1

さまざまなデータ型の引数に対して Haskell で関数をメモ化する方法を理解しようとしています。Ralf Hinze の記事「 Memo functions, polytyply!」にある Tree タイプの tabulate 関数と apply 関数を実装しました。

私の実装は以下です。私のテスト関数は、深さ d のツリー内のサブツリーの数をカウントします。再帰呼び出しをメモ化すると、この関数はより高速になるはずですか? そうではありません:私のシステムで両方のバージョンをタイミングすると、次のようになります:

helmholtz:LearningHaskell edechter$ time ./Memo 1 23
Not memoized: # of subtrees for tree of depth 23 is: 25165822

real    0m1.898s
user    0m1.886s
sys 0m0.011s
helmholtz:LearningHaskell edechter$ time ./Memo 0 23
Memoized: # of subtrees for tree of depth 23 is: 25165822

real    0m5.129s
user    0m5.013s
sys 0m0.115s

私のコードは簡単です：

-- Memo.hs
import System.Environment

data Tree = Leaf | Fork Tree Tree deriving Show
data TTree v = NTree v (TTree (TTree v)) deriving Show

applyTree :: TTree v -> (Tree -> v)
applyTree (NTree tl tf) Leaf = tl
applyTree (NTree tl tf) (Fork l r) = applyTree (applyTree tf l) r

tabulateTree :: (Tree -> v) -> TTree v
tabulateTree f = NTree (f Leaf) (tabulateTree $ \l
                                     -> tabulateTree $ \r -> f (Fork l r))

numSubTrees :: Tree -> Int
numSubTrees Leaf = 1
numSubTrees (Fork l r ) = 2 + numSubTrees l + numSubTrees r

memo = applyTree . tabulateTree

mkTree d | d == 0 = Leaf
         | otherwise = Fork (mkTree $ d-1) (mkTree $ d-1)

main = do
  args <- getArgs
  let version = read $ head args
      d = read $ args !! 1
      (version_name, out) = if version == 0
                              then ("Memoized", (memo numSubTrees) (mkTree d))
                              else ("Not memoized", numSubTrees (mkTree d))
  putStrLn $ version_name ++ ": # of subtrees for tree of depth "
               ++ show d ++ " is: " ++ show out

アップデート

私の関数がメモ化を利用しない理由はわかりますが、これを利用する関数を構築する方法はまだわかりません。こちらのフィボナッチメモ化の例に基づいて、私の試みは次のようになります。

memofunc :: Tree -> Int
memofunc  = memo f
    where f (Fork l r) = memofunc l + memofunc r
          f (Leaf) = 1

func :: Tree -> Int
func (Leaf) = 1
func (Fork l r) = func l + func r

しかし、これはまだ正しいことをしません:

helmholtz:LearningHaskell edechter$ time ./Memo 0 23
Memoized: # of subtrees for tree of depth 23 is: 8388608

real    0m10.436s
user    0m9.895s
sys 0m0.532s
helmholtz:LearningHaskell edechter$ time ./Memo 1 23
Not memoized: # of subtrees for tree of depth 23 is: 8388608

real    0m1.666s
user    0m1.654s
sys 0m0.011s
4

2 に答える 2

4

numSubTrees is a recursive function, and your memo can't peek into the recursion: This means that memo numSubTrees only does a lookup for the first call, while the recursive calls are still using the unmemoized version.

于 2012-10-26T19:42:56.823 に答える
1

どちらの回答者も正しかったのですが、もっと完全な回答があります。

元のコードに2つのエラーがありました。1つ目は、更新で修正したもので、元のメモ化関数は最初の呼び出しでメモ化テーブルのみを使用していたというものでした。再帰呼び出しは、通常の記憶されていない関数呼び出しでした。

ただし、このエラーを修正しても速度は向上しませんでした。これは、関数がメモテーブルの呼び出しに失敗したためではなく、テーブルへのインデックス作成を正当化するのに十分な再帰呼び出しがなかったためです。しかし、関数に同じサブツリーでより多くの呼び出しを実行させると、メモ化が改善につながることがわかります。

-- Memo.hs                                                                                                                                                                                                  

import System.Environment                                                                                                                                                                                   

data Tree = Leaf | Fork Tree Tree deriving Show                                                                                                                                                             
data TTree v = NTree v (TTree (TTree v)) deriving Show                                                                                                                                                      

applyTree :: TTree v -> (Tree -> v)                                                                                                                                                                         
applyTree (NTree tl tf) Leaf = tl                                                                                                                                                                           
applyTree (NTree tl tf) (Fork l r) = applyTree (applyTree tf l) r                                                                                                                                           

tabulateTree :: (Tree -> v) -> TTree v                                                                                                                                                                      
tabulateTree f = NTree (f Leaf) (tabulateTree $ \l                                                                                                                                                          
                                     -> tabulateTree $ \r -> f (Fork l r))                                                                                                                                  

memofunc :: Tree -> Int                                                                                                                                                                                     
memofunc t  = (memo func) t                                                                                                                                                                                 
    where func :: Tree -> Int                                                                                                                                                                               
          func (Leaf) = 1                                                                                                                                                                                   
          func (Fork Leaf Leaf) = 1                                                                                                                                                                         
          func (Fork l@(Fork a b) r) = memofunc l + memofunc a + memofunc b                                                                                                                                 
                                       + memofunc r                                                                                                                                                         

func :: Tree -> Int                                                                                                                                                                                         
func (Leaf) = 1                                                                                                                                                                                             
func (Fork Leaf Leaf) = 1                                                                                                                                                                                   
func (Fork l@(Fork a b) r) = func l + func a + func b + func r                                                                                                                                              


memo = applyTree . tabulateTree                                                                                                                                                                             

mkTree d | d == 0 = Leaf                                                                                                                                                                                    
         | otherwise = Fork (mkTree $ d-1) (mkTree $ d-1)                                                                                                                                                   

main = do                                                                                                                                                                                                   
  args <- getArgs                                                                                                                                                                                           
  let version = read $ head args                                                                                                                                                                            
      d = read $ args !! 1                                                                                                                                                                                  
      (version_name, out) = if version == 0                                                                                                                                                                 
                            then ("Memoized", (memofunc) (mkTree d))                                                                                                                                        
                            else ("Not memoized", func (mkTree d))                                                                                                                                          
  putStrLn $ version_name ++ ": function apply to tree of depth "                                                                                                                                           
               ++ show d ++ " is: " ++ show out

メモ化された実行時間とメモ化されていない実行時間につながります（深さ23のバランスの取れたツリーで）：

helmholtz:LearningHaskell edechter$ time ./Memo 0 21
Memoized: function apply to tree of depth 21 is: 733219840

real    0m2.954s
user    0m2.781s
sys 0m0.162s
helmholtz:LearningHaskell edechter$ time ./Memo 1 21
Not memoized: function apply to tree of depth 21 is: 733219840

real    0m6.334s
user    0m6.304s
sys 0m0.025s
于 2012-10-28T16:11:44.690 に答える