diff --git a/Changelog b/Changelog new file mode 100644 --- /dev/null +++ b/Changelog @@ -0,0 +1,11 @@ +Changelog for GA, a Haskell library for working with genetic algorithms: +------------------------------------------------------------------------ + +v0.1 (Aug. 31st 2011): + +* initial release +* support for: + - evolution of arbitrary entities (see Entity type class) + - checkpointing between generations with automatic restore from checkpoint +* two toy examples + diff --git a/GA.cabal b/GA.cabal new file mode 100644 --- /dev/null +++ b/GA.cabal @@ -0,0 +1,37 @@ +Name: GA +Version: 0.1 +Synopsis: Genetic algorithm library +License: BSD3 +License-file: LICENSE +Author: Kenneth Hoste +Maintainer: kenneth.hoste@gmail.com +Copyright: (c) 2011 Kenneth Hoste +Homepage: http://boegel.kejo.be +Bug-reports: mailto:kenneth.hoste@gmail.com +Category: AI, Algorithms, Optimisation +Stability: Experimental +Build-type: Simple +Cabal-version: >= 1.6 +Description: + This package provides a framework for working with genetic + algorithms. A genetic algorithm is an evolutionary technique, + inspired by biological evolution, to evolve entities that perform + as good as possible in terms of a predefined criterion (the scoring + function). Note: lower scores are assumed to indicate better entities. + The GA module provides a type class for defining entities and the + functions that are required by the genetic algorithm. + Checkpointing in between generations is available, as is automatic + restoring from the last available checkpoint. + +Extra-source-files: example1.hs, example2.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 + +source-repository head + type: git + location: git://github.com/boegel/GA.git diff --git a/GA.hs b/GA.hs new file mode 100644 --- /dev/null +++ b/GA.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- |GA, a Haskell library for working with genetic algoritms +-- +-- Aug. 2011, by Kenneth Hoste +-- +-- version: 0.1 +module GA (Entity(..), + GAConfig(..), + ShowEntity(..), + evolve) where + +import Data.List (intersperse, sortBy, nub) +import Data.Maybe (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 + +-- |Currify a list of elements into tuples. +currify :: [a] -> [(a,a)] +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 n 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 + } + +-- |Type class for entities that represent a candidate solution. +-- +-- Three parameters: +-- +-- * data structure representing an entity (a) +-- +-- * data used to score an entity, e.g. a list of numbers (b) +-- +-- * some kind of pool used to generate random entities, e.g. a Hoogle database (c) +-- +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 + +-- |A possibly scored entity. +type ScoredEntity a = (Maybe Double, a) + +-- |Scored generation (population and archive). +type ScoredGen a = ([ScoredEntity a],[ScoredEntity a]) + +-- |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 + +-- |Show a scored entity. +showScoredEntity :: ShowEntity a => ScoredEntity a -> String +showScoredEntity (score,e) = "(" ++ show score ++ ", " ++ showEntity e ++ ")" + +-- |Show a list of scored entities. +showScoredEntities :: ShowEntity a => [ScoredEntity a] -> String +showScoredEntities es = ("["++) . (++"]") . concat . intersperse "," $ map showScoredEntity es + +-- |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 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) + +-- |Binary tournament selection operator. +tournamentSelection :: [ScoredEntity a] -> Int -> a +tournamentSelection xs seed = if s1 < s2 then x1 else x2 + where + len = length xs + g = mkStdGen seed + is = take 2 $ map (flip mod len) $ randoms g + [(s1,x1),(s2,x2)] = map ((!!) xs) is + +-- |Function to perform a single evolution step: +-- +-- * score all entities +-- +-- * combine with best entities so far +-- +-- * 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 + -- 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 + +-- |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" + +-- |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 + where + fn = chkptFileName cfg (gi,seed) +restoreFromCheckpoint cfg [] = return Nothing + +-- |Checkpoint a single generation. +checkpointGen :: (Entity a b c) => GAConfig -> Int -> Int -> ScoredGen a -> IO() +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 + +-- |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 +-- no more gen. indices/seeds => quit +evolution cfg (pop,archive) _ [] = do + putStrLn $ "done evolving!" + return (pop,archive) + +-- |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] + + -- initial population + let (rs',pop) = initPop src (popSize cfg) rs + + 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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,7 @@ +all: example1 example2 + +%: GA.hs %.hs + ghc --make $@ + +clean: + rm -f *.hi *.o example1 example2 diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,63 @@ +GA, a Haskell library for working with genetic algorithms +--------------------------------------------------------- + +version 0.1, Aug. 2011, written by Kenneth Hoste (kenneth.hsote@gmail.com) +see http://hackage.haskell.org/package/GA + +* DESCRIPTION + +This package provides a framework for working with genetic +algorithms. A genetic algorithm is an evolutionary technique, +inspired by biological evolution, to evolve entities that perform +as good as possible in terms of a predefined criterion (the scoring +function). +Note: lower scores are assumed to indicate better entities. + +The GA module provides a type class for defining entities and the +functions that are required by the genetic algorithm. + +Checkpointing in between generations is available, as is automatic +restoring from the last available checkpoint. + +* BUILDING AND USING + +Building the GA module and supplied examples can be done by running 'make'. + +Using the GA module should be clear after studying the examples. + +* EXAMPLES + +This release includes two toy examples that show how to use the GA module. + +A first example evolves the string "Hello World!". The string that the +genetic algorithm should generate is supplied by the user in this example, +which is of course not representative of a real world problem that could +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 genetic algorithm using the 'evolve' function. + +It also shows the use of a 'pool' that can be used to generate random +entities (a list of characters, in this particular case), and user-supplied +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 +such an integer (it would be easier/faster to just go over integer values +one by one starting from e.g. 8), but again, it serves well as a toy example. + +This example shows how the pool and score data do not have to be used; it +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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example1.hs b/example1.hs new file mode 100644 --- /dev/null +++ b/example1.hs @@ -0,0 +1,107 @@ +{-- + - 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 new file mode 100644 --- /dev/null +++ b/example2.hs @@ -0,0 +1,102 @@ +{-- + - 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)