diff --git a/Changelog b/Changelog --- a/Changelog +++ b/Changelog @@ -1,13 +1,15 @@ Changelog for GA, a Haskell library for working with genetic algorithms: ------------------------------------------------------------------------ -v0.1 (Aug. 31st 2011): +v1.0 (Sept. 27th 2011): -* initial release -* support for: - - evolution of arbitrary entities (see Entity type class) - - checkpointing between generations with automatic restore from checkpoint -* two toy examples +* reorganize examples +* minor code cleanup +* support for user-defined: + - checking of progress (mustContinue) + - print progress per generation (showProgress) +* bug fixes: + - double pop/archive entities v0.2 (Sept. 19th 2011): @@ -19,3 +21,12 @@ progress to stdout (requires liftIO) * implemented random search * code cleanup and reorganization + +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 --- a/GA.cabal +++ b/GA.cabal @@ -1,5 +1,5 @@ Name: GA -Version: 0.2 +Version: 1.0 Synopsis: Genetic algorithm library License: BSD3 License-file: LICENSE diff --git a/GA.hs b/GA.hs --- a/GA.hs +++ b/GA.hs @@ -1,12 +1,155 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} --- |GA, a Haskell library for working with genetic algoritms +-- | GA, a Haskell library for working with genetic algoritms. -- -- Aug. 2011 - Sept. 2011, by Kenneth Hoste -- --- version: 0.2 -module GA (Entity(..), +-- version: 1.0 +-- +-- Major features: +-- +-- * flexible user-friendly API for working with genetic algorithms +-- +-- * Entity type class to let user define entity definition, scoring, etc. +-- +-- * abstraction over monad, resulting in a powerful yet simple interface +-- +-- * support for scoring entire population at once +-- +-- * support for checkpointing each generation, +-- and restoring from last checkpoint +-- +-- * convergence detection, as defined by user +-- +-- * also available: random searching, user-defined progress output +-- +-- * illustrative toy examples included +-- +-- Hello world example: +-- +-- > -- 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 System.IO(IOMode(..), hClose, hGetContents, openFile) +-- > +-- >import GA (Entity(..), GAConfig(..), +-- > evolveVerbose, randomSearch) +-- > +-- >-- 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 fn e = do +-- > h <- openFile fn ReadMode +-- > x <- hGetContents h +-- > length x `seq` hClose h +-- > let e' = map ord e +-- > x' = map ord x +-- > d = sum' $ map abs $ zipWith (-) e' x' +-- > l = abs $ (length x) - (length e) +-- > return $ Just $ fromIntegral $ d + 100*l +-- > +-- > -- 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: printable ASCII characters +-- > charsPool = map chr [32..126] +-- > +-- > fileName = "goal.txt" +-- > +-- > -- write string to file, pretend that we don't know what it is +-- > -- goal is to let genetic algorithm evolve this string +-- > writeFile fileName "Hello World!" +-- > +-- > -- Do the evolution! +-- > -- Note: if either of the last two arguments is unused, just use () as a value +-- > es <- evolveVerbose g cfg charsPool fileName +-- > let e = snd $ head es :: String +-- > +-- > putStrLn $ "best entity (GA): " ++ (show e) +-- > +-- > -- Compare with random search with large budget +-- > -- 100k random entities, equivalent to 1000 generations of GA +-- > es' <- randomSearch g 100000 charsPool fileName +-- > let e' = snd $ head es' :: String +-- > +-- > putStrLn $ "best entity (random search): " ++ (show e') +-- + +module GA (Entity(..), + ScoredEntity, + Archive, GAConfig(..), evolve, evolveVerbose, @@ -14,7 +157,7 @@ import Control.Monad (zipWithM) import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.List (sortBy, nub) +import Data.List (sortBy, nub, nubBy) import Data.Maybe (catMaybes, fromJust, isJust) import Data.Ord (comparing) import System.Directory (createDirectoryIfMissing, doesFileExist) @@ -36,6 +179,18 @@ in (head xs:hs, ts) | otherwise = ([],xs) +-- |A scored entity. +type ScoredEntity e s = (Maybe s, e) + +-- |Archive of scored entities. +type Archive e s = [ScoredEntity e s] + +-- |Scored generation (population and archive). +type Generation e s = ([e], Archive e s) + +-- |Universe of entities. +type Universe e = [e] + -- |Configuration for genetic algorithm. data GAConfig = GAConfig { -- |population size @@ -73,10 +228,12 @@ -- -- * monad to operate in (m) -- --- Minimal implementation includes genRandom, crossover, mutation, --- and either score', score or scorePop. +-- Minimal implementation should include 'genRandom', 'crossover', 'mutation', +-- and either 'score'', 'score' or 'scorePop'. -- -class (Eq e, Read e, Show e, +-- The 'isPerfect', 'showGeneration' and 'hasConverged' functions are optional. +-- +class (Eq e, Ord e, Read e, Show e, Ord s, Read s, Show s, Monad m) => Entity e s d p m @@ -138,15 +295,27 @@ -> 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]) + -- |Show progress made in this generation. + -- + -- Default implementation shows best entity. + showGeneration :: Int -- ^ generation index + -> Generation e s -- ^ generation (population and archive) + -> String -- ^ string describing this generation + showGeneration gi (_,archive) = "best entity (gen. " + ++ show gi ++ "): " ++ (show e) + ++ " [fitness: " ++ show fitness ++ "]" + where + (Just fitness, e) = head archive --- |Universe of entities. -type Universe e = [e] + -- |Determine whether evolution should continue or not, + -- based on lists of archive fitnesses of previous generations. + -- + -- Note: most recent archives are at the head of the list. + -- + -- Default implementation always returns False. + hasConverged :: [Archive e s] -- ^ archives so far + -> Bool -- ^ whether or not convergence was detected + hasConverged _ = False -- |Initialize: generate initial population. initPop :: (Entity e s d p m) => p -- ^ pool for generating random entities @@ -265,13 +434,16 @@ let -- new population: crossovered + mutated entities newPop = crossEnts ++ mutEnts -- new archive: best entities so far - newArchive = take an $ nub $ sortBy (comparing fst) $ combo + newArchive = take an + $ nubBy (\x y -> comparing snd x y == EQ) + $ sortBy (comparing fst) combo newUniverse = nub $ universe ++ pop return (newUniverse, (newPop,newArchive)) -- |Evolution: evaluate generation and continue. evolution :: (Entity e s d p m) => GAConfig -- ^ configuration for GA -> Universe e -- ^ known entities + -> [Archive e s] -- ^ previous archives -> Generation e s -- ^ current generation -> ( Universe e -> Generation e s @@ -280,14 +452,15 @@ ) -- ^ 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 +evolution cfg universe pastArchives gen step ((_,seed):gss) = do (universe',nextGen) <- step universe gen seed let (Just fitness, e) = (head $ snd nextGen) - if isPerfect (e,fitness) + newArchive = snd nextGen + if hasConverged pastArchives || isPerfect (e,fitness) then return nextGen - else evolution cfg universe' nextGen step gss + else evolution cfg universe' (newArchive:pastArchives) nextGen step gss -- no more gen. indices/seeds => quit -evolution _ _ gen _ [] = return gen +evolution _ _ _ gen _ [] = return gen -- |Generate file name for checkpoint. chkptFileName :: GAConfig -- ^ configuration for generation algorithm @@ -307,10 +480,10 @@ -- |Checkpoint a single generation. 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 + -> 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) @@ -320,9 +493,10 @@ writeFile fn txt -- |Evolution: evaluate generation, (maybe) checkpoint, continue. -evolutionChkpt :: (Entity e s d p m, +evolutionVerbose :: (Entity e s d p m, MonadIO m) => GAConfig -- ^ configuration for GA -> Universe e -- ^ universe of known entities + -> [Archive e s] -- ^ previous archives -> Generation e s -- ^ current generation -> ( Universe e -> Generation e s @@ -331,27 +505,29 @@ ) -- ^ 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 +evolutionVerbose cfg universe pastArchives 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 ++ "]" + liftIO $ putStrLn $ showGeneration gi newPa -- check for perfect entity - if isPerfect (e, fitness) + if hasConverged pastArchives || isPerfect (e,fitness) then do - liftIO $ putStrLn $ "perfect entity found, " - ++ "finished after " ++ show gi - ++ " generations!" + liftIO $ putStrLn $ if isPerfect (e,fitness) + then "perfect entity found, " + ++ "finished after " ++ show gi + ++ " generations!" + else "no progress for 3 generations, " + ++ "stopping after " ++ show gi + ++ " generations!" return newPa - else evolutionChkpt cfg universe' newPa step gss + else evolutionVerbose cfg universe' (archive':pastArchives) newPa step gss -- no more gen. indices/seeds => quit -evolutionChkpt _ _ gen _ [] = do +evolutionVerbose _ _ _ gen _ [] = do liftIO $ putStrLn $ "done evolving!" return gen @@ -387,7 +563,7 @@ -> GAConfig -- ^ configuration for GA -> p -- ^ random entities pool -> d -- ^ dataset required to score entities - -> m [ScoredEntity e s] -- ^ best entities + -> m (Archive e s) -- ^ best entities evolve g cfg pool dataset = do -- initialize (pop, cCnt, mCnt, aSize, @@ -398,7 +574,7 @@ -- do the evolution let rescoreArchive = getRescoreArchive cfg (_,resArchive) <- evolution - cfg [] (pop,[]) + cfg [] [] (pop,[]) (evolutionStep pool dataset (cCnt,mCnt,aSize) (crossPar,mutPar) @@ -425,15 +601,17 @@ fn = chkptFileName cfg (gi,seed) restoreFromChkpt _ [] = return Nothing --- |Do the evolution (supports checkpointing). +-- |Do the evolution, verbosely. -- --- Requires support for liftIO in monad used. -evolveVerbose :: (Entity e s d p m, - MonadIO m) => StdGen -- ^ random generator +-- Prints progress to stdout, and supports checkpointing. +-- +-- Note: 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 + -> m (Archive e s) -- ^ best entities evolveVerbose g cfg pool dataset = do -- initialize (pop, cCnt, mCnt, aSize, @@ -452,8 +630,8 @@ genSeeds' = filter ((>gi) . fst) genSeeds rescoreArchive = getRescoreArchive cfg -- do the evolution - (_,resArchive) <- evolutionChkpt - cfg [] gen + (_,resArchive) <- evolutionVerbose + cfg [] [] gen (evolutionStep pool dataset (cCnt,mCnt,aSize) (crossPar,mutPar) @@ -462,16 +640,18 @@ -- return best entity return resArchive --- |Random search. +-- |Random searching. -- -- 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 + -> m (Archive e s) -- ^ scored entities (sorted) 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 + return $ nubBy (\x y -> comparing snd x y == EQ) + $ sortBy (comparing fst) + $ zip scores es 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.2, Sept. 2011, written by Kenneth Hoste (kenneth.hoste@gmail.com) +version 1.0, Sept. 2011, written by Kenneth Hoste (kenneth.hoste@gmail.com) see http://hackage.haskell.org/package/GA * DESCRIPTION @@ -30,29 +30,35 @@ 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!"). - -The second example (see example2.hs) evolves an integer number that has +The first example (see theNumber.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. +one by one starting from e.g. 8), but 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. +We use the score' function in this example, because the scoring itself +doesn't operate in a monad. -The third example reimplements the first example, but inside the IO monad. +A second example evolves the string "Hello World!". The string that the +genetic algorithm should generate is supplied by the user in this example, +and is printed to a file where the GA will read it from during scoring. +This is of course not representative of a real world problem that could +be solved using genetic algorithms, but again, it does serve well as a toy +example. + +The code in hello.hs illustrates how you can define the "genRandom", +"crossover", "mutation" and "score" functions that are required to run +the genetic algorithm using the 'evolveVerbose' function. It also shows +an example of defining the "isPerfect" function to determine whether a +perfect entity was observed (and thus evolution can stop). + +This example demonstrates 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 name of the file where the target string was written to). + +It also shows how the GA module support operating in a monad, in this case +the IO monad, and illustrates the usefulness of the 'randomSearch' function. diff --git a/examples/Makefile b/examples/Makefile --- a/examples/Makefile +++ b/examples/Makefile @@ -1,7 +1,7 @@ -all: example1 example2 example3 +all: theNumber hello %: %.hs ghc --make -Wall $@ clean: - rm -f *.hi *.o example1 example2 example3 + rm -f *.hi *.o theNumber hello diff --git a/examples/example1.hs b/examples/example1.hs deleted file mode 100644 --- a/examples/example1.hs +++ /dev/null @@ -1,101 +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 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 deleted file mode 100644 --- a/examples/example2.hs +++ /dev/null @@ -1,95 +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 #-} -{-# 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 deleted file mode 100644 --- a/examples/example3.hs +++ /dev/null @@ -1,100 +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 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) diff --git a/examples/hello.hs b/examples/hello.hs new file mode 100644 --- /dev/null +++ b/examples/hello.hs @@ -0,0 +1,119 @@ +{-- + - 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 System.IO(IOMode(..), hClose, hGetContents, openFile) + +import GA (Entity(..), GAConfig(..), + evolveVerbose, randomSearch) + +-- 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 fn e = do + h <- openFile fn ReadMode + x <- hGetContents h + length x `seq` hClose h + let e' = map ord e + x' = map ord x + d = sum' $ map abs $ zipWith (-) e' x' + l = abs $ (length x) - (length e) + return $ Just $ fromIntegral $ d + 100*l + + -- 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: printable ASCII characters + charsPool = map chr [32..126] + + fileName = "goal.txt" + + -- write string to file, pretend that we don't know what it is + -- goal is to let genetic algorithm evolve this string + writeFile fileName "Hello World!" + + -- Do the evolution! + -- Note: if either of the last two arguments is unused, just use () as a value + es <- evolveVerbose g cfg charsPool fileName + let e = snd $ head es :: String + + putStrLn $ "best entity (GA): " ++ (show e) + + -- Compare with random search with large budget + -- 100k random entities, equivalent to 1000 generations of GA + es' <- randomSearch g 100000 charsPool fileName + let e' = snd $ head es' :: String + + putStrLn $ "best entity (random search): " ++ (show e') diff --git a/examples/theNumber.hs b/examples/theNumber.hs new file mode 100644 --- /dev/null +++ b/examples/theNumber.hs @@ -0,0 +1,92 @@ +{-- + - 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 + + +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)