Re: [Haskell-beginners] Genetic algorithm for knapsack problem

16 May 2011

      I wrote this for now and it's working pretty well ;)

Any comments?

import AI.SimpleEA
import AI.SimpleEA.Utils

import Control.Monad.Random
import Data.List
import System.Environment (getArgs)
import Control.Monad (unless)

data Item = Item {
    mass  :: Double,
    value :: Double
    }

instance Show Item where
    show i = "(" ++ show (mass i) ++ "," ++ show (value i) ++ ")"

type Gene = (Bool, Item)

capacity = 10.0
items = [  Item 5.0 0.2
         , Item 2.4 0.8
         , Item 1.7 1.9
         , Item 6.0 0.5
         , Item 0.5 0.1
         , Item 2.2 1.2
         , Item 1.4 7.8
         , Item 0.7 1.4
         , Item 6.9 0.3
         , Item 1.5 0.2
         , Item 4.2 0.5
        ]
genes = [ zip [True,  False, True,  True,  False, True,  False, True,
True,  True, True ] items
        ,zip [True,  True, False, False, True, True,  True, False,
False, True, True ] items
        ,zip [False, False, False, False, False, False,  True, False,
False, True, True ] items
        ,zip [False, True, False, True,  True, True,  True, False,
True,  True, True ] items
        ,zip [False, True, False, True,  True, False, False, False,
True,  False, False] items
       ]

fitness :: FitnessFunc Gene
fitness g _
    | massSum > capacity = 0.0
    | otherwise          = valSum
  where
    massSum = foldr (\i s -> s + (mass  $ snd i) ) 0.0 $ filter fst g
    valSum  = foldr (\i s -> s + (value $ snd i) ) 0.0 $ filter fst g

select :: SelectionFunction Gene
select gs = select' (take 4 $ elite gs)
    where scaled = zip (map fst gs) (sigmaScale (map snd gs))
          select' gs' =
              if length gs' >= length gs
                 then return gs'
                 else do
                     p1 <- fitPropSelect scaled
                     p2 <- fitPropSelect scaled
                     let newPop = p1:p2:gs'
                     select' newPop

recombination :: Double -> RecombinationOp Gene
recombination p (g1,g2) = do
    t <- getRandomR (0.0, 1.0)
    if t < p
       then do
           r <- getRandomR (0, length g1-1)
           return (take r g1 ++ drop r g2, take r g2 ++ drop r g1)
       else return (g1,g2)

mutate :: Double -> MutationOp Gene
mutate p g = do
    t <- getRandomR (0.0, 1.0)
    if t < p
       then do
           r <- getRandomR (0, length g-1)
           return (take r g ++ flipItem (g !! r) : drop (r+1) g)
       else return g
        where
              flipItem (False, i) = (True,  i)
              flipItem (True,  i) = (False, i)

main = do
    args <- getArgs
    g <- newStdGen
    let (g1,g2) = split g
    let gs = take 401 $ runEA genes fitness select (recombination
0.75) (mutate 0.01) g2
    let fs = avgFitnesses gs
    let ms = maxFitnesses gs
    let ds = stdDeviations gs
    mapM_ print $ zip5 (map head gs) [1..] fs ms ds
    unless (null args) $ writeFile (head args) $ getPlottingData gs

Regards,
Karol Samborski