wanparkの日記

■ Haskellプログラミング(8) ペンシルパズルを解く

http://www.ipsj.or.jp/07editj/promenade/4611.pdf

二コリをよく買っていた時期があったけど、数独とカックロはなんか面倒でいつもとばしてたなー。

import List
import Char

main = do input <- getContents
          case solve $ readSudoku input of
            Just s  -> print s
            Nothing -> putStrLn "No solutions."


------------------------------------------------------------------------
-- データ構造
------------------------------------------------------------------------

type Token    = Int
type Position = (Int, Int)
data Sudoku   = Sudoku { cells :: [[Maybe Token]] }

instance Show Sudoku where
    show = unlines . map ((join '\t') . (map showCell)) . cells
        where showCell Nothing = ""
              showCell (Just tok) = show tok

readSudoku :: String -> Sudoku
readSudoku str = Sudoku $ map readRow (adjustLength size "" rows)
    where (info:rows)  = lines str
          size         = read info
          readRow      = map readMaybeInt . adjustLength size "" . split '\t'

size:: Sudoku -> Int
size = length . cells

cell :: Position -> Sudoku -> Maybe Token
cell (x, y) (Sudoku cells) = cells  !! y !! x

tokens :: Sudoku -> [Token]
tokens sudoku = [1 .. size sudoku]


------------------------------------------------------------------------
-- Sudoku handling
------------------------------------------------------------------------

update :: Position -> Token -> Sudoku -> Sudoku
update (x, y) tok = Sudoku . replace y (replace x (const $ Just tok)) . cells

valid :: Position -> Sudoku -> Bool
valid (x, y) sudoku = all uniq [row, line, box]
    where s  = size sudoku
          ms = floor $ sqrt $ fromIntegral s
          mx = x `div` ms * ms
          my = y `div` ms * ms
          row  = [(i, y) | i <- [0 .. (s - 1)]]
          line = [(x, i) | i <- [0 .. (s - 1)]]
          box  = [(i, j) | i <- [mx .. (mx + ms - 1)], j <- [my .. (my + ms - 1)]]
          uniq positions = let toks = removeNothing $ map (flip cell sudoku) positions
                           in length toks == length (nub toks)


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

solve :: Sudoku -> Maybe Sudoku
solve sudoku = case nextSpace sudoku of
                 Nothing  -> Just sudoku
                 Just pos -> (find (not . isNothing) $ map (flip (assume pos) sudoku) (tokens sudoku)) >>= id

assume :: Position -> Token -> Sudoku -> Maybe Sudoku
assume pos tok sudoku = let updated = update pos tok sudoku
                        in  if valid pos updated
                            then solve updated
                            else Nothing

nextSpace :: Sudoku -> Maybe Position
nextSpace (Sudoku cells) = do let indexes = map (findIndex isNothing) cells
                              y <- findIndex (not . isNothing) indexes
                              x <- indexes !! y
                              return (x, y)


------------------------------------------------------------------------
-- basic functions
------------------------------------------------------------------------

join :: a -> [[a]] -> [a]
join sep = foldl1 (\ x y -> x ++ (sep:y))

split :: Eq a => a -> [a] -> [[a]]
split _   [] = []
split sep xs = group : split sep rest
    where (group, rest') = break (==sep) xs
          rest = if null rest' then [] else tail rest'

readMaybeInt :: String -> Maybe Int
readMaybeInt str = case filter (not . isSpace) str of
                     "" -> Nothing
                     s  -> Just $ read s

adjustLength :: Int -> a -> [a] -> [a]
adjustLength size fill xs = take size xs ++ take (max 0 (size - (length xs))) (repeat fill)

replace :: Int -> (a -> a) -> [a] -> [a]
replace pos f xs = take pos xs ++ [f (xs !! pos)] ++ drop (pos + 1) xs

isNothing :: Maybe a -> Bool
isNothing Nothing = True
isNothing _ = False

removeNothing :: [Maybe a] -> [a]
removeNothing = foldr f []
    where f (Just x) xs = x:xs
          f _        xs = xs

$ cat data.txt
9
8				3	4		5
		2						1
	1		9
		8			9			6
5				1				8
6			4			7
					1		7
2						1
	9		5	6				2
$ runghc sudoku.hs < data.txt
8	6	7	1	3	4	2	5	9
9	5	2	6	7	8	3	4	1
4	1	3	9	5	2	6	8	7
7	4	8	3	2	9	5	1	6
5	3	9	7	1	6	4	2	8
6	2	1	4	8	5	7	9	3
3	8	6	2	4	1	9	7	5
2	7	5	8	9	3	1	6	4
1	9	4	5	6	7	8	3	2

1マスごとに全数字を試す。反省点

• 遅い。9x9でぎりぎり
  • 全マスに置ける数字を計算しておく -> １つの数字しか置けないマスは確定 -> ... とやるとだいぶましになる
• 引数の最後に Sudoku を渡すパターンは State で書くとよいと思う
• Maybe を無理やり目に使ってみたけど、ぎこちない
• Sudoku のデータ構造を外に漏らすな。traverse とか書けばいいんだけど。Traversable っていうのを実装するのが標準的？
• print デバッグができなくて大変だ。いやテストを書けと

本文読んだ

わかった