Haskell - 树形递归避免控制堆栈溢出

Question

对于大学任务，我们必须研究背包问题的各种解决方案，然后在Haskell和Python中实现解决方案。

我选择了蛮力。我意识到有更好的算法，但这个选择的原因超出了这篇文章的范围。

但是，在我的两次尝试中，当使用HUGS时，最终都会出现控制堆栈溢出，但是在使用GHC时不会出现控制堆栈溢出。

调查似乎指向严格性/懒惰的问题，我的代码最终会产生过多的thunk，而GHC的严格性分析似乎正在消除这个问题。

有人能指出我在下面提供的代码中出错的地方，并且让我带领如何解决问题。

注：我只有4个星期的Haskell经验，所以认识到我的代码与Haskell专家编写的代码相比是天真的。

编辑：添加几个`seq`语句使得程序在HUGS中工作。然而，这似乎有点破解。还有其他可能的改进吗？我已经接受了一个答案，但任何进一步的意见将不胜感激。

module Main where 
import Debug.Trace 
import Data.Maybe 

type ItemInfo = (Double,Double) 
type Item = (ItemInfo,[Char]) 
type Solution = (ItemInfo,[Item]) 

-- FilterTerminationCondition should be a function that returns True if this branch of brute force should be stopped. 
type FilterTerminationCondition = (Solution -> Bool) 

-- FilterComparator should return which, out of two solutions, is better. 
-- Both solutions will have passed FilterTerminationCondition succesfully. 
type FilterComparator = (Solution -> Solution -> Solution) 

-- FilterUsesTerminatingSolution is a boolean which indicates, when FilterTerminationCondition has caused a branch to end, whether to use the set of items that caused the end of the branch (True) or the set of items immeidately before (False). 
type FilterUsesTerminatingSolution = Bool 

-- A Filter should contain lambada functions for FilterTerminationCondition and FilterComparator 
type Filter = (FilterTerminationCondition,FilterComparator,FilterUsesTerminatingSolution) 

-- A series of functions to extract the various items from the filter. 
getFilterTerminationCondition :: Filter -> FilterTerminationCondition 
getFilterTerminationCondition (ftcond,fcomp,futs) = ftcond 

getFilterComparator    :: Filter -> FilterComparator 
getFilterComparator    (ftcond,fcomp,futs) = fcomp 

getFilterUsesTerminatingSolution :: Filter -> FilterUsesTerminatingSolution 
getFilterUsesTerminatingSolution (ftcond,fcomp,futs) = futs 

-- Aliases for fst and snd that make the code easier to read later on. 
getSolutionItems :: Solution -> [Item] 
getSolutionItems (info,items) = items 

getItemInfo :: Item -> ItemInfo 
getItemInfo (iteminfo,itemname) = iteminfo 

getWeight :: ItemInfo -> Double 
getWeight (weight,profit) = weight 

getSolutionInfo :: Solution -> ItemInfo 
getSolutionInfo (info,items) = info 

getProfit :: ItemInfo -> Double 
getProfit (weight,profit) = profit 


knapsack :: Filter -> [Item] -> Solution -> Maybe Solution -> Maybe Solution 
knapsack filter []      currentsolution bestsolution = if (getFilterTerminationCondition filter) currentsolution == (getFilterUsesTerminatingSolution filter) then knapsackCompareValidSolutions filter currentsolution bestsolution else bestsolution 
knapsack filter (newitem:remainingitems) currentsolution bestsolution = let bestsolutionwithout = knapsack filter remainingitems currentsolution bestsolution 
                      currentsolutionwith = (((getWeight $ getSolutionInfo currentsolution)+(getWeight $ getItemInfo newitem),(getProfit $ getSolutionInfo currentsolution)+(getProfit $ getItemInfo newitem)),((getSolutionItems currentsolution) ++ [newitem])) 
                     in if (getFilterTerminationCondition filter) currentsolutionwith then knapsackCompareValidSolutions filter (if (getFilterUsesTerminatingSolution filter) then currentsolutionwith else currentsolution) bestsolutionwithout else knapsack filter remainingitems currentsolutionwith bestsolutionwithout 

knapsackCompareValidSolutions :: Filter -> Solution -> Maybe Solution -> Maybe Solution 
knapsackCompareValidSolutions filter currentsolution bestsolution = let returnval = case bestsolution of 
                         Nothing  -> currentsolution 
                         Just solution -> (getFilterComparator filter) currentsolution solution 
                    in Just returnval 

knapsackStart :: Filter -> [Item] -> Maybe Solution 
knapsackStart filter allitems = knapsack filter allitems ((0,0),[]) Nothing 

knapsackProblemItems :: [Item] 
knapsackProblemItems = 
    [ 
    ((4.13, 1.40),"Weapon and Ammunition"), 
    ((2.13, 2.74),"Water"), 
    ((3.03, 1.55),"Pith Helmet"), 
    ((2.26, 0.82),"Sun Cream"), 
    ((3.69, 2.38),"Tent"), 
    ((3.45, 2.93),"Flare Gun"), 
    ((1.09, 1.77),"Olive Oil"), 
    ((2.89, 0.53),"Firewood"), 
    ((1.08, 2.77),"Kendal Mint Cake"), 
    ((2.29, 2.85),"Snake Repellant Spray"), 
    ((3.23, 4.29),"Bread"), 
    ((0.55, 0.34),"Pot Noodles"), 
    ((2.82,-0.45),"Software Engineering Textbook"), 
    ((2.31, 2.17),"Tinned food"), 
    ((1.63, 1.62),"Pork Pie") 
    ] 

knapsackProblemMaxDistance :: Double -> Filter 
knapsackProblemMaxDistance maxweight = ((\solution -> (getWeight $ getSolutionInfo solution) > maxweight),(\solution1 solution2 -> if (getProfit $ getSolutionInfo solution1) > (getProfit $ getSolutionInfo solution2) then solution1 else solution2),False) 

knapsackProblemMinWeight :: Double -> Filter 
knapsackProblemMinWeight mindays = ((\solution -> (getProfit $ getSolutionInfo solution) >= mindays),(\solution1 solution2 -> if (getWeight $ getSolutionInfo solution1) < (getWeight $ getSolutionInfo solution2) then solution1 else solution2),True) 

knapsackProblem1 = knapsackStart (knapsackProblemMaxDistance 20) knapsackProblemItems 
knapsackProblem2 = knapsackStart (knapsackProblemMaxDistance 25) knapsackProblemItems 
knapsackProblem3 = knapsackStart (knapsackProblemMinWeight 25) knapsackProblemItems 

Answer 1

如果我猜的话，我会说，currentsolution和bestsolution参数knapsack不被评估热切不够。您可以通过添加该行强制评估：

knapsack _ _ currentsolution bestsolution | currentsolution `seq` bestsolution `seq` False = undefined 

之前的另外两种情况。

另外，不要使用元组，而应考虑创建新的数据类型。例如

data Filter = Filter 
    { getFilterTerminationCondition :: FilterTerminationCondition 
    , getFilterComparator :: FilterComparator 
    , getFilterUsesTerminatingSolution :: FilterUsesTerminatingSolution }