为什么这棵树没有被记忆的Haskell功能比unmemoized版本更快?

时间:2012-10-26 17:25:55

标签: haskell tree memoization

我正在尝试理解如何通过各种数据类型的参数在Haskell中记忆函数。我已经为Ralf Hinze的文章“Memo functions, polytypically!

中的树类型实现了表格和应用函数。

我的实施如下。我的测试函数计算深度为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

更新

我明白为什么我的函数不会利用memoization,但我仍然不明白如何构建一个利用它的函数。基于斐波那契记忆示例here,我的尝试看起来像:

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

2 个答案:

答案 0 :(得分:4)

numSubTrees是一个递归函数,你的memo无法查看递归:这意味着memo numSubTrees只查找第一个调用,而递归调用是仍然使用未标记的版本。

答案 1 :(得分:1)

两位回应者都是正确的,但这是一个更完整的回复。

我的原始代码中有两个错误。第一个,我在更新中纠正的是,我原来的memoized函数只在第一次调用时使用了memo表。递归调用只是普通的unmemoized函数调用。

然而,即使修复此错误也不会导致速度提升。这不是因为函数无法调用memo表,而是因为没有足够的递归调用来证明索引到表中。但是如果我们让函数在相同的子树上执行更多调用,我们会看到memoization会带来改进。

-- 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