sudoku

gistfile1.hs

module Sudoku where

import Prelude hiding (Nothing)
import Data.List ((\\), union)

data Val = Val Int
         | Nothing
         | Alt [Int]
    deriving (Show, Eq)

type Idx = Int

data Box   = Box [[Val]] deriving (Show, Eq)
data Board = Board [[Box]] deriving (Show, Eq)

col :: Idx -> Board -> [Val]
col idx (Board board) = concatMap boxCol colBoxes
  where colBoxes :: [Box]
        colBoxes = map (\boxrow -> boxrow !! floor (toRational idx / 3)) board

        boxCol :: Box -> [Val]
        boxCol (Box b) = map (\row -> row !! (idx `mod` 3)) b

row :: Idx -> Board -> [Val]
row idx (Board board) = concatMap boxRow rowBoxes
  where rowBoxes :: [Box]
        rowBoxes = board !! floor (toRational idx / 3)

        boxRow :: Box -> [Val]
        boxRow (Box b) = b !! (idx `mod` 3)

boxOf :: (Idx, Idx) -> Board -> Box
boxOf (x, y) (Board b) = b !! (floor $ toRational y / 3) !! (floor $ toRational x / 3)

unpackBox :: Box -> [[Val]]
unpackBox (Box b) = b

unpackVal :: Val -> Int
unpackVal (Val i) = i

filterVals :: [Val] -> [Val]
filterVals = filter $ \v -> case v of
                                (Val _) -> True
                                _ -> False

vals :: [Val] -> [Int]
vals = map unpackVal . filterVals

reqs :: Idx -> Board -> (Idx -> Board -> [Val]) -> [Int]
reqs idx (Board board) f = [1..9] \\ map unpackVal vals
  where vals = filterVals $ f idx (Board board)

reqsCol :: Idx -> Board -> [Int]
reqsCol idx board = reqs idx board col

reqsRow :: Idx -> Board -> [Int]
reqsRow idx board = reqs idx board row

reqsBox :: (Idx, Idx) -> Board -> [Int]
reqsBox (x, y) board = [1..9] \\ (vals $ concat (unpackBox (boxOf (x, y) board)))

required :: (Idx, Idx) -> Board -> [Int]
required (x, y) board =
    (reqsCol x board `union`
        reqsRow y board `union`
        reqsBox (x, y) board) \\
    (vals (row x board) `union`
        vals (col y board) `union`
        vals (concat $ unpackBox $ boxOf (x, y) board))

setAt :: (Idx, Idx) -> Board -> Val -> Board
setAt = undefined

fillVals :: Board -> Board
fillVals board = iter 0 0 board
  where iter x y board
            | x > 8 = iter 0 (y+1) board
            | y > 8 = board
            | len == 0  = error "error"
            | len == 1  = iter (x+1) y (setAt (x, y) board (Val $ r !! 0))
            | otherwise = iter (x+1) y (setAt (x, y) board (Alt r))
            where r = required (x, y) board
                  len = length r

solve :: Board -> Board
solve b = let next = fillVals b
          in if b == next
                 then b
                 else solve next