memoization
"top-downのmemoization"をしばらく前に思いついてhttp://www.sampou.org/cgi-bin/haskell.cgi?p=Programming%3a%b6%cc%bc%ea%c8%a2%3a%ca%b8%bb%fa%ce%f3&l=jp#6にも書きこんだのだが、今日は http://d.hatena.ne.jp/tanakh/20041126 に触発されてmemoizationについてもう少し考えてみた。
Haskellはpureなので、関数の中で副作用によって密かに結果を蓄えておくという、通常の命令型言語の方法でmemoizeすることはできない*1。
しかし、代わりに同じ変数に束縛されたものは二度計算されることがないというLazyな性質を利用できそうなものである。
まず、定番の
fib 0 = 0 fib 1 = 1 fib n = fib (n - 1) + fib (n - 2)
を考える。
O(n)で効率的に計算するidiomaticな方法は、
fib = fibs !! n fibs = 0:1:zipWith (+) fibs (tail fibs)
である。
fib nの値をfibs !! nに束縛することで再計算を防いでいるのだが、top downの定義をbottom upに書き換えているので、少し頭を使う必要がある。
できれば、再帰的なアルゴリズムをそのまま書きたい。そのような方法として、よく知られているのが、このようなものだ。
fib 0 = 0 fib 1 = 1 fib n = fibs !! (n - 1) + fibs !! (n - 2) where fibs = [fib n | n <- [0..]]
これはさっきのものよりはずっと簡単に書けるだろう。ほとんどアルゴリズムそのままである。この考えを一般化すると、tanakh氏のmemolize*2
memolize :: ( (Int -> Int) -> (Int -> Int)) -> (Int -> Int)
memolize f = (tbl!!) where
tbl = map (f (tbl!!)) [0..]
fib = memolize $ \f n ->
case n of
0 -> 0
1 -> 1
n -> f (n-1) + f (n-2)のように、memoize functionが得られる。
…のだが、この方法は効率がわるいのである。(!! n)で何度も最初からリストを辿るので、計算のオーダーがO(n^2)になってしまう。
実際、上記tanakh氏の日記の
solve :: Int -> Integer
solve x = inner (x,x) where
inner = memolizeI ( (0,0),(5000,5000)) $ \f (n,m) ->
case (n,m) of
(1,_) -> 1
(n,m) -> sum [f (n-1,m-i) | i <- [0,n..m] ]は、テーブルサイズが大きいためにまったく使いものにならなくなっている。
では、どうするか。テーブルを上からtop downに辿ればいいのである。つまり、nから始まるテーブルを作る。
(fibs n)@(_:x0:x1:_) = (x0 + x1):fibs (n - 1)
と書きたい所だが、文法的に無理なので、こうなった。
fib n = r where xs@(r:_) = fibs n xs fibs 1 _ = [1, 0] fibs n ~(_:xs@(x0:x1:_)) = (x0 + x1):fibs (n - 1) xs
これを一般化すると、無駄にリストを辿らないmemoizeができるはずである。
今日の所はこんなものができた。
fib = memo1 (\n xs -> case n of
0 -> 0
1 -> 1
_ -> xs !! 1 + xs !! 2)fibの定義そのままではないが、f (n - j) を xs !! j に置き換えるだけでよいので、頭を使う必要はない。
上のsolveによるmemoizationでは遅すぎた
f n m | n == 1 = 1
| otherwise = sum [f (n-1) (m-i) | i <- [0,n..m] ]は、このようになり、速く計算できるようになった。
solve = memo2 (\n m d ->
case (n, m) of
(1, _) -> 1
(n, m) -> sum [ (d !! 1) !! i | i <- [0,n..m] ] )本来はTreeのようなものに保存すべきではないかと思うのだが、とりあえず [ [ a ] ]にキャッシュしている。
memo1, memo2の定義は、これ。
memo1 f n = head $ memos1 f n
memos1 :: (Int -> [a] -> a) -> Int -> [a]
memos1 f n = rs
where
rs = m n rs
m n ~xxs@(x:xs) = (f n xxs):m (n - 1) xs
memo2 f n m = head $ head $ memos2 f n m
memos2 :: (Int -> Int -> [[a]] -> a) -> Int -> Int -> [[a]]
memos2 f n m = rs
where
rs = memo n m rs
memo n m ~rs@((_:xs):ys)
= (f n m rs:head (memo n (m - 1) (xs:map tail ys)))
:memo (n - 1) m ys
追記
[id:yts:20041127#p1]
histomorphism
