Haskell - предотвращение переполнения стека элементов управления с рекурсией дерева

Question

Для университетского задания мы должны исследовать различные решения проблемы ранца, а затем реализовать решение как в Haskell, так и в Python.

Я выбрал грубую силу. Я понимаю, что есть лучшие алгоритмы, но причина этого выбора выходит за рамки этой статьи.

Однако в обеих попытках я получаю переполнение стека элементов управления при использовании HUGS, но не при использовании GHC.

Исследование, похоже, указывает на проблему строгости/лени, где мой код заканчивается тем, что генерирует чрезмерное количество громкоговорителей, и кажется, что анализ строгости 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 }