sudoku.hs

module Main where
 
import Data.List hiding (lookup)
import Data.Array
import Control.Monad
import Data.Maybe
 
-- Types
type Digit  = Char
type Square = (Char,Char)
type Unit   = [Square]
 
-- We represent our grid as an array
type Grid = Array Square [Digit]
 
 
-- Setting Up the Problem
rows = "ABCDEFGHI"
cols = "123456789"
digits = "123456789"
box = (('A','1'),('I','9'))
 
cross :: String -> String -> [Square]
cross rows cols = [ (r,c) | r <- rows, c <- cols ]
 
squares :: [Square]
squares = cross rows cols  -- [('A','1'),('A','2'),('A','3'),...]
 
peers :: Array Square [Square]
peers = array box [(s, set (units!s)) | s <- squares ]
      where
        set = nub . concat
 
unitlist :: [Unit]
unitlist = [ cross rows [c] | c <- cols ] ++
            [ cross [r] cols | r <- rows ] ++
            [ cross rs cs | rs <- ["ABC","DEF","GHI"], 
                            cs <- ["123","456","789"]]
 
-- this could still be done more efficiently, but what the heck...
units :: Array Square [Unit]
units = array box [(s, [filter (/= s) u | u <- unitlist, s `elem` u ]) | 
                    s <- squares]
 
 
allPossibilities :: Grid
allPossibilities = array box [ (s,digits) | s <- squares ]
 
-- Parsing a grid into an Array
parsegrid     :: String -> Maybe Grid
parsegrid g    = do regularGrid g
                    foldM assign allPossibilities (zip squares g)
 
   where  regularGrid   :: String -> Maybe String
          regularGrid g  = if all (`elem` "0.-123456789") g
                              then Just g
                              else Nothing
 
-- Propagating Constraints
assign        :: Grid -> (Square, Digit) -> Maybe Grid
assign g (s,d) = if d `elem` digits
                 -- check that we are assigning a digit and not a '.'
                  then do
                    let ds = g ! s
                        toDump = delete d ds
                    foldM eliminate g (zip (repeat s) toDump)
                  else return g
 
eliminate     ::  Grid -> (Square, Digit) -> Maybe Grid
eliminate g (s,d) = 
  let cell = g ! s in
  if d `notElem` cell then return g -- already eliminated
  -- else d is deleted from s' values
    else do let newCell = delete d cell
                newV = g // [(s,newCell)]
            newV2 <- case newCell of
            -- contradiction : Nothing terminates the computation
                 []   -> Nothing
            -- if there is only one value left in s, remove it from peers
                 [d'] -> do let peersOfS = peers ! s
                            foldM eliminate newV (zip peersOfS (repeat d'))
            -- else : return the new grid
                 _    -> return newV
            -- Now check the places where d appears in the peers of s
            foldM (locate d) newV2 (units ! s)
 
locate :: Digit -> Grid -> Unit -> Maybe Grid
locate d g u = case filter ((d `elem`) . (g !)) u of
                []  -> Nothing
                [s] -> assign g (s,d)
                _   -> return g
 
-- Search
search :: Grid -> Maybe Grid
search g = 
  case [(l,(s,xs)) | (s,xs) <- assocs g, let l = length xs, l /= 1] of
            [] -> return g
            ls -> do let (_,(s,ds)) = minimum ls
                     msum [assign g (s,d) >>= search | d <- ds]
 
solve :: String -> Maybe Grid
solve str = do
    grd <- parsegrid str
    search grd
 
-- Display solved grid
printGrid :: Grid -> IO ()
printGrid = putStrLn . gridToString
 
gridToString :: Grid -> String
gridToString g =
  let l0 = elems g
      -- [("1537"),("4"),...]   
      l1 = (map (\s -> " " ++ s ++ " ")) l0
      -- ["1 "," 2 ",...] 
      l2 = (map concat . sublist 3) l1
      -- ["1  2  3 "," 4  5  6 ", ...]
      l3 = (sublist 3) l2
      -- [["1  2  3 "," 4  5  6 "," 7  8  9 "],...] 
      l4 = (map (concat . intersperse "|")) l3
      -- ["1  2  3 | 4  5  6 | 7  8  9 ",...]
      l5 = (concat . intersperse [line] . sublist 3) l4
  in unlines l5 
     where sublist n [] = []
           sublist n xs = ys : sublist n zs
             where (ys,zs) = splitAt n xs
           line = hyphens ++ "+" ++ hyphens ++ "+" ++ hyphens
           hyphens = replicate 9 '-'
 
main :: IO ()
main = do
    grids <- fmap lines $ readFile "top95.txt"
    mapM_ printGrid $ mapMaybe solve grids