GA 0.1 → 0.2

raw patch · 11 files changed

+738/−427 lines, 11 filesdep +transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: transformers

API changes (from Hackage documentation)

Files

• Changelog +10/−0
• GA.cabal +7/−3
• GA.hs +411/−196
• Makefile +0/−7
• README +7/−12
• example1.hs +0/−107
• example2.hs +0/−102
• examples/Makefile +7/−0
• examples/example1.hs +101/−0
• examples/example2.hs +95/−0
• examples/example3.hs +100/−0

@@ -9,3 +9,13 @@ 	- checkpointing between generations with automatic restore from checkpoint * two toy examples +v0.2 (Sept. 19th 2011):++* fixed compilation warnings in GA module and examples+* major API changes+  - generalized result type of evolve from IO a to Monad m => m a+  - hist genRandom, crossover, mutation adn scores into genertic Monad m+* introduced evolveVerbose which allows checkpointing, and prints+  progress to stdout (requires liftIO)+* implemented random search+* code cleanup and reorganization

@@ -1,5 +1,5 @@ Name:                GA-Version:             0.1+Version:             0.2 Synopsis:            Genetic algorithm library License:             BSD3 License-file:        LICENSE@@ -23,14 +23,18 @@   Checkpointing in between generations is available, as is automatic   restoring from the last available checkpoint.    -Extra-source-files:  example1.hs, example2.hs, Makefile+Extra-source-files:  examples/example1.hs, +                     examples/example2.hs, +                     examples/example3.hs, +                     Makefile Tested-with:         GHC==6.12.1  Library   exposed-modules:     GA   extensions:          FunctionalDependencies, MultiParamTypeClasses   ghc-options:         -Wall-  build-depends:       base >= 4 && < 5, directory, random+  build-depends:       base >= 4 && < 5, directory, +                       random, transformers  source-repository head   type: git

@@ -3,119 +3,166 @@  -- |GA, a Haskell library for working with genetic algoritms ----- Aug. 2011, by Kenneth Hoste+-- Aug. 2011 - Sept. 2011, by Kenneth Hoste ----- version: 0.1+-- version: 0.2 module GA (Entity(..),             GAConfig(..), -           ShowEntity(..), -           evolve) where+           evolve, +           evolveVerbose,+           randomSearch) where -import Data.List (intersperse, sortBy, nub)-import Data.Maybe (fromJust, isJust)+import Control.Monad (zipWithM)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.List (sortBy, nub)+import Data.Maybe (catMaybes, fromJust, isJust) import Data.Ord (comparing)-import Debug.Trace (trace) import System.Directory (createDirectoryIfMissing, doesFileExist)-import System.Random (StdGen, mkStdGen, randoms)---- DEBUGGING---- |Enable/disable debugging output (hard coded).-debug :: Bool-debug = False---- |Return value with debugging output if debugging is enabled.-dbg :: String -> a -> a-dbg str x = if debug-                then trace str x-                else x +import System.Random (StdGen, mkStdGen, random, randoms)  -- |Currify a list of elements into tuples.-currify :: [a] -> [(a,a)]+currify :: [a] -- ^ list+           -> [(a,a)] -- ^ list of tuples currify (x:y:xs) = (x,y):currify xs currify [] = [] currify [_] = error "(currify) ERROR: only one element left?!?"  -- |Take and drop elements of a list in a single pass.-takeAndDrop :: Int -> [a] -> ([a],[a])+takeAndDrop :: Int -- ^ number of elements to take/drop+            -> [a] -- ^ list +            -> ([a],[a]) -- ^ result: taken list element and rest of list takeAndDrop n xs-        | n > 0     = let (hs,ts) = takeAndDrop (n-1) (tail xs) in (head xs:hs, ts)-        | otherwise = ([],xs)-+    | n > 0     = let (hs,ts) = takeAndDrop (n-1) (tail xs) +                   in (head xs:hs, ts)+    | otherwise = ([],xs)  -- |Configuration for genetic algorithm. data GAConfig = GAConfig {-                -- |population size-                popSize :: Int, -                -- |size of archive (best entities so far)-                archiveSize :: Int, -                -- |maximum number of generations to evolve-                maxGenerations :: Int, -                -- |fraction of entities generated by crossover (tip: >= 0.80)-                crossoverRate :: Float, -                -- |fraction of entities generated by mutation (tip: <= 0.20)-                mutationRate :: Float, -                -- |parameter for crossover (semantics depend on actual crossover operator)-                crossoverParam :: Float, -                -- |parameter for mutation (semantics depend on actual mutation operator)-                mutationParam :: Float, -                -- |enable/disable built-in checkpointing mechanism-                withCheckpointing :: Bool +    -- |population size+    getPopSize :: Int, +    -- |size of archive (best entities so far)+    getArchiveSize :: Int, +    -- |maximum number of generations to evolve+    getMaxGenerations :: Int, +    -- |fraction of entities generated by crossover (tip: >= 0.80)+    getCrossoverRate :: Float, +    -- |fraction of entities generated by mutation (tip: <= 0.20)+    getMutationRate :: Float, +    -- |parameter for crossover (semantics depend on crossover operator)+    getCrossoverParam :: Float, +    -- |parameter for mutation (semantics depend on mutation operator)+    getMutationParam :: Float, +    -- |enable/disable built-in checkpointing mechanism+    getWithCheckpointing :: Bool,+    -- |rescore archive in each generation?+    getRescoreArchive :: Bool                 }  -- |Type class for entities that represent a candidate solution. ----- Three parameters:+-- Five parameters: ----- * data structure representing an entity (a)+-- * data structure representing an entity (e) ----- * data used to score an entity, e.g. a list of numbers (b)+-- * score type (s), e.g. Double ----- * some kind of pool used to generate random entities, e.g. a Hoogle database (c)+-- * data used to score an entity, e.g. a list of numbers (d) ---class (Eq a, Read a, Show a, ShowEntity a) => Entity a b c | a -> b, a -> c where-  -- |Generate a random entity.-  genRandom :: c -> Int -> a-  -- |Crossover operator: combine two entities into a new entity.-  crossover :: c -> Float -> Int -> a -> a -> Maybe a-  -- |Mutation operator: mutate an entity into a new entity.-  mutation :: c -> Float -> Int -> a -> Maybe a-  -- |Score an entity (lower is better).-  score :: a -> b -> Double+-- * some kind of pool used to generate random entities, +--   e.g. a Hoogle database (p)+--+-- * monad to operate in (m)+--+-- Minimal implementation includes genRandom, crossover, mutation, +-- and either score', score or scorePop.+--+class (Eq e, Read e, Show e, +       Ord s, Read s, Show s, +       Monad m)+   => Entity e s d p m +    | e -> s, e -> d, e -> p, e -> m where --- |A possibly scored entity.-type ScoredEntity a = (Maybe Double, a)+  -- |Generate a random entity. [required]+  genRandom :: p -- ^ pool for generating random entities+            -> Int -- ^ random seed+            -> m e -- ^ random entity --- |Scored generation (population and archive).-type ScoredGen a = ([ScoredEntity a],[ScoredEntity a])+  -- |Crossover operator: combine two entities into a new entity. [required]+  crossover :: p -- ^ entity pool+            -> Float -- ^ crossover parameter+            -> Int -- ^ random seed+            -> e -- ^ first entity+            -> e -- ^ second entity+            -> m (Maybe e) -- ^ entity resulting from crossover --- |Type class for pretty printing an entity instead of just using the default show implementation.-class ShowEntity a where-  -- |Show an entity.-  showEntity :: a -> String+  -- |Mutation operator: mutate an entity into a new entity. [required]+  mutation :: p -- ^ entity pool+           -> Float -- ^ mutation parameter+           -> Int -- ^ random seed+           -> e -- ^ entity to mutate+           -> m (Maybe e) -- ^ mutated entity --- |Show a scored entity.-showScoredEntity :: ShowEntity a => ScoredEntity a -> String-showScoredEntity (score,e) = "(" ++ show score ++ ", " ++ showEntity e ++ ")"+  -- |Score an entity (lower is better), pure version. [optional]+  --+  -- Overridden if score or scorePop are implemented.+  score' :: d -- ^ dataset for scoring entities+         -> e -- ^ entity to score+         -> (Maybe s) -- ^ entity score+  score' _ _ = error $ "(GA) score' is not defined, "+                    ++ "nor is score or scorePop!" --- |Show a list of scored entities.-showScoredEntities :: ShowEntity a => [ScoredEntity a] -> String-showScoredEntities es = ("["++) . (++"]") . concat . intersperse "," $ map showScoredEntity es+  -- |Score an entity (lower is better), monadic version. [optional]+  --+  -- Default implementation hoists score' into monad, +  -- overriden if scorePop is implemented.+  score :: d -- ^ dataset for scoring entities+        -> e -- ^ entity to score+        -> m (Maybe s) -- ^ entity score+  score d e = do +                 return $ score' d e --- |Initialize: generate initial population.-initPop :: (Entity a b c) => c -> Int -> [Int] -> ([Int],[a])-initPop src n seeds = (seeds'', entities)-  where-    (seeds',seeds'')  = takeAndDrop n seeds-    entities = map (genRandom src) seeds'+  -- |Score an entire population of entites. [optional]+  --+  -- Default implementation returns Nothing, +  -- and triggers indivual of entities.+  scorePop :: d -- ^ dataset to score entities+           -> [e] -- ^ universe of known entities+           -> [e] -- ^ population of entities to score+           -> m (Maybe [Maybe s]) -- ^ scores for population entities+  scorePop _ _ _ = return Nothing --- |Score an entity (if it hasn't been already).-scoreEnt :: (Entity a b c) => b -> ScoredEntity a -> ScoredEntity a-scoreEnt d e@(Just _,_) = e-scoreEnt d (Nothing,x) = (Just $ score x d, x)+  -- |Determines whether a score indicates a perfect entity. [optional]+  --+  -- Default implementation returns always False.+  isPerfect :: (e,s) -- ^ scored entity+               -> Bool -- ^ whether or not scored entity is perfect+  isPerfect _ = False ++-- |A possibly scored entity.+type ScoredEntity e s = (Maybe s, e)++-- |Scored generation (population and archive).+type Generation e s = ([e],[ScoredEntity e s])++-- |Universe of entities.+type Universe e = [e]++-- |Initialize: generate initial population.+initPop :: (Entity e s d p m) => p -- ^ pool for generating random entities+                            -> Int -- ^ population size+                            -> Int -- ^ random seed+                            -> m [e] -- ^ initialized population+initPop pool n seed = do+                         let g = mkStdGen seed+                             seeds = take n $ randoms g+                         entities <- mapM (genRandom pool) seeds+                         return entities+ -- |Binary tournament selection operator.-tournamentSelection :: [ScoredEntity a] -> Int -> a+tournamentSelection :: (Ord s) => [ScoredEntity e s] -- ^ set of entities+                               -> Int -- ^ random seed+                               -> e -- ^ selected entity tournamentSelection xs seed = if s1 < s2 then x1 else x2   where     len = length xs@@ -123,140 +170,308 @@     is = take 2 $ map (flip mod len) $ randoms g     [(s1,x1),(s2,x2)] = map ((!!) xs) is +-- |Apply crossover to obtain new entites.+performCrossover :: (Entity e s d p m) => Float -- ^ crossover parameter+                                     -> Int -- ^ number of entities+                                     -> Int -- ^ random seed+                                     -> p -- ^ pool for combining entities+                                     -> [ScoredEntity e s] -- ^ entities+                                     -> m [e] -- combined entities+performCrossover p n seed pool es = do +    let g = mkStdGen seed+        (selSeeds,seeds) = takeAndDrop (2*2*n) $ randoms g+        (crossSeeds,_) = takeAndDrop (2*n) seeds+        tuples = currify $ map (tournamentSelection es) selSeeds+    resEntities <- zipWithM ($) +                     (map (uncurry . (crossover pool p)) crossSeeds) +                     tuples+    return $ take n $ catMaybes $ resEntities++-- |Apply mutation to obtain new entites.+performMutation :: (Entity e s d p m) => Float -- ^ mutation parameter+                                    -> Int -- ^ number of entities+                                    -> Int -- ^ random seed+                                    -> p -- ^ pool for mutating entities+                                    -> [ScoredEntity e s] -- ^ entities+                                    -> m [e] -- mutated entities+performMutation p n seed pool es = do +    let g = mkStdGen seed+        (selSeeds,seeds) = takeAndDrop (2*n) $ randoms g+        (mutSeeds,_) = takeAndDrop (2*n) seeds+    resEntities <- zipWithM ($) +                     (map (mutation pool p) mutSeeds) +                     (map (tournamentSelection es) selSeeds)+    return $ take n $ catMaybes $ resEntities++-- |Score a list of entities.+scoreAll :: (Entity e s d p m) => d -- ^ dataset for scoring entities+                               -> [e] -- ^ universe of known entities+                               -> [e] -- ^ set of entities to score+                               -> m [Maybe s]+scoreAll dataset univEnts ents = do+  scores <- scorePop dataset univEnts ents+  case scores of+    (Just ss) -> return ss+    -- score one by one if scorePop failed+    Nothing   -> mapM (score dataset) ents+  -- |Function to perform a single evolution step: ----- * score all entities+-- * score all entities in the population ----- * combine with best entities so far+-- * combine with best entities so far (archive) -- -- * sort by fitness -- -- * create new population using crossover/mutation-evolutionStep :: (Entity a b c) => c -> b -> (Int,Int,Int) -> (Float,Float) -> ScoredGen a -> (Int,Int) -> ScoredGen a-evolutionStep src d (cn,mn,an) (crossPar,mutPar) (pop,archive) (gi,seed) = dbg (   "\n\ngeneration " ++ (show gi) ++ ": \n\n" -                                                                              ++ "  scored population: " ++ (showScoredEntities scoredPop) ++ "\n\n"-                                                                              ++ "  archive: " ++ (showScoredEntities archive') ++ "\n\n"-                                                                              ++ "  archive fitnesses: " ++ (show $ map fst archive') ++ "\n\n"-                                                                              ++ "  generated " ++ show (length pop') ++ " entities\n\n"-                                                                              ++ (replicate 150 '='))-                                                                       (pop',archive')-  where+--+-- * retain best scoring entities in the archive+evolutionStep :: (Entity e s d p m) => p -- ^ pool for crossover/mutation+                                  -> d -- ^ dataset for scoring entities+                                  -> (Int,Int,Int) -- ^ # of c/m/a entities+                                  -> (Float,Float) -- ^ c/m parameters+                                  -> Bool -- ^ rescore archive in each step?+                                  -> Universe e -- ^ known entities+                                  -> Generation e s -- ^ current generation+                                  -> Int -- ^ seed for next generation+                                  -> m (Universe e, Generation e s) +                                     -- ^ renewed universe, next generation+evolutionStep pool+              dataset+              (cn,mn,an)+              (crossPar,mutPar)+              rescoreArchive+              universe+              (pop,archive)+              seed = do      -- score population-    scoredPop = map (scoreEnt d) pop-    -- combine with archive for selection-    combo = scoredPop ++ archive-    -- split seeds for crossover selection/seeds, mutation selection/seeds-    seeds = randoms (mkStdGen seed) :: [Int]-    -- generate twice as many crossover/mutation entities as needed, because crossover/mutation can fail-    (crossSelSeeds,seeds')   = takeAndDrop (2*2*cn) seeds-    (crossSeeds   ,seeds'')  = takeAndDrop (2*cn) seeds'-    (mutSelSeeds  ,seeds''') = takeAndDrop (2*mn) seeds''-    (mutSeeds     ,_)        = takeAndDrop (2*mn) seeds'''-    -- crossover entities-    crossSel = currify $ map (tournamentSelection combo) crossSelSeeds-    crossEnts = take cn $ map fromJust $ filter isJust $ zipWith ($) (map (uncurry . (crossover src crossPar)) crossSeeds) crossSel-    -- mutation entities-    mutSel = map (tournamentSelection combo) mutSelSeeds-    mutEnts = take cn $ map fromJust $ filter isJust $ zipWith ($) (map (mutation src mutPar) mutSeeds) mutSel-    -- new population: crossovered + mutated entities-    pop' = zip (repeat Nothing) $ crossEnts ++ mutEnts-    -- new archive: best entities so far-    archive' = take an $ nub $ sortBy (comparing fst) $ filter (isJust . fst) combo+    -- try to score in a single go first+    scores <- scoreAll dataset universe pop+    archive' <- if rescoreArchive+      then return archive+      else do+        let as = map snd archive+        scores' <- scoreAll dataset universe as+        return $ zip scores' as+    let scoredPop = zip scores pop+        -- combine with archive for selection+        combo = scoredPop ++ archive'+        -- split seeds for crossover/mutation selection/seeds+        g = mkStdGen seed+        [crossSeed,mutSeed] = take 2 $ randoms g+    -- apply crossover and mutation+    crossEnts <- performCrossover crossPar cn crossSeed pool combo+    mutEnts <- performMutation mutPar mn mutSeed pool combo+    let -- new population: crossovered + mutated entities+        newPop = crossEnts ++ mutEnts+        -- new archive: best entities so far+        newArchive = take an $ nub $ sortBy (comparing fst) $ combo+        newUniverse = nub $ universe ++ pop+    return (newUniverse, (newPop,newArchive)) --- |Generate file name for checkpoint.-chkptFileName :: GAConfig -> (Int,Int) -> FilePath-chkptFileName cfg (gi,seed) = dbg fn fn-  where-    cfgTxt = (show $ popSize cfg) ++ "-" ++ -             (show $ archiveSize cfg) ++ "-" ++-             (show $ crossoverRate cfg) ++ "-" ++-             (show $ mutationRate cfg) ++ "-" ++-             (show $ crossoverParam cfg) ++ "-" ++-             (show $ mutationParam cfg)-    fn = "checkpoints/GA-" ++ cfgTxt ++ "-gen" ++ (show gi) ++ "-seed-" ++ (show seed) ++ ".chk"+-- |Evolution: evaluate generation and continue.+evolution :: (Entity e s d p m) => GAConfig -- ^ configuration for GA+                                -> Universe e -- ^ known entities +                                -> Generation e s -- ^ current generation+                                -> (   Universe e+                                    -> Generation e s +                                    -> Int +                                    -> m (Universe e, Generation e s)+                                   ) -- ^ function that evolves a generation+                                -> [(Int,Int)] -- ^ gen indicies and seeds+                                -> m (Generation e s) -- ^evolved generation+evolution cfg universe gen step ((_,seed):gss) = do+    (universe',nextGen) <- step universe gen seed +    let (Just fitness, e) = (head $ snd nextGen)+    if isPerfect (e,fitness)+      then return nextGen+      else evolution cfg universe' nextGen step gss+-- no more gen. indices/seeds => quit+evolution _ _ gen _              []    = return gen --- |Try to restore from checkpoint: first checkpoint for which a checkpoint file is found is restored.-restoreFromCheckpoint :: (Entity a b c) => GAConfig -> [(Int,Int)] -> IO (Maybe (Int,ScoredGen a))-restoreFromCheckpoint cfg ((gi,seed):genSeeds) = do-                                                  chkptFound <- doesFileExist fn-                                                  if chkptFound -                                                    then do-                                                          txt <- dbg ("chk for gen. " ++ (show gi) ++ " found") readFile fn-                                                          return $ Just (gi, read txt)-                                                    else restoreFromCheckpoint cfg genSeeds+-- |Generate file name for checkpoint.+chkptFileName :: GAConfig -- ^ configuration for generation algorithm+              -> (Int,Int) -- ^ generation index and random seed+              -> FilePath -- ^ path of checkpoint file+chkptFileName cfg (gi,seed) = "checkpoints/GA-" +                           ++ cfgTxt ++ "-gen" +                           ++ (show gi) ++ "-seed-" +                           ++ (show seed) ++ ".chk"   where-    fn = chkptFileName cfg (gi,seed)-restoreFromCheckpoint cfg [] = return Nothing+    cfgTxt = (show $ getPopSize cfg) ++ "-" ++ +             (show $ getArchiveSize cfg) ++ "-" +++             (show $ getCrossoverRate cfg) ++ "-" +++             (show $ getMutationRate cfg) ++ "-" +++             (show $ getCrossoverParam cfg) ++ "-" +++             (show $ getMutationParam cfg)  -- |Checkpoint a single generation.-checkpointGen :: (Entity a b c) => GAConfig -> Int -> Int -> ScoredGen a -> IO()+checkpointGen :: (Entity e s d p m) => GAConfig -- ^ configuraton for GA+                                  -> Int -- ^ generation index+                                  -> Int -- ^ random seed for generation+                                  -> Generation e s -- ^ current generation+                                  -> IO() -- ^ writes to file checkpointGen cfg index seed (pop,archive) = do-                                           let txt = show $ (pop,archive)-                                               fn = chkptFileName cfg (index,seed)-                                           if debug -                                              then putStrLn $ "writing checkpoint for gen " ++ (show index) ++ " to " ++ fn-                                              else return ()-                                           createDirectoryIfMissing True "checkpoints"-                                           writeFile fn txt+    let txt = show $ (pop,archive)+        fn = chkptFileName cfg (index,seed)+    putStrLn $ "writing checkpoint for gen " +            ++ (show index) ++ " to " ++ fn+    createDirectoryIfMissing True "checkpoints"+    writeFile fn txt  -- |Evolution: evaluate generation, (maybe) checkpoint, continue.-evolution :: (Entity a b c) => GAConfig -> ScoredGen a -> (ScoredGen a -> (Int,Int) -> ScoredGen a) -> [(Int,Int)] -> IO (ScoredGen a)-evolution cfg (pop,archive) step ((gi,seed):gss) = do-                                             let newPa@(_,archive') = step (pop,archive) (gi,seed)-                                                 (Just fitness, e) = head archive'-                                             -- checkpoint generation if desired-                                             if (withCheckpointing cfg)-                                               then checkpointGen cfg gi seed newPa-                                               else return () -- skip checkpoint-                                             putStrLn $ "best entity (gen. " ++ show gi ++ "): " ++ (show e) ++ " [fitness: " ++ show fitness ++ "]"-                                             -- check for perfect entity-                                             if (fromJust $ fst $ head archive') == 0.0-                                                then do -                                                        putStrLn $ "perfect entity found, finished after " ++ show gi ++ " generations!"-                                                        return newPa-                                                else evolution cfg newPa step gss+evolutionChkpt :: (Entity e s d p m, +                   MonadIO m) => GAConfig -- ^ configuration for GA+                              -> Universe e -- ^ universe of known entities+                              -> Generation e s -- ^ current generation+                              -> (   Universe e +                                  -> Generation e s +                                  -> Int +                                  -> m (Universe e, Generation e s)+                                 ) -- ^ function that evolves a generation+                              -> [(Int,Int)] -- ^ gen indicies and seeds+                              -> m (Generation e s) -- ^ evolved generation+evolutionChkpt cfg universe gen step ((gi,seed):gss) = do+    (universe',newPa@(_,archive')) <- step universe gen seed+    let (Just fitness, e) = head archive'+    -- checkpoint generation if desired+    liftIO $ if (getWithCheckpointing cfg)+      then checkpointGen cfg gi seed newPa+      else return () -- skip checkpoint+    liftIO $ putStrLn $ "best entity (gen. " +                     ++ show gi ++ "): " ++ (show e) +                     ++ " [fitness: " ++ show fitness ++ "]"+    -- check for perfect entity+    if isPerfect (e, fitness)+       then do +               liftIO $ putStrLn $ "perfect entity found, "+                                ++ "finished after " ++ show gi +                                ++ " generations!"+               return newPa+       else evolutionChkpt cfg universe' newPa step gss+ -- no more gen. indices/seeds => quit-evolution cfg (pop,archive) _              []    = do -                                                      putStrLn $ "done evolving!"-                                                      return (pop,archive)- +evolutionChkpt _ _ gen _ [] = do +    liftIO $ putStrLn $ "done evolving!"+    return gen++-- |Initialize.+initGA :: (Entity e s d p m) => StdGen  -- ^ random generator+                           -> GAConfig -- ^ configuration for GA+                           -> p -- ^ pool for generating random entities+                           -> m ([e],Int,Int,Int,+                                 Float,Float,[(Int,Int)]+                                ) -- ^ initialization result+initGA g cfg pool = do+    -- generate list of random integers+    let (seed:rs) = randoms g :: [Int]+        ps = getPopSize cfg+    -- initial population+    pop <- initPop pool ps seed+    let -- number of entities generated by crossover/mutation+        cCnt = round $ (getCrossoverRate cfg) * (fromIntegral ps)+        mCnt = round $ (getMutationRate cfg) * (fromIntegral ps)+        -- archive size+        aSize = getArchiveSize cfg+        -- crossover/mutation parameters+        crossPar = getCrossoverParam cfg+        mutPar = getMutationParam cfg+        --  seeds for evolution+        seeds = take (getMaxGenerations cfg) rs+        -- seeds per generation+        genSeeds = zip [0..] seeds+    return (pop, cCnt, mCnt, aSize, crossPar, mutPar, genSeeds)+ -- |Do the evolution!-evolve :: (Entity a b c) => StdGen -> GAConfig -> c -> b -> IO a-evolve g cfg src dataset = do-                -- generate list of random integers-                let rs = randoms g :: [Int]+evolve :: (Entity e s d p m) => StdGen -- ^ random generator+                             -> GAConfig -- ^ configuration for GA+                             -> p -- ^ random entities pool+                             -> d -- ^ dataset required to score entities+                             -> m [ScoredEntity e s] -- ^ best entities+evolve g cfg pool dataset = do+    -- initialize+    (pop, cCnt, mCnt, aSize, +     crossPar, mutPar, genSeeds) <- if not (getWithCheckpointing cfg)+       then initGA g cfg pool+       else error $ "(evolve) No checkpointing support " +                 ++ "(requires liftIO); see evolveVerbose."+    -- do the evolution+    let rescoreArchive = getRescoreArchive cfg+    (_,resArchive) <- evolution +                       cfg [] (pop,[]) +                       (evolutionStep pool dataset +                                      (cCnt,mCnt,aSize) +                                      (crossPar,mutPar) +                                      rescoreArchive   )+                       genSeeds+    -- return best entity+    return resArchive -                    -- initial population-                let (rs',pop) = initPop src (popSize cfg) rs+-- |Try to restore from checkpoint.+--+-- First checkpoint for which a checkpoint file is found is restored.+restoreFromChkpt :: (Entity e s d p m) => GAConfig -- ^ configuration for GA+                                       -> [(Int,Int)] -- ^ gen indices/seeds+                                       -> IO (Maybe (Int,Generation e s)) +                                          -- ^ restored generation (if any)+restoreFromChkpt cfg ((gi,seed):genSeeds) = do+    chkptFound <- doesFileExist fn+    if chkptFound +      then do+        txt <- readFile fn+        return $ Just (gi, read txt)+      else restoreFromChkpt cfg genSeeds+  where+    fn = chkptFileName cfg (gi,seed)+restoreFromChkpt _ [] = return Nothing -                let ps = popSize cfg-                    -- number of entities generated by crossover/mutation-                    cCnt = round $ (crossoverRate cfg) * (fromIntegral ps)-                    mCnt = round $ (mutationRate cfg) * (fromIntegral ps)-                    -- archive size-                    aSize = archiveSize cfg-                    -- crossover/mutation parameters-                    crossPar = crossoverParam cfg-                    mutPar = mutationParam cfg-                    --  seeds for evolution-                    seeds = take (maxGenerations cfg) rs'-                    -- seeds per generation-                    genSeeds = zip [0..] seeds-                    -- checkpoint?-                    checkpointing = withCheckpointing cfg-                    -- do the evolution-                restored <- if checkpointing-                               then restoreFromCheckpoint cfg (reverse genSeeds) :: (Entity a b c) => IO (Maybe (Int,ScoredGen a))-                               else return Nothing-                let (gi,(pop',archive')) = if isJust restored-                                          -- restored pop/archive from checkpoint-                                          then dbg ("restored from checkpoint!\n\n") $ fromJust restored -                                          -- restore failed, new population and empty archive-                                          else dbg (if checkpointing then "no checkpoint found...\n\n"-                                                                       else "checkpoints ignored...\n\n") -                                                         (-1, (zip (repeat Nothing) pop, []))-                (resPop,resArchive) <- evolution cfg (pop',archive') (evolutionStep src dataset (cCnt,mCnt,aSize) (crossPar,mutPar)) (filter ((>gi) . fst) genSeeds)-                -                if null resArchive-                  then error $ "(evolve) empty archive!"-                  else return $ snd $ head resArchive+-- |Do the evolution (supports checkpointing). +--+-- Requires support for liftIO in monad used.+evolveVerbose :: (Entity e s d p m, +                  MonadIO m) => StdGen -- ^ random generator+                             -> GAConfig -- ^ configuration for GA+                             -> p -- ^ random entities pool+                             -> d -- ^ dataset required to score entities+                             -> m [ScoredEntity e s] -- ^ best entities+evolveVerbose g cfg pool dataset = do+    -- initialize+    (pop, cCnt, mCnt, aSize, +     crossPar, mutPar, genSeeds) <- initGA g cfg pool+    let checkpointing = getWithCheckpointing cfg+    -- (maybe) restore from checkpoint+    restored <- liftIO $ if checkpointing+      then restoreFromChkpt cfg (reverse genSeeds) +      else return Nothing+    let (gi,gen) = if isJust restored+           -- restored pop/archive from checkpoint+           then fromJust restored +           -- restore failed, new population and empty archive+           else (-1, (pop, []))+        -- filter out seeds from past generations+        genSeeds' = filter ((>gi) . fst) genSeeds+        rescoreArchive = getRescoreArchive cfg+    -- do the evolution+    (_,resArchive) <- evolutionChkpt +                        cfg [] gen +                        (evolutionStep pool dataset +                                       (cCnt,mCnt,aSize) +                                       (crossPar,mutPar) +                                       rescoreArchive)+                                       genSeeds'+    -- return best entity +    return resArchive++-- |Random search.+--+-- Useful to compare with results from genetic algorithm.+randomSearch :: (Entity e s d p m) => StdGen -- ^ random generator+                                   -> Int -- ^ number of random entities+                                   -> p -- ^ random entity pool+                                   -> d -- ^ scoring dataset+                                   -> m [ScoredEntity e s] -- ^ best ents+randomSearch g n pool dataset = do+    let seed = fst $ random g :: Int+    es <- initPop pool n seed+    scores <- scoreAll dataset [] es+    return $ zip scores es

