Memoization

Haskellでナップサック問題を解こうと思ったらメモリ使用量が爆発して悲惨なことになったので、メモ化にチャレンジしてみることに。

Programming in HaskellのMemoiseのページがとても良い解説で、かなり参考にさせてもらいました。でも、途中からIOArrayとかfundepsとかおかしな方向に向かっていったので最後にはひどいことに。自分のような初心者にはオーバーテクノロジすぎる... 素直にDiffArrayとか使って出直そう。

せっかくだからおれはこのソースコードを公開処刑しておくぜ。

{-# OPTIONS -fglasgow-exts #-}

import Control.Monad
import Data.Array.MArray
import Data.Array.IO

data (Monad m) => MonadicMemoized m t a =
    MonadicMemoized { runMonadicMemoized :: t -> m a }

instance (Monad m) => Monad (MonadicMemoized m t) where
    return x = MonadicMemoized $ \t -> return x
    mx >>= f = MonadicMemoized $ \t -> do x <- runMonadicMemoized mx t
                                          runMonadicMemoized (f x) t

type MonadicMemoizedFunction m t a b =
    a -> MonadicMemoized m t b

class (Monad m) => MonadicMemoizeTable m i t a b | t -> i, t -> a, t -> b where
    newTable :: i -> m t
    lookupTable :: t -> a -> m b
    insertTable :: t -> a -> b -> m ()

class (MonadicMemoizeTable m i t a b) => MonadicMemoization m i t a b | t -> i, t -> a, t -> b where
    memoize :: MonadicMemoizedFunction m t a b -> MonadicMemoizedFunction m t a b
    evalMemoized :: i -> MonadicMemoized m t c -> m c
    evalMemoized init mx = newTable init >>= runMonadicMemoized mx

instance (Ix a, Eq b) => MonadicMemoizeTable IO ((a, a), b) (b, IOArray a b) a b where
    newTable (range, def) = do ar <- newArray range def
                               return (def, ar)
    lookupTable (_, t)    = readArray t
    insertTable (_, t)    = writeArray t

instance (Ix a, Eq b) => MonadicMemoization IO ((a, a), b) (b, IOArray a b) a b where
    memoize f x = MonadicMemoized $ \table@(def, _) ->
                  do cache <- lookupTable table x
                     if cache /= def
                        then return cache
                        else do y <- runMonadicMemoized (f x) table
                                insertTable table x y
                                return y

type Memo a b = MonadicMemoizedFunction IO (b, IOArray a b) a b

fibM :: Memo Integer Integer
fibM 0 = return 1
fibM 1 = return 1
fibM n = (`memoize` n) $ \n -> do a1 <- fibM (n-1)
                                  a2 <- fibM (n-2)
                                  return (a1+a2)

fibMIO n = evalMemoized ((0, n), 0) (fibM n)

main = sequence [fibMIO n | n <- [0..100]] >>= mapM_ print