moo-1.2: examples/knapsack.hs

{-
  The 0-1 knapsack problem. Given a set of items with given weight and value,
  choose which items to put into collection to maximize collection value
  with given maximum weight constraint.

  It is a binary genetic algorithm. This example interleaves computation
  with logging in IO monad, and terminates by reaching a time limit.

  To run:

      ghc --make knapsack.hs
      ./knapsack > output.txt

  To visualize the output in gnuplot:

      % gnuplot
      > plot 'output.txt' u 1:2 w l t 'median value', '' u 1:3 w l t 'best value' lt 3
-}

import Moo.GeneticAlgorithm.Binary

import Control.Monad
import Data.List (intercalate)

type Weight = Int
type Value = Int
type Problem = [(Weight, Value)]

items = 42
itemWeight = (1,9 :: Weight)
itemValue = (0,9 :: Value)
maxTotalWeight = items*2 :: Weight

popsize = 11
elitesize = 1

-- fitness function to maximize
totalValue :: Problem -> [Bool] -> Objective
totalValue things taken = fromIntegral . snd $ totalWeithtAndValue things taken

totalWeithtAndValue :: Problem -> Genome Bool -> (Weight, Value)
totalWeithtAndValue things taken = sumVals (0,0) $ zip taken things
  where
    sumVals (totalW, totalV) ((True, (w,v)):rest)  -- item is taken
        | totalW + w > maxTotalWeight  = (totalW, totalV)  -- weight limit exceeded
        | otherwise                    = sumVals (totalW+w,totalV+v) rest
    sumVals acc ((False, _):rest)      = sumVals acc rest
    sumVals (totalW, totalV) []        = (totalW, totalV)  -- all items in the knapsack


select = tournamentSelect Maximizing 2 (popsize-elitesize)

-- generate items to choose from: [(weight, value)]
randomProblem ::  IO Problem
randomProblem = do
  rng <- newPureMT
  return . flip evalRand rng $ do
                      weights <- replicateM items $ getRandomR itemWeight
                      values <- replicateM items $ getRandomR itemValue
                      return $ zip weights values

geneticAlgorithm :: Problem -> IO (Population Bool)
geneticAlgorithm things = do
  let initialize = replicateM popsize $ replicateM items getRandom
  let fitness = totalValue things
  let nextGen = nextGeneration Maximizing fitness select elitesize
                          (onePointCrossover 0.5) (pointMutate 0.5)
  runIO initialize $ loopIO
         [DoEvery 10 logStats, TimeLimit 0.1]  -- stop after 100 ms
         (Generations maxBound)  -- effectively, forever; unless an IOHook condition triggers
         nextGen

  where

    logStats :: Int -> Population Bool -> IO ()
    logStats iterno pop = do
      when (iterno == 0) $
           putStrLn "# generation medianValue bestValue"
      let gs = map takeGenome . bestFirst Maximizing $ pop  -- genomes
      let best = head gs
      let median = gs !! (length gs `div` 2)
      let bvalue = snd $ totalWeithtAndValue things best
      let mvalue = snd $ totalWeithtAndValue things median
      putStrLn $ intercalate " " (map show [iterno, mvalue, bvalue])


main = do
  things <- randomProblem
  pop <- geneticAlgorithm things
  putStrLn "# final population:"
  let best = takeGenome . head . bestFirst Maximizing $ pop
  let bestthings = zip best things
  let taken = intercalate ", " . map (showItem . snd) $ filter fst bestthings
  let left = intercalate ", " . map (showItem . snd) $ filter (not . fst) bestthings
  putStrLn $ showPop pop
  putStrLn $ "# taken: " ++ taken
  putStrLn $ "# left: " ++ left

  where
    showPop = intercalate "\n" . map showG
    showG (bs,v) = "# " ++ (concatMap (show . fromEnum) bs) ++ " " ++ show v
    showItem (w, v) = "$" ++ show v ++ "/" ++ show w ++ "oz"