1

我试图了解如何在 Haskell 中通过各种数据类型的参数来记忆函数。我已经为 Ralf Hinze 的文章“ Memo functions, polytypically！ ”中的 Tree 类型实现了制表和应用函数。

我的实现如下。我的测试函数计算深度为 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是一个递归函数，你memo无法窥视递归：这意味着memo numSubTrees只查找第一次调用，而递归调用仍在使用未记忆的版本。

于 2012-10-26T19:42:56.823 回答
1

两位回答者都是正确的，但这里有一个更完整的回答。

我的原始代码中有两个错误。第一个，我在更新中更正了，我原来的记忆函数只在第一次调用中使用了备忘录表。递归调用只是普通的 unmemoized 函数调用。

但是，即使修复此错误也不会导致速度提高。这不是因为该函数未能调用备忘录表，而是因为没有足够的递归调用来证明对表的索引是正确的。但是如果我们让函数在相同的子树上执行更多的调用，我们会看到记忆化会带来改进。

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