wanparkの日記

■ Stateによるメモ化を理解すべくがんばる

http://www.sampou.org/cgi-bin/haskell.cgi?Memoise

フィボナッチ数

fib :: Integer -> Integer
fib 0 = 0
fib 1 = 1
fib n = fib (n-1) + fib (n-2)

これをメモ化

type Table = [(Integer,Integer)]

fib :: Integer -> Integer
fib = fst . flip memofib []

memofib :: Integer -> Table -> (Integer,Table)
memofib 0 mt = (0, (0,0):mt)
memofib 1 mt = (1, (1,1):mt)
memofib n mt = case prev of
                 Just r    -> (r , mt)
                 Nothing   -> (r1+r2, (n,r1+r2):tb2)
                where
                  prev = lookup n mt
                  (r1,tb1) = memofib (n-1) mt
                  (r2,tb2) = memofib (n-2) tb1

ここまではいいんだけど、memoise とか言い出すところからついていけない。まず State モナドを返すように memofib を変える。

import Control.Monad.State

type Table = [(Integer,Integer)]

fib :: Integer -> Integer
fib n = evalState (memofib n) []

memofib :: Integer -> State Table Integer
memofib 0 = return 0
memofib 1 = return 1
memofib n = State (\mt -> let prev = lookup n mt
                              (r1,tb1) = runState (memofib (n-1)) mt
                              (r2,tb2) = runState (memofib (n-2)) tb1
                          in case prev of
                               Just r    -> (r , mt)
                               Nothing   -> (r1+r2, (n,r1+r2):tb2))

あんまり変わってない。次に memoise を理解できる形で書いてみる。

memoise :: (Integer -> State Table Integer) -> Integer -> State Table Integer
memoise f n = State (\mt -> case lookup n mt of
                              Just r  -> (r, mt)
                              Nothing -> let (r, tb) = runState (f n) mt
                                         in  (r, (n, r):tb))

テーブルの検索、結果の挿入を抜き出しているわけですね。memoise を使って memofib を書き直す。

fib :: Integer -> Integer
fib n = evalState (memofib n) []

memofib :: Integer -> State Table Integer
memofib 0 = return 0
memofib 1 = return 1
memofib n = memoise memofib' n

memofib' :: Integer -> State Table Integer
memofib' n = State (\mt -> let (r1,tb1) = runState (memofib (n-1)) mt
                               (r2,tb2) = runState (memofib (n-2)) tb1
                           in  (r1 + r2, tb2))

やってることはわかった。これをモナドっぽく書き直すのに使うのはこのへん。

instance Monad (State s) where
        return a = State $ \s -> (a, s)
        m >>= k  = State $ \s -> let
                (a, s') = runState m s
                in runState (k a) s'

instance MonadState s (State s) where
        get   = State $ \s -> (s, s)
        put s = State $ \_ -> ((), s)

>>= は、State s a の a の演算を繋げて s を後ろで受け渡す。get は s にある状態を a に持ってきて操作できるように、put は逆に s に持っていく。

つかんだね、これは。連載の両替何通り問題でやってみる。

type Amount = Integer
type Coin   = Integer
type Count  = Integer

cc :: Amount -> [Coin] -> Count
cc 0 _  = 1
cc _ [] = 0
cc a ccs@(c:cs)
       | a < 0     = 0
       | otherwise = cc (a - c) ccs
                   + cc a       cs

メモ化する

import Control.Monad.State

memoise f x = find x                  >>= \ prev ->
              case prev of
                Just r  -> return r
                Nothing -> f x        >>= \ r ->
                           ins (x, r) >>  return r
ins item = get >>=  put . (item:)
find n = get >>= return . lookup n


type Amount = Integer
type Coin   = Integer
type Count  = Integer

cc :: Amount -> [Coin] -> Count
cc a cs = evalState (memocc (a, cs)) []

memocc :: (Amount, [Coin]) -> State [((Amount, [Coin]), Count)] Count
memocc (0, _ ) = return 1
memocc (_, []) = return 0
memocc (ammount, coins)
    | ammount < 0 = return 0
    | otherwise   = memoise (\ (a, ccs@(c:cs)) ->
                                 if a < 0
                                 then return 0
                                 else liftM2 (+) (memocc ((a - c), ccs)) (memocc (a, cs)))
                            (ammount, coins)

載ってるのそのままだけど。

こないだの、指定leaf数の木を列挙するやつ

trees :: Int -> [Tree]
trees = flip evalState [] . mtrees

mtrees :: Int -> State [(Int, [Tree])] [Tree]
mtrees 1 = return [Leaf]
mtrees n = memoise (\n' -> let treesL i = do ts1 <- mtrees i
                                             ts2 <- mtrees (n' - i)
                                             return [Node t1 t2 | t1 <- ts1, t2 <- ts2]
                               concatMapM f xs = liftM concat (mapM f xs)
                           in  concatMapM treesL [1..(n'-1)]) n

無名関数の中で where って使えないの？