Skip to content

Instantly share code, notes, and snippets.

@mdunsmuir
Last active August 29, 2015 14:14
Show Gist options
  • Save mdunsmuir/7f4cf226ce678b62f166 to your computer and use it in GitHub Desktop.
Save mdunsmuir/7f4cf226ce678b62f166 to your computer and use it in GitHub Desktop.
Sudoku
5 6 1
48 7
8 52
2 57 3
3 69 5
79 8
1 65
5 3 6
{-# 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"
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment