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 }