Example of Genetic Algorithm ============================ We use the Haskell GA package > {-# LANGUAGE FlexibleInstances #-} > {-# LANGUAGE MultiParamTypeClasses #-} > {-# LANGUAGE TypeSynonymInstances #-} > module GAexample where > > import Data.List (foldl') > import System.Random (mkStdGen, random, randoms) > > import GA (Entity(..), GAConfig(..), > evolve, evolveVerbose, randomSearch) Efficient sum: > sum' :: (Num a) => [a] -> a > sum' = foldl' (+) 0 Efficient product: > product' :: (Num a) => [a] -> a > product' = foldl' (*) 1 > type Bit = Integer > list2vector :: [Integer] -> [Bit] > list2vector xs = l2v 1 xs where > l2v _ [] = [] > l2v n (m:ms) = if n == m then 1 : l2v (n+1) ms > else 0 : l2v (n+1) (m:ms) > > vector2list :: [Bit] -> [Integer] > vector2list bs = filter (/= 0) (zipWith (*) bs [1..]) > complement :: [Bit] -> [Bit] > complement = map (flip mod 2 . succ) > sumprod :: [Bit] -> (Integer,Integer) > sumprod e = (n,m) where > n = sum' \$ vector2list e > m = product' \$ vector2list \$ complement e GA Type Class implementation > type Cards = [Bit] > instance Entity Cards Integer () Int IO where > > genRandom k seed = return (take k is) > where > g = mkStdGen seed > is = map (flip mod 2) \$ randoms g > > crossover n _ seed e1 e2 = let > k = seed `mod` (n+1) > in > return \$ Just (take k e1 ++ drop k e2) > > mutation n _ seed e = let > k = fst \$ random (mkStdGen seed) > m = mod k n > xs = take m e > (y:ys) = drop m e > y' = mod (y+1) 2 > in > return \$ Just (xs ++ [y'] ++ ys) > > score' _ e = Just (abs (10*n - m)) where > (n,m) = sumprod e > > isPerfect (_,s) = s == 0 > main :: IO() > main = do > let cfg = GAConfig > 100 -- population size > 25 -- archive size (best entities to keep track of) > 100 -- maximum number of generations > 0.8 -- crossover rate (% of entities by crossover) > 0.2 -- mutation rate (% of entities by mutation) > 0.0 -- parameter for crossover (not used here) > 0.2 -- parameter for mutation (% of replaced bits) > False -- whether or not to use checkpointing > False -- don't rescore archive in each generation > > g = mkStdGen 0 -- random generator > > -- Do the evolution! > -- last parameter (extra data to score an entity) > -- unused in this example > es <- evolveVerbose g cfg 40 () > let e = snd \$ head es :: [Integer] > > putStrLn \$ "selected: " > ++ (show (vector2list e)) ++ show (sumprod e)