From 72498722f988c639b38104c8d4589629b1761c0f Mon Sep 17 00:00:00 2001 From: Iru Cai Date: Mon, 23 Apr 2018 11:40:32 +0800 Subject: sudoku.hs --- sudoku.hs | 194 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 194 insertions(+) create mode 100644 sudoku.hs 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 + -- cgit v1.2.3