-- Solve sudoku!
-- General strategy:
-- -- Find item in cell.  Test it for each number possible in that cell.  Eliminate #'s from other cells.
-- -- Try next available item.

import Array
import Data.List
import Char

------------------- Some Test Boards ---------------------
filled = "123456789\
         \456789123\
         \789123456\
         \234567891\
         \567891234\
         \891234567\
         \345678912\
         \678912345\
         \912345678"

difficult = "013254900\
            \000007000\
            \845060000\
            \050610407\
            \000409000\
            \409038010\
            \000020186\
            \000100000\
            \006845270"

difficult2 = "000003060\
             \000000010\
             \097500080\
             \000090200\
             \008070400\
             \003060000\
             \010002890\
             \040000000\
             \050100000"

difficult3 = "010706000\
             \703000000\
             \020540000\
             \340000250\
             \500000001\
             \081000074\
             \000057080\
             \000000309\
             \000801040"

extreme = "054001900\
          \000400030\
          \300000501\
          \700380000\
          \040705010\
          \000094008\
          \503000009\
          \060008000\
          \009500820"
---------------- End Test Boards ---------------------

type Coord = (Int, Int)
type Board = Array Coord [Int]

---------------- Board Creation/Display -----------------

-- The board with no squares marked
emptyBoard = listArray ((0,0),(8,8)) [[1..9] | x <- [1..81]]

-- Turn a string of 81 digits into a Board.  0 represents
-- an unmarked square
prepStringBoard :: String -> Board
prepStringBoard s = foldl markSquare emptyBoard $
                    filter ((/= 0) . snd) $
                           zip [(r,c) | r <- [0..8], c <- [0..8]] $
                               map ((subtract $ ord '0') . ord) s

showBoard :: Board -> String
showBoard b = unlines [unwords [show $ head (b ! (r, c)) | c<-[0..8]] | r <-[0..8]]

---------------- Solving a Board -------------------

-- For a given square, return the list of squares that are
-- prohibited from having the same number as that square
affectedCoords :: Coord -> [Coord]
affectedCoords (r, c)
    = (zip (repeat r) [0..8]) ++ (zip [0..8] (repeat c))
      ++ [(x + a, y + b) | x <- delete r [0..2], y <- delete c [0..2]]
    where a = div r 3 * 3
          b = div c 3 * 3

-- Mark a square with a given number, and update the
-- rest of the board
markSquare :: Board -> (Coord, Int) -> Board
markSquare b (coord, m) = (b // zip coords (map (delete m . (b!)) coords)) // [(coord, [m])]
    where coords = affectedCoords coord

-- If we have JUST made a move at the given coordinate, so the board
-- has already been updated to reflect that move, was that move valid?
validMove :: Coord -> Board -> Bool
validMove coord b = null $ filter (null . (b!)) (affectedCoords coord)

-- From the current move, find the next move,
-- going left-to-right, top-to-bottom
nextMove :: Coord -> Coord
nextMove (r, c) = if c < 8 then (r,c+1) else (r+1,0)

-- Return a list of all possible solutions
-- Call with the second argument (0,0)
stepBoardList :: Board -> Coord -> [Board]
stepBoardList b (8, 8) = if null $ b ! (8,8) then [] else [b]
stepBoardList b (r, c) = concat [stepBoardList b (nextMove (r,c)) |
                                 b <- [markSquare b ((r, c), i) | i <- b ! (r, c)],
                                 validMove (r,c) b]

-- Human-friendly test.
-- Example: from ghci, call (testSolve extreme) to solve the "extreme" board
testSolve x = putStrLn $ showBoard $ head $ stepBoardList (prepStringBoard x) (0,0)