diff --git a/Changelog b/Changelog --- a/Changelog +++ b/Changelog @@ -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 diff --git a/GA.cabal b/GA.cabal --- a/GA.cabal +++ b/GA.cabal @@ -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 diff --git a/GA.hs b/GA.hs --- a/GA.hs +++ b/GA.hs @@ -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 diff --git a/Makefile b/Makefile deleted file mode 100644 --- a/Makefile +++ /dev/null @@ -1,7 +0,0 @@ -all: example1 example2 - -%: GA.hs %.hs - ghc --make $@ - -clean: - rm -f *.hi *.o example1 example2 diff --git a/README b/README --- a/README +++ b/README @@ -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. diff --git a/example1.hs b/example1.hs deleted file mode 100644 --- a/example1.hs +++ /dev/null @@ -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: " ++ - " " ++ - " " ++ - "" - 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) diff --git a/example2.hs b/example2.hs deleted file mode 100644 --- a/example2.hs +++ /dev/null @@ -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: " ++ - " " ++ - " " ++ - "" - 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) diff --git a/examples/Makefile b/examples/Makefile new file mode 100644 --- /dev/null +++ b/examples/Makefile @@ -0,0 +1,7 @@ +all: example1 example2 example3 + +%: %.hs + ghc --make -Wall $@ + +clean: + rm -f *.hi *.o example1 example2 example3 diff --git a/examples/example1.hs b/examples/example1.hs new file mode 100644 --- /dev/null +++ b/examples/example1.hs @@ -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) diff --git a/examples/example2.hs b/examples/example2.hs new file mode 100644 --- /dev/null +++ b/examples/example2.hs @@ -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) diff --git a/examples/example3.hs b/examples/example3.hs new file mode 100644 --- /dev/null +++ b/examples/example3.hs @@ -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)