Sudoku

import MonadNondet (option)
import Sudoku
import System
import Control.Monad
 
forM = flip mapM
 
solve = forM [(i,j) | i <- [1..9], j <- [1..9]] $ \(i,j) -> do
    v <- valAt (i,j)       -- ^ for each board position
    when (v == 0) $ do     -- if it's empty (we represent that with a 0)
        a <- option [1..9] -- pick a number
        place (i,j) a      -- and try to put it there
 
main = do
    [f] <- getArgs
    xs <- readFile f
    putStrLn . evalSudoku $ do { readSudoku xs; solve; showSudoku }

{-# OPTIONS_GHC -fglasgow-exts #-}
module Sudoku 
    (Sudoku,
     readSudoku,
     runSudoku,
     evalSudoku,
     execSudoku,
     showSudoku,
     valAt, rowAt, colAt, boxAt,
     place)
     where
import Data.Array.Diff
import MonadNondet
import Control.Monad.State
 
-- Nondet here is a drop-in replacement for [] (the list monad) which just runs a little faster.
newtype Sudoku a = Sudoku (StateT (DiffUArray (Int,Int) Int) Nondet a)
    deriving (Functor, Monad, MonadPlus)
 
{- -- That is, we could also use the following, which works exactly the same way.
newtype Sudoku a = Sudoku (StateT (DiffUArray (Int,Int) Int) [] a)
    deriving (Functor, Monad, MonadPlus)
-}
 
initialSudokuArray = listArray ((1,1),(9,9)) [0,0..]
 
runSudoku (Sudoku k) = runNondet (runStateT k initialSudokuArray)
 
evalSudoku = fst . runSudoku
execSudoku = snd . runSudoku
 
showSudoku = Sudoku $ do
    a <- get
    return $ unlines [unwords [show (a ! (i,j)) | j <- [1..9]] | i <- [1..9]]
 
readSudoku :: String -> Sudoku ()
readSudoku xs = sequence_ $ do
    (i,ys) <- zip [1..9] (lines xs)
    (j,n)  <- zip [1..9] (words ys)
    return $ place (i,j) (read n)
 
valAt' (i,j) = do
    a <- get
    return (a ! (i,j))
 
rowAt' (i,j) = mapM valAt' [(i, k) | k <- [1..9]]
 
colAt' (i,j) = mapM valAt' [(k, j) | k <- [1..9]] 
 
boxAt' (i,j) = mapM valAt' [(i' + u, j' + v) | u <- [1..3], v <- [1..3]]
  where i' = ((i-1) `div` 3) * 3
        j' = ((j-1) `div` 3) * 3
 
valAt = Sudoku . valAt'
rowAt = Sudoku . rowAt'
colAt = Sudoku . colAt'
boxAt = Sudoku . boxAt'
 
-- This is the least trivial part.
-- It just guards to make sure that the move is legal,
-- and updates the array in the state if it is.
place :: (Int,Int) -> Int -> Sudoku ()
place (i,j) n = Sudoku $ do
    v <- valAt' (i,j)
    when (v == 0 && n /= 0) $ do
        rs <- rowAt' (i,j)
        cs <- colAt' (i,j)
        bs <- boxAt' (i,j)
        guard $ not . any (== n) $ rs ++ cs ++ bs
        a <- get
        put (a // [((i,j),n)])

{-# OPTIONS_GHC -fglasgow-exts #-}
 
module MonadNondet where
 
import Control.Monad
import Control.Monad.Trans
 
import Control.Monad.Identity
 
newtype NondetT m a
  = NondetT { foldNondetT :: (forall b. (a -> m b -> m b) -> m b -> m b) }
 
runNondetT :: (Monad m) => NondetT m a -> m a
runNondetT m = foldNondetT m (\x xs -> return x) (error "No solution found.")
 
instance (Functor m) => Functor (NondetT m) where
  fmap f (NondetT g) = NondetT (\cons nil -> g (cons . f) nil)
 
instance (Monad m) => Monad (NondetT m) where
  return a = NondetT (\cons nil -> cons a nil)
  m >>= k  = NondetT (\cons nil -> foldNondetT m (\x -> foldNondetT (k x) cons) nil)
 
instance (Monad m) => MonadPlus (NondetT m) where
  mzero         = NondetT (\cons nil -> nil)
  m1 `mplus` m2 = NondetT (\cons -> foldNondetT m1 cons . foldNondetT m2 cons)
 
instance MonadTrans NondetT where
  lift m = NondetT (\cons nil -> m >>= \a -> cons a nil)
 
newtype Nondet a = Nondet (NondetT Identity a) deriving (Functor, Monad, MonadPlus)
runNondet (Nondet x) = runIdentity (runNondetT x)
 
foldNondet :: Nondet a -> (a -> b -> b) -> b -> b
foldNondet (Nondet nd) cons nil =
   runIdentity $ foldNondetT nd (\x xs -> return (cons x (runIdentity xs))) (return nil)
 
option :: (MonadPlus m) => [a] -> m a
option = msum . map return

import System
import Control.Monad
import Data.List
import Data.Array.IO
 
type SodokuBoard = IOArray Int Int
 
main = do
    [f] <- getArgs
    a <- newArray (1, 81) 0
    readFile f >>= readSodokuBoard a
    putStrLn "Original:"
    printSodokuBoard a
    putStrLn "Solutions:"
    solve a (1,1)
 
readSodokuBoard a xs = sequence_ $ do (i,ys) <- zip [1..9] (lines xs)
                                      (j,n)  <- zip [1..9] (words ys)
                                      return $ writeBoard a (j,i) (read n)
 
printSodokuBoard a =
   let printLine a y =
     mapM (\x -> readBoard a (x,y)) [1..9] >>= mapM_ (putStr . show) in
                     putStrLn "-----------" >> 
                     mapM_ (\y -> putStr "|" >> printLine a y >> putStrLn "|") [1..9] >> 
                     putStrLn "-----------"
 
-- the meat of the program.  Checks the current square.
-- If 0, then get the list of nums and try to "solve' "
-- Otherwise, go to the next square.
solve :: SodokuBoard  -> (Int, Int) -> IO (Maybe SodokuBoard)
solve a (10,y) = solve a (1,y+1)
solve a (_, 10)= printSodokuBoard a >> return (Just a)
solve a (x,y)  = do v <- readBoard a (x,y)
                    case v of
                      0 -> availableNums a (x,y) >>= solve' a (x,y)
                      _ ->  solve a (x+1,y)
     -- solve' handles the backtacking
  where solve' a (x,y) []     = return Nothing
        solve' a (x,y) (v:vs) = do writeBoard a (x,y) v   -- put a guess onto the board
                                   r <- solve a (x+1,y)
                                   writeBoard a (x,y) 0   -- remove the guess from the board
                                   solve' a (x,y) vs      -- recurse over the remainder of the list
 
-- get the "taken" numbers from a row, col or box.
getRowNums a y = sequence [readBoard a (x',y) | x' <- [1..9]]
getColNums a x = sequence [readBoard a (x,y') | y' <- [1..9]]
getBoxNums a (x,y) = sequence [readBoard a (x'+u, y'+v) | u <- [0..2], v <- [0..2]] 
  where x' = (3 * ((x-1) `quot` 3)) + 1
        y' = (3 * ((y-1) `quot` 3)) + 1
 
-- return the numbers that are available for a particular square
availableNums a (x,y) = do r <- getRowNums a y 
                           c <- getColNums a x
                           b <- getBoxNums a (x,y)
                           return $ [0..9] \\ (r `union` c `union` b)  
 
-- aliases of read and write array that flatten the index
readBoard a (x,y) = readArray a (x+9*(y-1))
writeBoard a (x,y) e = writeArray a (x+9*(y-1)) e

module Sudoku where
 
{-
  This is inspired by John Hughes "Why Functional Programming Matters".
  We build a complete decision tree.
  That is, all alternatives in a certain depth
  have the same number of determined values.
  At the bottom of the tree all possible solutions can be found.
  Actually the algorithm is very stupid:
  In each depth we look for the field with the least admissible choices of numbers
  and prune the alternative branches for the other fields.
-}
 
import Data.Char (ord, chr)
import Data.Array (Array, range, (!), (//))
import Data.Tree (Tree)
import qualified Data.Tree as Tree
import Data.List (sort, minimumBy)
import Data.Maybe (catMaybes, isNothing, fromMaybe, fromJust)
import qualified Data.Array as Array
 
{-
Example:
 
ghci -Wall Sudoku.hs
 
*Sudoku> mapM putCLn (solutions exampleHawiki0)
-}
 
 
{- [[ATree]] contains a list of possible alternatives for each position -}
data ATree a = ANode T [[ATree a]]
 
type Coord   = Int
type Address = (Int,Int,Int,Int)
type Element = Int
 
type T        = Array Address (Maybe Element)
type Complete = Array Address Element
 
fieldBounds :: (Address, Address)
fieldBounds = ((0,0,0,0), (2,2,2,2))
 
squareRange :: [(Coord, Coord)]
squareRange = range ((0,0), (2,2))
 
alphabet :: [Element]
alphabet = [1..9]
 
 
 
{- * solution -}
 
{-
  Given two sorted lists,
  remove the elements of the first list from the second one.
-}
deleteSorted :: Ord a => [a] -> [a] -> [a]
deleteSorted [] ys = ys
deleteSorted _  [] = []
deleteSorted (x:xs) (y:ys) =
   case compare x y of
      EQ -> deleteSorted xs ys
      LT -> deleteSorted xs (y:ys)
      GT -> y : deleteSorted (x:xs) ys
 
admissibleNumbers :: [[Maybe Element]] -> [Element]
admissibleNumbers =
   foldl (flip deleteSorted) alphabet .
   map (sort . catMaybes)
 
admissibleAdditions :: T -> Address -> [Element]
admissibleAdditions sudoku (i,j,k,l) =
   admissibleNumbers (map ($ sudoku)
      [selectRow    (i,k),
       selectColumn (j,l),
       selectSquare (i,j)])
 
allAdmissibleAdditions :: T -> [(Address, [Element])]
allAdmissibleAdditions sudoku =
   let adds addr =
          (addr, admissibleAdditions sudoku addr)
   in  map adds
           (map fst (filter (isNothing . snd)
                            (Array.assocs sudoku)))
 
 
 
solutionTree :: T -> ATree T
solutionTree sudoku =
   let new (addr,elms) =
          map (\elm -> solutionTree (sudoku // [(addr, Just elm)])) elms
   in  ANode sudoku (map new (allAdmissibleAdditions sudoku))
 
treeAltToStandard :: ATree T -> Tree T
treeAltToStandard (ANode sudoku subs) =
   Tree.Node sudoku (concatMap (map treeAltToStandard) subs)
 
{- Convert a tree with alternatives for each position (ATree)
   into a normal tree by choosing one position and its alternative values.
   We need to consider only one position per level
   because the remaining positions are processed in the sub-levels.
   With other words: Choosing more than one position
   would lead to multiple reports of the same solution.
 
   For reasons of efficiency
   we choose the position with the least number of alternatives.
   If this number is zero, the numbers tried so far are wrong.
   If this number is one, then the choice is unique, but maybe still wrong.
   If the number of alternatives is larger,
   we have to check each alternative.
-}
treeAltToStandardOptimize :: ATree T -> Tree T
treeAltToStandardOptimize (ANode sudoku subs) =
   let chooseMinLen [] = []
       chooseMinLen xs = minimumBy compareLength xs
   in  Tree.Node sudoku (chooseMinLen
          (map (map treeAltToStandardOptimize) subs))
 
maybeComplete :: T -> Maybe Complete
maybeComplete sudoku =
   fmap (Array.array fieldBounds)
        (mapM (uncurry (fmap . (,))) (Array.assocs sudoku))
 
{- All leafs are at the same depth,
   namely the number of undetermined fields.
   That's why we can safely select all Sudokus at the lowest level. -}
solutions :: T -> [Complete]
solutions sudoku =
   let err = error "The lowest level should contain complete Sudokus only."
       {- "last'" is more efficient than "last" here
          because the program does not have to check
          whether deeper levels exist.
          We know that the tree is as deep
          as the number of undefined fields.
          This means that dropMatch returns a singleton list.
          We don't check that
          because then we would lose the efficiency again. -}
       last' = head . dropMatch (filter isNothing (Array.elems sudoku))
   in  map (fromMaybe err . maybeComplete)
           (last' (Tree.levels
             (treeAltToStandardOptimize (solutionTree sudoku))))
 
 
 
{- * transformations (can be used for construction, too) -}
 
standard :: Complete
standard =
   Array.listArray fieldBounds
      (map (\(i,j,k,l) -> mod (j+k) 3 * 3 + mod (i+l) 3 + 1)
           (range fieldBounds))
 
 
exampleHawiki0, exampleHawiki1 :: T
exampleHawiki0 = fromString (unlines [
      " 5  6   1",
      "  48   7 ",
      "8      52",
      "2   57 3 ",
      "         ",
      " 3 69   5",
      "79      8",
      " 1   65  ",
      "5   3  6 "
   ])
 
exampleHawiki1 = fromString (unlines [
      "    6  8 ",
      " 2       ",
      "  1      ",
      " 7    1 2",
      "5   3    ",
      "      4  ",
      "  42 1   ",
      "3  7  6  ",
      "       5 "
   ])
 
 
 
 
check :: Complete -> Bool
check sudoku =
   let checkParts select =
          all (\addr -> sort (select addr sudoku) == alphabet) squareRange
   in  all checkParts [selectRow, selectColumn, selectSquare]
 
selectRow, selectColumn, selectSquare ::
   (Coord,Coord) -> Array Address element -> [element]
selectRow (i,k) sudoku =
   map (sudoku!) (range ((i,0,k,0), (i,2,k,2)))
--   map (sudoku!) (map (\(j,l) -> (i,j,k,l)) squareRange)
selectColumn (j,l) sudoku =
   map (sudoku!) (range ((0,j,0,l), (2,j,2,l)))
selectSquare (i,j) sudoku =
   map (sudoku!) (range ((i,j,0,0), (i,j,2,2)))
 
 
{- * conversion from and to strings -}
 
put, putLn :: T -> IO ()
put   sudoku = putStr   (toString sudoku)
putLn sudoku = putStrLn (toString sudoku)
 
putC, putCLn :: Complete -> IO ()
putC   sudoku = putStr   (toString (fmap Just sudoku))
putCLn sudoku = putStrLn (toString (fmap Just sudoku))
 
fromString :: String -> T
fromString str =
   Array.array fieldBounds (concat
      (zipWith (\(i,k) -> map (\((j,l),x) -> ((i,j,k,l),x)))
         squareRange
         (map (zip squareRange . map charToElem) (lines str))))
 
toString :: T -> String
toString sudoku =
   unlines
      (map (\(i,k) -> map (\(j,l) -> elemToChar (sudoku!(i,j,k,l)))
                          squareRange)
           squareRange)
 
charToElem :: Char -> Maybe Element
charToElem c =
   toMaybe ('0'<=c && c<='9') (ord c - ord '0')
 
elemToChar :: Maybe Element -> Char
elemToChar =
   maybe ' ' (\c -> chr (ord '0' + c))
 
 
{- * helper functions -}
 
nest :: Int -> (a -> a) -> a -> a
nest 0 _ x = x
nest n f x = f (nest (n-1) f x)
 
toMaybe :: Bool -> a -> Maybe a
toMaybe False _ = Nothing
toMaybe True  x = Just x
 
compareLength :: [a] -> [b] -> Ordering
compareLength (_:xs) (_:ys) = compareLength xs ys
compareLength []     []     = EQ
compareLength (_:_)  []     = GT
compareLength []     (_:_)  = LT
 
{- | Drop as many elements as the first list is long -}
dropMatch :: [b] -> [a] -> [a]
dropMatch xs ys =
   map fromJust (dropWhile isNothing
      (zipWith (toMaybe . null) (iterate (drop 1) xs) ys))

{-# OPTIONS_GHC -fglasgow-exts #-}
 
-- Solve a Sudoku puzzle
 
module Sudoku where
 
import Control.Monad.State
import Data.Maybe (maybeToList)
import Data.List (delete)
 
type Value = Int
type Cell = (Int, Int) -- One-based coordinates
 
type Puzzle  = [[Maybe Value]]
type Solution = [[Value]]
 
-- The size of the puzzle.
sqrtSize :: Int
sqrtSize = 3
size = sqrtSize * sqrtSize
 
-- Besides the rows and columns, a Sudoku puzzle contains s blocks
-- of s cells each, where s = size.
blocks :: [[Cell]]
blocks = [[(x + i, y + j) | i <- [1..sqrtSize], j <- [1..sqrtSize]] |
          x <- [0,sqrtSize..size-sqrtSize],
          y <- [0,sqrtSize..size-sqrtSize]]
 
-- The one-based number of the block that a cell is contained in.
blockNum :: Cell -> Int
blockNum (row, col) = row - (row - 1) `mod` sqrtSize + (col - 1) `div` sqrtSize
 
-- When a Sudoku puzzle has been partially filled in, the following
-- data structure represents the remaining options for how to proceed.
data Options = Options {
    cellOpts :: [[[Value]]], -- For each cell, a list of possible values
    rowOpts  :: [[[Cell ]]], -- For each row    and value, a list of cells
    colOpts  :: [[[Cell ]]], -- For each column and value, a list of cells
    blkOpts  :: [[[Cell ]]]  -- For each block  and value, a list of cells
  } deriving Show
modifyCellOpts f = do {opts <- get; put $ opts {cellOpts = f $ cellOpts opts}}
modifyRowOpts  f = do {opts <- get; put $ opts {rowOpts  = f $ rowOpts  opts}}
modifyColOpts  f = do {opts <- get; put $ opts {colOpts  = f $ colOpts  opts}}
modifyBlkOpts  f = do {opts <- get; put $ opts {blkOpts  = f $ blkOpts  opts}}
 
-- The full set of initial options, before any cells are constrained
initOptions :: Options
initOptions = Options {
  cellOpts = [[[1..size] | _ <- [1..size]] | _ <- [1..size]],
  rowOpts  = [[[(r, c)   | c <- [1..size]] | _ <- [1..size]] | r <- [1..size]],
  colOpts  = [[[(r, c)   | r <- [1..size]] | _ <- [1..size]] | c <- [1..size]],
  blkOpts  = [[b         | _ <- [1..size]] | b <- blocks]}
 
solve :: Puzzle -> [Solution]
solve puz = evalStateT (initPuzzle >> solutions) initOptions
  where
    initPuzzle =
      sequence_ [fixCell v (r, c) | (row, r) <- zip puz [1..],
                                    (val, c) <- zip row [1..],
                                    v <- maybeToList val]
 
-- Build a list of all possible solutions given the current options.
-- We use a list monad INSIDE a state monad. That way,
-- the state is re-initialized on each element of the list iteration,
-- allowing backtracking when an attempt fails (with mzero).
solutions :: StateT Options [] Solution
solutions = solveFromRow 1
  where
    solveFromRow r
     | r > size  = return []
     | otherwise = do
         row  <- solveRowFromCol r 1
         rows <- solveFromRow $ r + 1
         return $ row : rows
    solveRowFromCol r c
     | c > size  = return []
     | otherwise = do
         vals <- gets $ (!! (c - 1)) . (!! (r - 1)) . cellOpts
         val <- lift vals
         fixCell val (r, c)
         row <- solveRowFromCol r (c + 1)
         return $ val : row
 
-- Fix the value of a cell.
-- More specifically - update Options to reflect the given value at
-- the given cell, or mzero if that is not possible.
fixCell :: (MonadState Options m, MonadPlus m) =>
           Value -> Cell -> m ()
fixCell val cell@(row, col) = do
    vals <- gets $ (!! (col - 1)) . (!! (row - 1)) . cellOpts
    guard $ val `elem` vals
    modifyCellOpts $ replace2 row col [val]
    modifyRowOpts  $ replace2 row val [cell]
    modifyColOpts  $ replace2 col val [cell]
    modifyBlkOpts  $ replace2 blk val [cell]
    sequence_ [constrainCell v   cell     | v <- [1..size], v /= val]
    sequence_ [constrainCell val (row, c) | c <- [1..size], c /= col]
    sequence_ [constrainCell val (r, col) | r <- [1..size], r /= row]
    sequence_ [constrainCell val c | c <- blocks !! (blk - 1), c /= cell]
  where
    blk = blockNum cell
 
-- Assert that the given value cannot occur in the given cell.
-- Fail with mzero if that means that there are no options left.
constrainCell :: (MonadState Options m, MonadPlus m) =>
                 Value -> Cell -> m ()
constrainCell val cell@(row, col) = do
    constrainOpts row col val  cellOpts modifyCellOpts (flip fixCell cell)
    constrainOpts row val cell rowOpts  modifyRowOpts  (fixCell val)
    constrainOpts col val cell colOpts  modifyColOpts  (fixCell val)
    constrainOpts blk val cell blkOpts  modifyBlkOpts  (fixCell val)
  where
    blk = blockNum cell
    constrainOpts x y z getOpts modifyOpts fixOpts = do
      zs <- gets $ (!! (y - 1)) . (!! (x - 1)) . getOpts
      case zs of
        [z']  -> guard (z' /= z)
        [_,_] -> when (z `elem` zs) $ fixOpts (head $ delete z zs)
        (_:_) -> modifyOpts $ replace2 x y (delete z zs)
        _     -> mzero
 
-- Replace one element of a list.
-- Coordinates are 1-based.
replace :: Int -> a -> [a] -> [a]
replace i x (y:ys)
 | i > 1     = y : replace (i - 1) x ys
 | otherwise = x : ys
replace _ _ _ = []
 
-- Replace one element of a 2-dimensional list.
-- Coordinates are 1-based.
replace2 :: Int -> Int -> a -> [[a]] -> [[a]]
replace2 i j x (y:ys)
 | i > 1     = y : replace2 (i - 1) j x ys
 | otherwise = replace j x y : ys
replace2 _ _ _ _ = []

module Sudoku(Square, Board, ColDigit, RowDigit, BoxDigit, Digit, initialBoard, getBoard, mkSquare, setSquare, solveMany) where
import Char(intToDigit, digitToInt)
import List ((\\), sortBy)
 
-- A board is just a list of Squares.  It always has all the squares.
data Board = Board [Square]
	deriving (Show)
 
-- A Square contains its column (ColDigit), row (RowDigit), and
-- which 3x3 box it belongs to (BoxDigit).  The box can be computed
-- from the row and column, but is kept for speed.
-- A Square also contains it's status: either a list of possible
-- digits that can be placed in the square OR a fixed digit (i.e.,
-- the square was given by a clue or has been solved).
data Square = Square ColDigit RowDigit BoxDigit (Either [Digit] Digit)
	deriving (Show)
 
type ColDigit = Digit
type RowDigit = Digit
type BoxDigit = Digit
type Digit = Char	-- '1' .. '9'
 
-- The initial board, no clues given so all digits are possible in all squares.
initialBoard :: Board
initialBoard = Board [ Square col row (boxDigit col row) (Left allDigits) |
		       row <- allDigits, col <- allDigits ]
 
-- Return a list of rows of a solved board.
-- If used on an unsolved board the return value is unspecified.
getBoard :: Board -> [[Char]]
getBoard (Board sqs) = [ [ getDigit d | Square _ row' _ d <- sqs, row' == row ] | row <- allDigits ]
  where getDigit (Right d) = d
        getDigit _ = '0'
 
allDigits :: [Char]
allDigits = ['1' .. '9']
 
-- Compute the box from a column and row.
boxDigit :: ColDigit -> RowDigit -> BoxDigit
boxDigit c r = intToDigit $ (digitToInt c - 1) `div` 3 + (digitToInt r - 1) `div` 3 * 3 + 1
 
-- Given a column, row, and a digit make a (solved) square representing this.
mkSquare :: ColDigit -> RowDigit -> Digit -> Square
mkSquare col row c | col `elem` allDigits && row `elem` allDigits && c `elem` allDigits 
                   = Square col row (boxDigit col row) (Right c)
mkSquare _ _ _ = error "Bad mkSquare"
 
-- Place a given Square on a Board and return the new Board.
-- Illegal setSquare calls will just error out.  The main work here
-- is to remove the placed digit from the other Squares on the board
-- that are in the same column, row, or box.
setSquare :: Square -> Board -> Board
setSquare sq@(Square scol srow sbox (Right d)) (Board sqs) = Board (map set sqs)
  where set osq@(Square col row box ds) =
	    if col == scol && row == srow then sq
	    else if col == scol || row == srow || box == sbox then (Square col row box (sub ds))
	    else osq
	sub (Left ds) = Left (ds \\ [d])
        sub (Right d') | d == d' = error "Impossible setSquare"
	sub dd = dd
setSquare _ _ = error "Bad setSquare"
 
-- Get the unsolved Squares from a Board.
getLeftSquares :: Board -> [Square]
getLeftSquares (Board sqs) = [ sq | sq@(Square _ _ _ (Left _)) <- sqs ]
 
-- Given an initial Board return all the possible solutions starting
-- from that Board.
-- Note, this all happens in the list monad and makes use of lazy evaluation
-- to avoid work.  Using the list monad automatically handles all the backtracking
-- and enumeration of solutions.
solveMany :: Board -> [Board]
solveMany brd =
    case getLeftSquares brd of
    [] -> return brd            -- Nothing unsolved remains, we are done.
    sqs -> do
	-- Sort the unsolved Squares by the ascending length of the possible
	-- digits.  Pick the first of those so we always solve forced Squares
	-- first.
	let Square c r b (Left ds) : _ = sortBy leftLen sqs
	    leftLen (Square _ _ _ (Left ds1)) (Square _ _ _ (Left ds2)) = compare (length ds1) (length ds2)
	    leftLen _ _ = error "bad leftLen"
        sq <- [ Square c r b (Right d) | d <- ds ] -- Try all possible moves
        solveMany (setSquare sq brd) -- And solve the extended Board.

module Main where
import Sudoku
 
--         Col    Row   Digit
solve :: [((Char, Char), Char)] -> [[Char]]
solve crds =
    let brd = foldr add initialBoard crds
        add ((c, r), d) = setSquare (mkSquare c r d)
    in  case solveMany brd of
	[] -> error "No solutions"
        b : _ -> getBoard b
 
-- The parse assumes that squares without a clue
-- contain '0'.
main = interact $
     unlines .                                             -- turn it into lines
     map (concatMap (:" ")) .                              -- add a space after each digit for readability
     solve .                                               -- solve the puzzle
     filter ((`elem` ['1'..'9']) . snd) .                  -- get rid of non-clues
     zip [ (c, r) | r <- ['1'..'9'], c <- ['1'..'9'] ] .   -- pair up the digits with their coordinates
     filter (`elem` ['0'..'9'])                            -- get rid of non-digits

import List
 
main = putStr . unlines . map disp . solve . return . input =<< getContents
 
solve s = foldr (\p l -> [mark (p,n) s | s <- l, n <- s p]) s idx
 
mark (p@(i,j),n) s q@(x,y)
    | p == q                             = [n]
    | x == i || y == j || e x i && e y j = delete n (s q)
    | otherwise                          = s q
    where e a b = div (a-1) 3 == div (b-1) 3
 
disp s = unlines [unwords [show $ head $ s (i,j) | j <- [1..9]] | i <- [1..9]]
 
input s = foldr mark (const [1..9]) $
  [(p,n) | (p,n) <- zip idx $ map read $ lines s >>= words, n>0]
 
idx = [(i,j) | i <- [1..9], j <- [1..9]]