Sudoku.hs

{-# OPTIONS_GHC -Wall #-}

-- http://www.cse.chalmers.se/edu/year/2014/course/TDA555/lab3.html

import Data.Char
import Data.List
import Data.List.Split
import Data.Maybe
import Debug.Trace

data Sudoku = Sudoku [[Maybe Int]]

-- default parameters
boardsize :: Int
boardsize = 9

boxsize :: Int
boxsize   = 3

-- example Sudoku
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]
  ]

example' :: Sudoku
example' = Sudoku
  [ [Just 3, Just 6, Nothing,Nothing,Just 7, Just 1, Nothing, 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]
  ]

-- blank Sudoku
allBlankSoduku :: Sudoku
allBlankSoduku = Sudoku . g . g  $ Nothing where g = take boardsize . repeat

-- check it's a Sudoku
isSudoku :: Sudoku -> Bool
isSudoku (Sudoku s) = all ($ s) [f, all f] where f xs = length xs == boardsize

-- check if it's solved.
isSolved :: Sudoku -> Bool
isSolved sk@(Sudoku s) = and [isSudoku sk, all (all isJust) s]

-- Show instance of Sudoku
instance Show Sudoku where
    show (Sudoku s)  = intercalate "\n" (map (intercalate " " . map m2s) s) where
                       m2s m = case m of
                            Just n  -> show n
                            Nothing -> "."

-- print Sudoku
printSudoku :: Sudoku -> IO ()
printSudoku sk = putStr (show sk)

-- read Sudoku
-- readSudoku :: FilePath -> IO Sudoku

{-
Generate Sudoku
-}

-- cell :: Gen (Maybe Int)

type Block = [Maybe Int]

-- given a block, checks if that block does not contain the same digit twice
isOkayBlock :: Block -> Bool
isOkayBlock xs = length (nub ys) == length ys where 
                    ys = filter isJust xs

-- given a Sudoku, creates a list of all blocks of that Sudoku.
blocks :: Sudoku -> [Block]
blocks (Sudoku s) = s ++ (transpose s) ++ (box s) where
    box = map (foldr1 (++)) . grp . transpose . foldr1 (zipWith (++)) . grp
    grp = chunksOf boxsize

-- given a Sudoku, checks that all rows, colums and 3x3 blocks do not contain the same digit twice. 
isOkay :: Sudoku -> Bool
isOkay = all isOkayBlock . blocks

-- Positions and Finding Blanks.
type Pos = (Int, Int)

-- returns a position in the Sudoku that is still blank
blank :: Sudoku -> Pos
blank (Sudoku s) = head  [(i,j) | i <- [0..(boardsize-1)],
                                  j <- [0..(boardsize-1)], 
                                  isNothing ((s !! i) !! j)]

-- given a list, and a tuple containing an index in the list and a new value
-- updates the given list with the new value at the given index
(!!=) :: [a] -> (Int, a) -> [a]
xs !!= (n, x) = (take n xs) ++ [x] ++ (drop (n+1) xs)

-- given a Sudoku, a position, and a new cell value, updates the given Sudoku 
-- at the given position with the new value.
update :: Sudoku -> Pos -> Maybe Int -> Sudoku
update sk@(Sudoku s) (i,j) m = Sudoku $ s !!= (i, (s !! i) !!= (j, m))

-- Solving Sudoku
-- 1. brute force without tail recursion
solve1 :: Sudoku -> Maybe Sudoku
solve1 sk
    | not $ isSudoku sk = Nothing
    | not $ isOkay sk   = Nothing
    | isSolved sk       = Just sk
    | otherwise         = if length sud == 0 then Nothing else head sud where
                            sud = filter isJust . map (solve1 . update sk (blank sk) . Just) $ [1..9]

-- search all possible solution.
solve1' :: Sudoku -> [Maybe Sudoku]
solve1' sk
    | not $ isSudoku sk = []
    | not $ isOkay sk   = []
    | isSolved sk       = [Just sk]
    | otherwise         =  concat . map (solve1' . update sk pos . Just) $ [1..9] where pos = blank sk

-- 2. brute force with tail recursion
deleteOptions :: [Maybe Int] -> [Maybe Int] -> [Maybe Int]
deleteOptions ys xs = foldr delete xs $ filter (flip elem xs) ys

options :: Sudoku -> Pos -> [Maybe Int]
options (Sudoku s) (i,j) = foldr deleteOptions (map Just [1..9]) [(s !! i), (transpose s) !! j]

--
solve2 :: Sudoku -> [Maybe Sudoku]
solve2 sk
    | not $ isSudoku sk = []
    | not $ isOkay sk   = []
    | isSolved sk       = [Just sk]
    | otherwise         = concat . map (solve2 . update sk pos) . options sk $ pos where
                          pos = blank sk