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

如果我不得不猜测，我会说 knapsack 的 currentsolution 和 bestsolution 参数没有得到足够的评估。您可以通过添加以下行来强制评估：

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

在其他两种情况之前。

顺便说一句，您应该考虑创建新的数据类型，而不是使用元组。例如

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