import System.Environment
import System.IO
import Data.List
type Cell = (Int,Int)
type F = Cell -> [Int]
allCells :: [Cell]
allCells = [(i,j) | i <- [1..9],
j <- [1..9]]
-- Solver
solveSudoku :: [F] -> [F]
solveSudoku fl = foldr searchFor fl allCells
--
-- Iterate over all cells (from the right) with 'foldr' and apply
-- the function 'searchFor' to each cell with the list 'fl' of
-- possible values, the function 'searchFor' produces a new list
-- of possible values; then, the 'searchFor' is called again with
-- the new list and the next cell, and so on.
searchFor :: Cell -> [F] -> [F]
searchFor c fl' = [adjustCells (c,v) f | f <- fl',
v <- f c]
--
-- For the cell c try all possible values with 'v <- f c'
adjustCells :: (Cell,Int) -> F -> F
adjustCells (p@(i,j),v) t q@(x,y) =
if p==q then [v] else
if x==i || y==j || e x i && e y j
then delete v (t q)
else t q
where e m n = (div (m-1) 3) == (div (n-1) 3)
--
-- If the value v is guessed for the cell (i,j), the possible
-- values of the affected cells are to be adjusted with 'delete v (f q)'
-- Input Output
displaySolution :: F -> String
displaySolution f = unlines [unwords [show $ head (f (i,j))
| j <- [1..9]]
| i <- [1..9]]
ntoS :: (Show a) => [a] -> String
ntoS [] = ""
ntoS (x:xs) = (show x) ++ ntoS xs
fillS :: (Show a) => [a] -> String
fillS a = fst $ splitAt 9 $ (ntoS a) ++ "_________"
displayStep :: F -> String
displayStep f = unlines [unwords [fillS (f (i,j))
| j <- [1..9]]
| i <- [1..9]]
getProblem :: String -> [(Cell,Int)]
getProblem s = [(p,v) | (p,v) <- zip allCells $ map read (lines s >>= words), v > 0]
--
-- The Sudoku to be solved, a list with the given numbers
-- [((1,3),5), ..., ((9,8),7)]
initializeSolver :: String -> F
initializeSolver s = foldr adjustCells (const [1..9]) (getProblem s)
--
-- All possible values for each cell adjusted with the given values
-- of the problem
-- Main
main = do
args <- getArgs
case args of
[filename] -> do
s <- readFile filename
putStrLn "\n>>> The Sudoku problem is ...\n"
putStrLn s
putStrLn "\n>>> The first step ...\n"
putStr $ unlines $ map displayStep [initializeSolver s]
putStrLn ">>> Wait a while ...\n"
let solutions = solveSudoku [initializeSolver s]
nb = length solutions
putStr $ unlines $ map displaySolution $ solutions
putStr ">>> There are solutuions: "
print nb
--
[] -> error "Usage: maggesi_sudoku.exe filename"
_ -> error "Too many arguments"
--
-- The end