@@ -1,7 +0,0 @@-all: example1 example2--%: GA.hs %.hs-	ghc --make $@--clean:-	rm -f *.hi *.o example1 example2

@@ -1,7 +1,7 @@ GA, a Haskell library for working with genetic algorithms --------------------------------------------------------- -version 0.1, Aug. 2011, written by Kenneth Hoste (kenneth.hsote@gmail.com)+version 0.2, Sept. 2011, written by Kenneth Hoste (kenneth.hoste@gmail.com) see http://hackage.haskell.org/package/GA  * DESCRIPTION@@ -17,11 +17,12 @@ functions that are required by the genetic algorithm.  Checkpointing in between generations is available, as is automatic-restoring from the last available checkpoint. +restoring from the last available checkpoint (see evolveChkpt).   * BUILDING AND USING -Building the GA module and supplied examples can be done by running 'make'.+Building the supplied examples can be done by running 'make'+in the examples directory after the installation of the GA library.  Using the GA module should be clear after studying the examples. @@ -35,8 +36,8 @@ be solved using genetic algorithms. However, it does serve well as a toy  example. -The code in example1.hs illustrates how you can define the 'genRandom', -'crossover', 'mutation' and 'score' functions that are required to run +The code in example1.hs illustrates how you can define the "genRandom", +"crossover", "mutation" and "score'" functions that are required to run  the genetic algorithm using the 'evolve' function.  It also shows the use of a 'pool' that can be used to generate random@@ -44,10 +45,6 @@ data that can be used to evaluate the fitness of entities (in this case, the string "Hello World!"). -Example command line (with checkpointing enabled):--	./example1 100 25 200 0.8 0.2 0.0 0.2 True +RTS -M1G- The second example (see example2.hs) evolves an integer number that has 8 integer divisors, and for which the sum of its divisors equals 96. Although using a genetic algorithm is probably not the best way to find @@ -58,6 +55,4 @@ suffices to supply '()' as values to the evolve function, and to simply ignore the respective arguments passed to the Entity typeclass functions. -Example command line:--	./example2 20 10 100 0.8 0.2 0.0 0.2 False +RTS -M1G +The third example reimplements the first example, but inside the IO monad.

