Haskell - Avoiding a control stack overflow with tree recursion

Question

For a university assignment, we have to investigate the various solutions to the knapsack problem, and then implement a solution in both Haskell and Python.

I have chosen brute force. I realize there are better algorithms, but the reason for this choice is beyond the scope of this post.

However, in both my attempts, I end up with a control stack overflow when using HUGS, but not when using GHC.

Investigation seems to point to a problem regarding strictness/laziness, where my code ends up generating an excessive amount of thunks, and it seems that GHC's strictness analysis is removing the problem.

Can someone point out where I am going wrong in the code I have provided below, and give me a lead on how to go about fixing the issue.

Note: I have only 4 weeks experience with Haskell, so realize my code will be naive compared to that written by Haskell experts.

Edit: Adding a few `seq` statements in has made the program work in HUGS. However, it seems like a bit of a hack. Are there any other possible improvements? I have accepted an answer but any further advice would be appreciated.

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

If I had to guess, I would say that the currentsolution and bestsolution arguments to knapsack are not evaluated eagerly enough. You can force evaluation by adding the line:

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

before the other two cases.

As an aside, instead of using tuple, you should consider creating new datatypes. For example

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