Hatena::Grouphaskell

wanparkの日記

 | 

2007-11-28

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

本文読んだ

わかった


数値リテラルと型変換は違う

Num クラスに属する型は数値リテラルを使える。

instance Num MyType where ...

fromLiteral :: MyType = 1      -- OK

だからといって、例えば Int から勝手に型を変換してくれるわけではない。Haskell には暗黙の型変換はない。

i :: Int = 1
fromFunction :: MyType = i     -- NG

nobsun に教えてもらいました。助かります。


Haskellプログラミング(6) 文字列間の距離-モナドを使って-

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

レーベンシュタイン距離を計算する。

data Operator = Insert Char
              | Delete
              | Substitute Char
              | Ident
                deriving Eq

align :: String -> String -> [Operator]
align [] []     = []
align (x:xs) [] = Delete   : align xs []
align [] (x:xs) = Insert x : align [] xs
align xxs@(x:xs) yys@(y:ys) = if x == y
                              then Ident : align xs ys
                              else shortest [Delete       : align xs yys,
                                             Insert y     : align xxs ys,
                                             Substitute y : align xs ys]
shortest = snd . foldl1 (\ a b -> if fst a > fst b then b else a) . map (\a -> (length $ filter (/= Ident) a, a))


showAlignment :: String -> String -> String
showAlignment from to = unlines ["Levenshtein distance: " ++ show (distance operators),
                                 showSkipWord isInsert from operators,
                                 showHomology operators,
                                 showSkipWord (== Delete) to operators]
    where
      operators = align from to
      distance = length . filter (/= Ident)
      isInsert (Insert _) = True
      isInsert _ = False
      showSkipWord :: (Operator -> Bool) -> String -> [Operator] -> String
      showSkipWord _ []  _ = ""
      showSkipWord _ cs [] = cs
      showSkipWord skip ccs@(c:cs) (op:ops) = if skip op
                                              then ' ' : showSkipWord skip ccs ops
                                              else c   : showSkipWord skip cs  ops
      showHomology = map (\op -> if op == Ident then '|' else ' ')
*Main> putStr $ showAlignment "kitten" "sitting"
Levenshtein distance: 3
kitten
 ||| |
sitting

DNA の alignment っぽく表示してみました。単に距離を求めるだけなら

distance :: String -> String -> Int
distance [] xs = length xs
distance xs [] = length xs
distance xxs@(x:xs) yys@(y:ys) = if x == y
                                 then distance xs ys
                                 else 1 + minimum [distance xs ys,
                                                   distance xxs ys,
                                                   distance xs yys]

Page not found · GitHub Pages の Memo モジュールを使ってメモ化する。ghc6.6 の場合、-fglasgow-exts オプションをつけないといけないみたいです。

import Memo
import Monad

data Ord a => ListTable a b  = ListTable [(a, b)]

instance Table ListTable where
    emptyTable = ListTable []
    lookupTable key (ListTable []) = Nothing
    lookupTable key tbl@(ListTable ((k, v):rest)) | key >  k  = Nothing
                                                  | key == k  = Just v
                                                  | otherwise = lookupTable key (ListTable rest)
    insertTable k v (ListTable list) = case break ((k >) . fst) list of
                                         (xs, ys) -> ListTable (xs ++ (k, v):ys)


mdistance :: Memo ListTable (String, String) Int
mdistance ([],   to) = return $ length to
mdistance (from, []) = return $ length from
mdistance (from, to) = memoise (\ (xxs@(x:xs), yys@(y:ys)) ->
                                    if x == y
                                    then mdistance (xs, ys)
                                    else 1 + liftM minimum (sequence [mdistance (xs,  ys),
                                                                      mdistance (xxs, ys),
                                                                      mdistance (xs,  yys)])) (from, to)

evalMdistance ::String -> String -> Int
evalMdistance from to = evalMemo mdistance (from, to)

"mdistance ([], to) = return $ length to" の return はいらないと思うんだけど、ないとエラーになる。暗黙の型変換を理解してない。

記事を読んだ。

先頭の文字が一致している時の挙動

その場合無条件に変換なしとしても最小距離は変わらない、と思ったんだけど、違うのかな。いや違くないよな。

Data.Map

lookup が O(n) から O(log n) になる。普通の配列でやれば O(1) だけど、と最後に言ってる

表示のやり方

なるほどーうまいねー

結局

前回の連載「記憶する関数」は理解されないこと前提だったのですか

nobsunnobsun 2007/11/28 23:48 Haskell には暗黙の型変換はありません。
length to の型は Int です。mdistance の型は Memo ListTable (String,String) Int
すなわち (String,String) -> State (ListTable (String,String) Int ですので、
return なしでは型があいません。

wanparkwanpark 2007/11/29 03:19 ありがとうございます。暗黙の型変換はそもそもないんですか。数値リテラルと型変換を混同していたようです。

ゲスト



トラックバック - http://haskell.g.hatena.ne.jp/wanpark/20071128
 |