mdunsmuir · August 29, 2015 14:14 · Feb 8, 2015 · Feb 8, 2015
diff --git a/Hudooku.hs b/Hudooku.hs
@@ -21,6 +21,7 @@ printBoard b = do
                   Nothing -> " "
       in  putStr str
     putStrLn ""
+
 
 {-
   parse board
@@ -158,7 +159,7 @@ solveND' b = do
     else do
       let 
         possVals = allPossibleValues b'
-        s (_, xs) (_, ys) = xs `compare` ys
+        s (_, xs) (_, ys) = length xs `compare` length ys
       guard $ length possVals > 0
       let (square, xs) = minimumBy s possVals -- hmm
       x <- xs
@@ -176,4 +177,4 @@ main = do
           in if length bs > 0
                then printBoard $ head bs
                else putStrLn "no solutions found"
-        Nothing -> putStrLn "board parse failed"
+        Nothing -> putStrLn "board parse failed"
diff --git a/Hudooku.hs b/Hudooku.hs
@@ -0,0 +1,179 @@
+{-# 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) = xs `compare` 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"
diff --git a/board.txt b/board.txt
@@ -0,0 +1,9 @@
+ 5  6   1
+  48   7 
+8      52
+2   57 3 
+
+ 3 69   5
+79      8
+ 1   65  
+5   3  6
-Original file line number
+Diff line change
@@ -0,0 +1,9 @@
+6   1
+7
+52
+57 3
+69   5
+8
+65
+3  6
No results found