NumberPlateMaybe.hs

module NumberPlate where

import Data.List  ((\\))
import Data.Maybe

-- マス　｛数　行　列　ブロック｝
data Cell    = Cell {num :: Int, row :: Int, col :: Int, block :: Int} deriving (Eq,Show)

-- 盤面
type Board   = [Cell]

-- 埋められたマス
type Filled  = [Cell]

-- 空のマス
type Empties = [Cell]

-- 施行中の盤面　(埋められたマス　空のマス)
type State   = (Filled,Empties)

-- 問題
type Ploblem = [Int]

-----------  initilize  -----------

easy :: Ploblem
easy =      [5,1,7, 6,0,0, 0,3,4,
             2,8,9, 0,0,4, 0,0,0,
             3,4,6, 2,0,5, 0,9,0,

             6,0,2, 0,0,0, 0,1,0,
             0,3,8, 0,0,6, 0,4,7,
             0,0,0, 0,0,0, 0,0,0,

             0,9,0, 0,0,0, 0,7,8,
             7,0,3, 4,0,0, 5,6,0,
             0,0,0, 0,0,0, 0,0,0]

difficult :: Ploblem
difficult = [0,0,5, 3,0,0, 0,0,0,
             8,0,0, 0,0,0, 0,2,0,
             0,7,0, 0,1,0, 5,0,0,

             4,0,0, 0,0,5, 3,0,0,
             0,1,0, 0,7,0, 0,0,6,
             0,0,3, 2,0,0, 0,8,0,

             0,6,0, 5,0,0, 0,0,9,
             0,0,4, 0,0,0, 0,3,0,
             0,0,0, 0,0,9, 7,0,0]

-- 各マスの（行・列・ブロック）のリスト
positions :: [(Int,Int,Int)]
positions = [(r,c,b) | r <- [0..8], c <- [0..8], let b = 3 * classify r + classify c]
    where classify = flip div 3

-- 盤面の初期化
board :: Ploblem -> Board
board = zipWith initialize positions
    where initialize (r,c,b) n = Cell n r c b

----------- solve -----------

solve :: Board -> Board
solve board = fst . fromJust . loop $ (filled,empties)
    where filled  = filter ((/= 0) . num) board
          empties = filter ((== 0) . num) board

-- 空きマスに入りうる選択肢を虱潰しに試して検索
-- null empties : 矛盾なく空きマスを埋められてるのでループ終了
-- null result  : 空きマスが残ってるのに選択肢がなくなる、間違い。
loop :: State -> Maybe State
loop state@(filled,empties)
    | null empties = Just (filled,empties)
    | null result  = Nothing
    | otherwise    = Just $ head result
    where envs     = getStates state
          result   = mapMaybe loop envs

-- 先頭の空きマスに、各選択肢を埋めた盤面の取得
getStates :: State -> [State]
getStates state = map (putCandidates state) candidates
    where candidates = getCandidates state
          putCandidates (fs,e:es) c = (fs++[c],es)

-- 先頭の空きマスに入りうる選択肢（同列・同行・同ブロックにある数を除外したもの）の取得
getCandidates :: State -> [Cell]
getCandidates (filled,e:es) = map (\n -> e {num = n}) nums
    where inSameRow   = map num $ filter ((== row e)   . row)   filled
          inSameCol   = map num $ filter ((== col e)   . col)   filled
          inSameBlock = map num $ filter ((== block e) . block) filled
          nums        = [1..9] \\ (inSameRow ++ inSameCol ++ inSameBlock)

----------- display -----------

sortBy :: Ord b => (a -> b) -> [a] -> [a]
sortBy f []     = []
sortBy f (x:xs) = sortBy f l ++ [x] ++ sortBy f r
    where l = filter ((<= f x) . f) xs
          r = filter ((>  f x) . f) xs

display :: Board -> IO ()
display [] = return ()
display b = do
    let (x,xs) = splitAt 9 $ sortBy row b
    print $ map num $ sortBy col x
    display xs