@@ -1,107 +0,0 @@-{--- - Example for GA package- - see http://hackage.haskell.org/package/GA- -- - Evolve the string "Hello World!"---}--{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeSynonymInstances #-}--import GA (Entity(..), GAConfig(..), ShowEntity(..), evolve)-import Data.Char (chr,ord)-import Data.List (foldl')-import System (getArgs,getProgName)-import System.Random (mkStdGen, random, randoms)---- efficient sum-sum' :: (Num a) => [a] -> a-sum' = foldl' (+) 0------- GA TYPE CLASS IMPLEMENTATION-----instance Entity String String [Char] where- -  -- generate a random entity, i.e. a random string-  -- assumption: max. 100 chars, only 'printable' ASCII (first 128)-  genRandom pool seed = take n $ map ((!!) pool) is-    where-        g = mkStdGen seed-        n = (fst $ random g) `mod` 101-        k = length pool-        is = map (flip mod k) $ randoms g--  -- crossover operator: mix (and trim to shortest entity)-  crossover _ _ seed e1 e2 = Just e-    where-      g = mkStdGen seed-      cps = zipWith (\x y -> [x,y]) e1 e2-      picks = map (flip mod 2) $ randoms g-      e = zipWith (!!) cps picks--  -- mutation operator: use next or previous letter randomly and add random characters (max. 9)-  mutation pool p seed e = Just $ (zipWith replace tweaks e) ++ addChars-    where-      g = mkStdGen seed-      k = round (1 / p) :: Int-      tweaks = randoms g :: [Int]-      replace i x = if (i `mod` k) == 0-                       then if even i-                               then if x > (minBound :: Char) then pred x else succ x-                               else if x < (maxBound :: Char) then succ x else pred x-                       else x-      is = map (flip mod $ length pool) $ randoms g-      addChars = take (seed `mod` 10) $ map ((!!) pool) is--  -- score: distance between current string and target-  -- sum of 'distances' between letters, large penalty for additional/short letters-  -- NOTE: lower is better-  score e x = fromIntegral $ d + 100*l-    where-      e' = map ord e-      x' = map ord x-      d = sum' $ map abs $ zipWith (-) e' x'-      l = abs $ (length x) - (length e)--instance ShowEntity String where -  showEntity = show- -main = do-        args <- getArgs-        progName <- getProgName-        if length args /= 8 -           then error $ "Usage: <pop. size> <archive size> <max. # generations> " ++-                               "<crossover rate> <mutation rate> " ++-                               "<crossover parameter> <mutation parameter> " ++-                               "<enable checkpointing (bool)>"-           else return ()-        let popSize       = read $ args !! 0-            archiveSize   = read $ args !! 1-            maxGens       = read $ args !! 2-            crossoverRate = read $ args !! 3-            mutationRate  = read $ args !! 4-            crossoverPar  = read $ args !! 5-            mutationPar   = read $ args !! 6-            checkpointing = read $ args !! 7-        let cfg = GAConfig -                    popSize -- population size-                    archiveSize -- archive size (best entities to keep track of)-                    maxGens -- maximum number of generations-                    crossoverRate -- crossover rate (% of new entities generated with crossover)-                    mutationRate -- mutation rate (% of new entities generated with mutation)-                    crossoverPar -- parameter for crossover operator (not used here)-                    mutationPar -- parameter for mutation operator (ratio of replaced letters)-                    checkpointing -- whether or not to use checkpointing--            g = mkStdGen 0 -- random generator--            -- pool of characters to pick from-            charsPool = map chr [32..126]-        -- Do the evolution!-        -- Note: if either of the last two arguments is unused, just use () as a value-        e <- evolve g cfg charsPool "Hello World!" :: IO String-        -        putStrLn $ "best entity: " ++ (show e)

@@ -1,102 +0,0 @@-{--- - Example for GA package- - see http://hackage.haskell.org/package/GA- -- - Evolve a single integer number to match the following features as closely as possible- -   * 8 integer divisors- -   * sum of divisors is 96---}--{-# LANGUAGE MultiParamTypeClasses #-}--import GA (Entity(..), GAConfig(..), ShowEntity(..), evolve)-import Data.List (foldl')-import Debug.Trace-import System (getArgs,getProgName)-import System.Random (mkStdGen, random)------- HELPER FUNCTIONS------- find all divisors of a number-divisors :: Int -> [Int]-divisors n = concat $ map (divsFor n) [1..(sqrt' n)]-  where-    divsFor n x = if n `mod` x == 0-                     then [x, n `div` x]-                     else []---- "integer" square root-sqrt' :: Int -> Int-sqrt' n = floor $ sqrt $ fromIntegral n---- efficient sum-sum' :: (Num a) => [a] -> a-sum' = foldl' (+) 0------- GA TYPE CLASS IMPLEMENTATION-----instance Entity Int () () where- -  -- generate a random entity, i.e. a random integer value -  genRandom _ seed = (fst $ random $ mkStdGen seed) `mod` 10000--  -- crossover operator: sum, (abs value of) difference or (rounded) mean-  crossover _ _ seed e1 e2 = Just $ case seed `mod` 3 of-                                         0 -> e1+e2-                                         1 -> abs (e1-e2)-                                         2 -> (e1+e2) `div` 2--  -- mutation operator: add or subtract random value (max. 10)-  mutation _ _ seed e = Just $ if seed `mod` 2 == 0-                                  then e +(1 + seed `mod` 10)-                                  else abs (e - (1 + seed `mod` 10))--  -- score: how closely does the given number match the criteria?-  -- NOTE: lower is better-  score e _ = fromIntegral $ s + n-    where-      ds = divisors e-      s = abs $ (-) 96 $ sum' ds-      n = abs $ (-) 8 $ length ds--instance ShowEntity Int where -  showEntity = show- -main = do-        args <- getArgs-        progName <- getProgName-        if length args /= 8 -           then error $ "Usage: <pop. size> <archive size> <max. # generations> " ++-                               "<crossover rate> <mutation rate> " ++-                               "<crossover parameter> <mutation parameter> " ++-                               "<enable checkpointing (bool)>"-           else return ()-        let popSize       = read $ args !! 0-            archiveSize   = read $ args !! 1-            maxGens       = read $ args !! 2-            crossoverRate = read $ args !! 3-            mutationRate  = read $ args !! 4-            crossoverPar  = read $ args !! 5-            mutationPar   = read $ args !! 6-            checkpointing = read $ args !! 7-        let cfg = GAConfig -                    popSize -- population size-                    archiveSize -- archive size (best entities to keep track of)-                    maxGens -- maximum number of generations-                    crossoverRate -- crossover rate (% of new entities generated with crossover)-                    mutationRate -- mutation rate (% of new entities generated with mutation)-                    crossoverPar -- parameter for crossover operator (not used here)-                    mutationPar -- parameter for mutation operator (ratio of replaced letters)-                    checkpointing -- whether or not to use checkpointing--            g = mkStdGen 0 -- random generator--        -- Do the evolution!-        -- two last parameters (pool for generating new entities and extra data to score an entity) are unused in this example-        e <- evolve g cfg () () :: IO Int-        -        putStrLn $ "best entity: " ++ (show e)

@@ -0,0 +1,7 @@+all: example1 example2 example3++%: %.hs+	ghc --make -Wall $@++clean:+	rm -f *.hi *.o example1 example2 example3

@@ -0,0 +1,101 @@+{--+ - Example for GA package+ - see http://hackage.haskell.org/package/GA+ -+ - Evolve the string "Hello World!"+--}++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}++import Control.Monad.Identity (Identity(..))+import Data.Char (chr,ord)+import Data.List (foldl')+import System.Random (mkStdGen, random, randoms)++import GA (Entity(..), GAConfig(..), evolve)++-- efficient sum+sum' :: (Num a) => [a] -> a+sum' = foldl' (+) 0++--+-- GA TYPE CLASS IMPLEMENTATION+--++type Sentence = String+type Target = String+type Letter = Char++instance Entity Sentence Double Target [Letter] Identity where+ +  -- generate a random entity, i.e. a random string+  -- assumption: max. 100 chars, only 'printable' ASCII (first 128)+  genRandom pool seed = return $ take n $ map ((!!) pool) is+    where+        g = mkStdGen seed+        n = (fst $ random g) `mod` 101+        k = length pool+        is = map (flip mod k) $ randoms g++  -- crossover operator: mix (and trim to shortest entity)+  crossover _ _ seed e1 e2 = return $ Just e+    where+      g = mkStdGen seed+      cps = zipWith (\x y -> [x,y]) e1 e2+      picks = map (flip mod 2) $ randoms g+      e = zipWith (!!) cps picks++  -- mutation operator: use next or previous letter randomly and add random characters (max. 9)+  mutation pool p seed e = return $ Just $ (zipWith replace tweaks e) +                                        ++ addChars+    where+      g = mkStdGen seed+      k = round (1 / p) :: Int+      tweaks = randoms g :: [Int]+      replace i x = if (i `mod` k) == 0+        then if even i+          then if x > (minBound :: Char) then pred x else succ x+          else if x < (maxBound :: Char) then succ x else pred x+        else x+      is = map (flip mod $ length pool) $ randoms g+      addChars = take (seed `mod` 10) $ map ((!!) pool) is++  -- score: distance between current string and target+  -- sum of 'distances' between letters, large penalty for additional/short letters+  -- NOTE: lower is better+  score' x e = Just $ fromIntegral $ d + 100*l+    where+      e' = map ord e+      x' = map ord x+      d = sum' $ map abs $ zipWith (-) e' x'+      l = abs $ (length x) - (length e)++  -- whether or not a scored entity is perfect+  isPerfect (_,s) = s == 0.0++main :: IO() +main = do+        let cfg = GAConfig +                    100 -- population size+                    25 -- archive size (best entities to keep track of)+                    300 -- 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 letters)+                    False -- whether or not to use checkpointing+                    False -- don't rescore archive in each generation++            g = mkStdGen 0 -- random generator++            -- pool of characters to pick from+            charsPool = map chr [32..126]+        -- Do the evolution!+        -- Note: if either of the last two arguments is unused, +        --       just use () as a value+            (Identity es) = evolve g cfg charsPool "Hello World!"+            e = snd $ head es :: String+        +        putStrLn $ "best entity: " ++ (show e)

@@ -0,0 +1,95 @@+{--+ - Example for GA package+ - see http://hackage.haskell.org/package/GA+ -+ - Evolve a single integer number to match the following features as closely as possible+ -   * 8 integer divisors+ -   * sum of divisors is 96+--}++{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}++import Control.Monad.Identity (Identity(..))+import Data.List (foldl')+import System.Random (mkStdGen, random)++import GA (Entity(..), GAConfig(..), evolve)++--+-- HELPER FUNCTIONS+--++-- find all divisors of a number+divisors :: Int -> [Int]+divisors n = concat $ map divsFor [1..(sqrt' n)]+  where+    divsFor x = if n `mod` x == 0+                     then [x, n `div` x]+                     else []++-- "integer" square root+sqrt' :: Int -> Int+sqrt' n = floor (sqrt $ fromIntegral n :: Float)++-- efficient sum+sum' :: (Num a) => [a] -> a+sum' = foldl' (+) 0++--+-- GA TYPE CLASS IMPLEMENTATION+--++type Number = Int++instance Entity Number Double () () Identity where+ +  -- generate a random entity, i.e. a random integer value +  genRandom _ seed = return $ (fst $ random $ mkStdGen seed) `mod` 10000++  -- crossover operator: sum, (abs value of) difference or (rounded) mean+  crossover _ _ seed e1 e2 = return $ Just $ case seed `mod` 3 of+                                                  0 -> e1+e2+                                                  1 -> abs (e1-e2)+                                                  2 -> (e1+e2) `div` 2+                                                  _ -> error "crossover: unknown case"++  -- mutation operator: add or subtract random value (max. 10)+  mutation _ _ seed e = return $ Just $ if seed `mod` 2 == 0+                                        then e +(1 + seed `mod` 10)+                                        else abs (e - (1 + seed `mod` 10))++  -- score: how closely does the given number match the criteria?+  -- NOTE: lower is better+  score' _ e = Just $ fromIntegral $ s + n+    where+      ds = divisors e+      s = abs $ (-) 96 $ sum' ds+      n = abs $ (-) 8 $ length ds++  -- whether or not a scored entity is perfect+  isPerfect (_,s) = s == 0.0+++main :: IO() +main = do+        let cfg = GAConfig +                    20 -- population size+                    10 -- 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 letters)+                    False -- whether or not to use checkpointing+                    False -- don't rescore archive in each generation++            g = mkStdGen 0 -- random generator++        -- Do the evolution!+        -- two last parameters (pool for generating new entities and +        -- extra data to score an entity) are unused in this example+            (Identity es) = evolve g cfg () ()+            e = snd $ head es :: Int+        +        putStrLn $ "best entity: " ++ (show e)

@@ -0,0 +1,100 @@+{--+ - Example for GA package+ - see http://hackage.haskell.org/package/GA+ -+ - Evolve the string "Hello World!"+--}++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}++import Data.Char (chr,ord)+import Data.List (foldl')+import System.Random (mkStdGen, random, randoms)++import GA (Entity(..), GAConfig(..), evolveVerbose)++-- efficient sum+sum' :: (Num a) => [a] -> a+sum' = foldl' (+) 0++--+-- GA TYPE CLASS IMPLEMENTATION+--++type Sentence = String+type Target = String+type Letter = Char++instance Entity Sentence Double Target [Letter] IO where+ +  -- generate a random entity, i.e. a random string+  -- assumption: max. 100 chars, only 'printable' ASCII (first 128)+  genRandom pool seed = return $ take n $ map ((!!) pool) is+    where+        g = mkStdGen seed+        n = (fst $ random g) `mod` 101+        k = length pool+        is = map (flip mod k) $ randoms g++  -- crossover operator: mix (and trim to shortest entity)+  crossover _ _ seed e1 e2 = return $ Just e+    where+      g = mkStdGen seed+      cps = zipWith (\x y -> [x,y]) e1 e2+      picks = map (flip mod 2) $ randoms g+      e = zipWith (!!) cps picks++  -- mutation operator: use next or previous letter randomly and add random characters (max. 9)+  mutation pool p seed e = return $ Just $ (zipWith replace tweaks e) +                                         ++ addChars+    where+      g = mkStdGen seed+      k = round (1 / p) :: Int+      tweaks = randoms g :: [Int]+      replace i x = if (i `mod` k) == 0+        then if even i+          then if x > (minBound :: Char) then pred x else succ x+          else if x < (maxBound :: Char) then succ x else pred x+        else x+      is = map (flip mod $ length pool) $ randoms g+      addChars = take (seed `mod` 10) $ map ((!!) pool) is++  -- score: distance between current string and target+  -- sum of 'distances' between letters, large penalty for additional/short letters+  -- NOTE: lower is better+  score x e = return $ Just $ fromIntegral $ d + 100*l+    where+      e' = map ord e+      x' = map ord x+      d = sum' $ map abs $ zipWith (-) e' x'+      l = abs $ (length x) - (length e)++  -- whether or not a scored entity is perfect+  isPerfect (_,s) = s == 0.0+++main :: IO() +main = do+        let cfg = GAConfig +                    100 -- population size+                    25 -- archive size (best entities to keep track of)+                    300 -- 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 letters)+                    False -- whether or not to use checkpointing+                    False -- don't rescore archive in each generation++            g = mkStdGen 0 -- random generator++            -- pool of characters to pick from+            charsPool = map chr [32..126]+        -- Do the evolution!+        -- Note: if either of the last two arguments is unused, just use () as a value+        es <- evolveVerbose g cfg charsPool "Hello World!"+        let e = snd $ head es :: String+        +        putStrLn $ "best entity: " ++ (show e)