Sudoku

board.txt

 5  6   1
  48   7 
8      52
2   57 3 
         
 3 69   5
79      8
 1   65  
5   3  6 

Hudooku.hs

{-# LANGUAGE TupleSections #-}

import System.Environment
import Control.Monad
import qualified Data.Attoparsec.Text as P
import Data.Maybe
import Data.List
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import qualified Data.Map as M
import qualified Data.Set as S

type Board = M.Map (Integer, Integer) Integer

printBoard :: Board -> IO ()
printBoard b = do
  forM_ [0..8] $ \y -> do
    forM_ [0..8] $ \x -> 
      let str = case M.lookup (x, y) b of
                  Just x -> show x
                  Nothing -> " "
      in  putStr str
    putStrLn ""
      

{-
  parse board
-}

parseBoard :: P.Parser Board
parseBoard = do
  let b = M.empty :: Board
  parseLine 0 b

parseLine :: Integer -> Board -> P.Parser Board
parseLine y b = do
  line <- P.takeWhile (\c -> S.member c (S.fromList (' ' : ['1'..'9'])))
  let b' = foldl' (\b (x, c) -> if c == ' ' then b else M.insert (x, y) (fromIntegral (fromEnum c - 48)) b) b (zip [0..] (T.unpack line))
  end <- P.atEnd
  if end
    then return b'
    else P.endOfLine >> parseLine (y + 1) b'

loadBoard :: String -> IO (Maybe Board)
loadBoard path = do
  fileData <- TIO.readFile path
  let eitherBoard = P.parseOnly parseBoard fileData
  case eitherBoard of
    Right b -> return $ Just b
    Left _ -> return $ Nothing

{-
  board querying
-}

digitsInSubgroup :: (Integer, Integer) -> Board -> S.Set Integer
digitsInSubgroup (x, y) b
  = let
      x_group = x `div` 3
      y_group = y `div` 3
    in
      S.fromList $ do
        x <- [0..2]
        y <- [0..2]
        let maybeDig = M.lookup (x + x_group * 3, y + y_group * 3) b
        case maybeDig of
          Just dig -> return dig
          Nothing -> []

digitsInLine :: (Integer -> (Integer, Integer)) -> Board -> S.Set Integer
digitsInLine f b
  = S.fromList $ do
      d <- [0..8]
      let maybeDig = M.lookup (f d) b
      case maybeDig of
        Just dig -> return dig
        Nothing -> []

digitsInColumn :: Integer -> Board -> S.Set Integer
digitsInColumn x = digitsInLine (x,)

digitsInRow :: Integer -> Board -> S.Set Integer
digitsInRow y = digitsInLine (,y)

{-
  constraint analysis
  this will solve boards that this program can solve without guessing
-}

allDigits = S.fromList [1..9]

allSquares = S.fromList $ do
  x <- [0..8]
  y <- [0..8]
  return (x, y)

possibleValuesForSquare :: (Integer, Integer) -> Board -> [Integer]
possibleValuesForSquare (x, y) b
  = let
      col = digitsInColumn x b
      row = digitsInRow y b
      subGroup = digitsInSubgroup (x, y) b
      all = S.union col $ S.union row subGroup
    in
      S.toList $ S.difference allDigits all

boardValid :: Board -> Bool
boardValid b
  = let 
      keys = M.keys b
      f k = let 
              x = fromJust $ M.lookup k b
              b' = M.delete k b
              possVals = possibleValuesForSquare k b'
            in length possVals == 1 && [x] == possVals
    in  all id $ map f keys

allPossibleValues :: Board -> [((Integer, Integer), [Integer])]
allPossibleValues b
  = let emptySquares = S.toList $ S.difference allSquares $ S.fromList $ M.keys b
    in  zip emptySquares $ fmap ((flip possibleValuesForSquare) b) emptySquares

solveStep :: Board -> Board
solveStep b
  = let
      possVals = allPossibleValues b
      singles = filter ((== 1) . length . snd) possVals
    in
      foldr (\(s, [x]) b -> M.insert s x b) b singles

solve :: Board -> Board
solve b =
  let b' = solveStep b
  in
    if b /= b'
      then solve b'
      else b

{-
  nondeterministic solver
-}

solveND = filter boardValid . nub . solveND'

{-
  ok so the 'solve' function above solves a board where a unique solution can
  be obtained by iteratively narrowing a single cell down to one value by
  looking at the digits in its subgroup, row, and column.

  but sometimes, we have to guess.

  this thing does the guessing.
-}
solveND' :: Board -> [Board]
solveND' b = do
  let b' = solve b
  if M.size b' == 81
    then return b'
    else do
      let 
        possVals = allPossibleValues b'
        s (_, xs) (_, ys) = length xs `compare` length ys
      guard $ length possVals > 0
      let (square, xs) = minimumBy s possVals -- hmm
      x <- xs
      solveND' $ M.insert square x b'

main = do
  args <- getArgs 
  if length args /= 1
    then putStrLn "gotta give a filename"
    else do
      mb <- loadBoard $ head args
      case mb of
        Just b -> 
          let bs = solveND b
          in if length bs > 0
               then printBoard $ head bs
               else putStrLn "no solutions found"
        Nothing -> putStrLn "board parse failed"