sudoku.hs

1 files changed, 194 insertions, 0 deletions

diff --git a/sudoku.hs b/sudoku.hs
new file mode 100644
index 0000000..d06ffd4
--- /dev/null
+++ b/sudoku.hs
@@ -0,0 +1,194 @@
+import Data.Maybe
+import Data.List
+import Data.Char
+import Test.QuickCheck
+
+data Sudoku = Sudoku [[Maybe Int]] 
+
+showElement :: Maybe Int -> String
+showElement (Nothing) = "."
+showElement (Just a) = show a
+
+showSudoku :: Sudoku -> String
+showSudoku (Sudoku s) = concatMap (\x->(concatMap showElement x)++"\n") s
+
+instance Show Sudoku where
+    show = showSudoku
+
+example :: Sudoku
+example =
+    Sudoku
+      [ [Just 3, Just 6, Nothing,Nothing,Just 7, Just 1, Just 2, Nothing,Nothing]
+      , [Nothing,Just 5, Nothing,Nothing,Nothing,Nothing,Just 1, Just 8, Nothing]
+      , [Nothing,Nothing,Just 9, Just 2, Nothing,Just 4, Just 7, Nothing,Nothing]
+      , [Nothing,Nothing,Nothing,Nothing,Just 1, Just 3, Nothing,Just 2, Just 8]
+      , [Just 4, Nothing,Nothing,Just 5, Nothing,Just 2, Nothing,Nothing,Just 9]
+      , [Just 2, Just 7, Nothing,Just 4, Just 6, Nothing,Nothing,Nothing,Nothing]
+      , [Nothing,Nothing,Just 5, Just 3, Nothing,Just 8, Just 9, Nothing,Nothing]
+      , [Nothing,Just 8, Just 3, Nothing,Nothing,Nothing,Nothing,Just 6, Nothing]
+      , [Nothing,Nothing,Just 7, Just 6, Just 9, Nothing,Nothing,Just 4, Just 3]
+      ]
+
+-- rows extracts the actual rows from the Sudoku
+rows :: Sudoku -> [[Maybe Int]]
+rows (Sudoku rs) = rs
+
+-- allBlankSudoku represents a Sudoku that only contains blank cells
+allBlankSudoku :: Sudoku
+allBlankSudoku = Sudoku $ take 9 (repeat ( take 9 (repeat Nothing) ))
+
+-- isSudoku 
+isSudoku :: Sudoku -> Bool
+isSudoku (Sudoku s) | length s /= 9 = False
+isSudoku (Sudoku s) | map length s /= take 9 (repeat 9) = False
+isSudoku (Sudoku s) = and (map (\x->(isNothing x || fromJust x `elem` [1..9])) (concat s))
+
+-- isSolved
+isSolved :: Sudoku -> Bool
+isSolved (Sudoku s) = not $ elem Nothing (concat s)
+
+-- printSudoku: print the Sudoku on the screen
+printSudoku :: Sudoku -> IO ()
+printSudoku s = putStr (show s)
+
+-- readSudoku
+readSudoku :: FilePath -> IO Sudoku
+readSudoku fn =
+    do sudokuData <- readFile fn
+       return (Sudoku (map
+                       (map (\x->(if x=='.' then Nothing else Just $ digitToInt x)))
+                       $ lines sudokuData))
+
+-- generate a cell
+cell :: Gen (Maybe Int)
+cell = frequency
+       [ (1, do a <- elements [1..9]
+                return (Just a)),
+         (9, return Nothing)
+       ]
+
+-- C2. Make Sudokus an instance of the class Arbitrary. 
+instance Arbitrary Sudoku where
+    arbitrary = do grid <- sequence (replicate 9 (sequence (replicate 9 cell)))
+                   return (Sudoku grid)
+
+prop_Sudoku :: Sudoku -> Bool
+prop_Sudoku s = isSudoku s
+
+type Block = [Maybe Int]
+
+-- isOkayBlock
+isOkayBlock :: Block -> Bool
+isOkayBlock b = length (nub y) == length y where y = [ x | x <- b, isJust x ]
+
+groupn :: Int -> [a] -> [[a]]
+groupn _ [] = []
+groupn n xs = (take n xs):(groupn n (drop n xs))
+
+-- blocks
+linesSudoku (Sudoku s) = s
+columnsSudoku (Sudoku s) = transpose s
+gridsSudoku (Sudoku s) = map concat $ concatMap (groupn 3) (map transpose (groupn 3 s))
+blocks :: Sudoku -> [Block]
+blocks s = linesSudoku s ++ columnsSudoku s ++ gridsSudoku s
+prop_Blocks s = length (blocks s) == 27 && and (map (==9) (map length (blocks s)))
+
+-- isOkay
+isOkay :: Sudoku -> Bool
+isOkay s = and (map isOkayBlock (blocks s))
+
+type Pos = (Int,Int)
+
+-- blank returns a blank position
+hasBlank :: Sudoku -> Maybe Int
+hasBlank (Sudoku s) = findIndex isNothing (concat s)
+
+toPos :: Int -> Pos
+toPos n = (n `div` 9, n `mod` 9)
+blank :: Sudoku -> Pos
+blank (Sudoku s) = toPos $ (fromJust (findIndex isNothing (drop n (concat s))))+n
+                   where n = 9*fewestNothingLine s
+blank (Sudoku s) = toPos (fromJust (findIndex (isNothing) (concat s)))
+
+fewestNothingLine :: [[Maybe Int]] -> Int
+fewestNothingLine s = snd $ minimum (filter (\x->fst x/=0)
+                                                (zip
+                                                 (map length (map (filter isNothing) s))
+                                                 [0..8]))
+fewestNothingCol s = fewestNothingLine (transpose s)
+
+prop_Blankcell :: Sudoku -> Property
+prop_Blankcell ss@(Sudoku s) =
+    elem Nothing (concat s) ==> (s !! x) !! y == Nothing where (x,y)=blank ss
+
+-- (!!=) updates a list 
+(!!=) :: [a] -> (Int,a) -> [a]
+(!!=) [] _ = []
+(!!=) (x:xs) (0,a) = a:xs
+(!!=) (x:xs) (n,a) = x:(xs !!= (n-1,a))
+
+prop_idxReplacs xs (n,x) =
+    n >=0 && length xs > n ==> (xs !!= (n,x)) !! n == x
+prop_ReplaceTake xs (n,x) =
+    n >=0 ==> take n (xs !!= (n,x)) == take n xs
+prop_ReplaceDrop xs (n,x) =
+    n >=0 ==> drop (n+1) (xs !!= (n,x)) == drop (n+1) xs
+
+-- update update a Sudoku
+update :: Sudoku -> Pos -> Maybe Int -> Sudoku
+update (Sudoku s) (x,y) a = Sudoku (s !!= (x, (s !! x) !!= (y, a)))
+
+data Position = Position (Int,Int) deriving Show
+instance Arbitrary Position where
+    arbitrary = do x <- elements [0..8]
+                   y <- elements [0..8]
+                   return (Position (x,y))
+
+prop_update :: Sudoku -> Position -> Maybe Int -> Property
+prop_update s (Position pos@(x,y)) a =
+    x `elem` [0..8] && y `elem` [0..8] ==>
+      getElem (update s pos a) pos == a
+          where getElem (Sudoku s) (x,y) = (s !! x) !! y
+
+
+solve :: Sudoku -> Maybe Sudoku
+solve s | not (isOkay s) = Nothing
+solve s | isNothing (hasBlank s) = Just s
+solve s = solveAux s (blank s) 1
+
+solveAux :: Sudoku -> Pos -> Int -> Maybe Sudoku
+solveAux _ _ 10 = Nothing
+solveAux s (x,y) a = if isNothing result then
+                         solveAux s (x,y) (a+1)
+                     else
+                         result
+    where news = update s (x,y) (Just a)
+          result = solve news
+
+readAndSolve :: FilePath -> IO ()
+readAndSolve fn =
+    do su <- readSudoku fn
+       let result = solve su
+       if isNothing result then
+           putStrLn "(no solution)"
+       else
+           printSudoku (fromJust result)
+
+-- isSolutionOf  checks, given two Sudokus,
+-- whether the first one is a solution (i.e. all blocks are okay, there are no blanks), 
+-- and also whether the first one is a solution of the second one 
+isSolutionOf :: Sudoku -> Sudoku -> Bool
+isSolutionOf s1 _ | not (isOkay s1) = False
+isSolutionOf s1 _ | isJust (hasBlank s1) = False
+isSolutionOf (Sudoku s1) (Sudoku s2) =
+    f s1 == f s2 where
+        f xs = [ (xs !! x) !! y | x <- [0..8], y <- [0..8], isJust ((s2 !! x) !! y) ]
+
+prop_SolveSound :: Sudoku -> Property
+prop_SolveSound s =
+    collect
+    s
+    $ isJust (solve s) ==> isSolutionOf (fromJust (solve s)) s
+
+fewerCheck prop = quickCheckWith stdArgs{ maxSuccess = 30 } prop
+