Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 658 lines (621 sloc) 26.76 kb
079879b @boegel initial commit: GA v0.1, ready to release on Hackage
authored
1 {-# LANGUAGE FunctionalDependencies #-}
2 {-# LANGUAGE MultiParamTypeClasses #-}
3
d80ab67 @boegel version bump (v1.0), fix documentation, slight API changes, fix bug i…
authored
4 -- | GA, a Haskell library for working with genetic algoritms.
5945e9b @boegel fix Cabal file, adjust documentation for Haddock, define ScoredGen ty…
authored
5 --
3c4b161 @boegel version bump
authored
6 -- Aug. 2011 - Sept. 2011, by Kenneth Hoste
5945e9b @boegel fix Cabal file, adjust documentation for Haddock, define ScoredGen ty…
authored
7 --
d80ab67 @boegel version bump (v1.0), fix documentation, slight API changes, fix bug i…
authored
8 -- version: 1.0
9 --
10 -- Major features:
11 --
12 -- * flexible user-friendly API for working with genetic algorithms
13 --
14 -- * Entity type class to let user define entity definition, scoring, etc.
15 --
16 -- * abstraction over monad, resulting in a powerful yet simple interface
17 --
18 -- * support for scoring entire population at once
19 --
20 -- * support for checkpointing each generation,
21 -- and restoring from last checkpoint
22 --
23 -- * convergence detection, as defined by user
24 --
25 -- * also available: random searching, user-defined progress output
26 --
27 -- * illustrative toy examples included
28 --
29 -- Hello world example:
30 --
31 -- > -- Example for GA package
32 -- > -- see http://hackage.haskell.org/package/GA
33 -- > --
34 -- > -- Evolve the string "Hello World!"
35 -- >
36 -- >{-# LANGUAGE FlexibleInstances #-}
37 -- >{-# LANGUAGE MultiParamTypeClasses #-}
38 -- >{-# LANGUAGE TypeSynonymInstances #-}
39 -- >
40 -- >import Data.Char (chr,ord)
41 -- >import Data.List (foldl')
42 -- >import System.Random (mkStdGen, random, randoms)
43 -- >import System.IO(IOMode(..), hClose, hGetContents, openFile)
44 -- >
45 -- >import GA (Entity(..), GAConfig(..),
46 -- > evolveVerbose, randomSearch)
47 -- >
48 -- >-- efficient sum
49 -- >sum' :: (Num a) => [a] -> a
50 -- >sum' = foldl' (+) 0
51 -- >
52 -- >--
53 -- >-- GA TYPE CLASS IMPLEMENTATION
54 -- >--
55 -- >
56 -- >type Sentence = String
57 -- >type Target = String
58 -- >type Letter = Char
59 -- >
60 -- >instance Entity Sentence Double Target [Letter] IO where
61 -- >
62 -- > -- generate a random entity, i.e. a random string
63 -- > -- assumption: max. 100 chars, only 'printable' ASCII (first 128)
64 -- > genRandom pool seed = return $ take n $ map ((!!) pool) is
65 -- > where
66 -- > g = mkStdGen seed
67 -- > n = (fst $ random g) `mod` 101
68 -- > k = length pool
69 -- > is = map (flip mod k) $ randoms g
70 -- >
71 -- > -- crossover operator: mix (and trim to shortest entity)
72 -- > crossover _ _ seed e1 e2 = return $ Just e
73 -- > where
74 -- > g = mkStdGen seed
75 -- > cps = zipWith (\x y -> [x,y]) e1 e2
76 -- > picks = map (flip mod 2) $ randoms g
77 -- > e = zipWith (!!) cps picks
78 -- >
79 -- > -- mutation operator: use next or previous letter randomly and add random characters (max. 9)
80 -- > mutation pool p seed e = return $ Just $ (zipWith replace tweaks e)
81 -- > ++ addChars
82 -- > where
83 -- > g = mkStdGen seed
84 -- > k = round (1 / p) :: Int
85 -- > tweaks = randoms g :: [Int]
86 -- > replace i x = if (i `mod` k) == 0
87 -- > then if even i
88 -- > then if x > (minBound :: Char) then pred x else succ x
89 -- > else if x < (maxBound :: Char) then succ x else pred x
90 -- > else x
91 -- > is = map (flip mod $ length pool) $ randoms g
92 -- > addChars = take (seed `mod` 10) $ map ((!!) pool) is
93 -- >
94 -- > -- score: distance between current string and target
95 -- > -- sum of 'distances' between letters, large penalty for additional/short letters
96 -- > -- NOTE: lower is better
97 -- > score fn e = do
98 -- > h <- openFile fn ReadMode
99 -- > x <- hGetContents h
100 -- > length x `seq` hClose h
101 -- > let e' = map ord e
102 -- > x' = map ord x
103 -- > d = sum' $ map abs $ zipWith (-) e' x'
104 -- > l = abs $ (length x) - (length e)
105 -- > return $ Just $ fromIntegral $ d + 100*l
106 -- >
107 -- > -- whether or not a scored entity is perfect
108 -- > isPerfect (_,s) = s == 0.0
109 -- >
110 -- >
111 -- >main :: IO()
112 -- >main = do
113 -- > let cfg = GAConfig
114 -- > 100 -- population size
115 -- > 25 -- archive size (best entities to keep track of)
116 -- > 300 -- maximum number of generations
117 -- > 0.8 -- crossover rate (% of entities by crossover)
118 -- > 0.2 -- mutation rate (% of entities by mutation)
119 -- > 0.0 -- parameter for crossover (not used here)
120 -- > 0.2 -- parameter for mutation (% of replaced letters)
121 -- > False -- whether or not to use checkpointing
122 -- > False -- don't rescore archive in each generation
123 -- >
124 -- > g = mkStdGen 0 -- random generator
125 -- >
126 -- > -- pool of characters to pick from: printable ASCII characters
127 -- > charsPool = map chr [32..126]
128 -- >
129 -- > fileName = "goal.txt"
130 -- >
131 -- > -- write string to file, pretend that we don't know what it is
132 -- > -- goal is to let genetic algorithm evolve this string
133 -- > writeFile fileName "Hello World!"
134 -- >
135 -- > -- Do the evolution!
136 -- > -- Note: if either of the last two arguments is unused, just use () as a value
137 -- > es <- evolveVerbose g cfg charsPool fileName
138 -- > let e = snd $ head es :: String
139 -- >
140 -- > putStrLn $ "best entity (GA): " ++ (show e)
141 -- >
142 -- > -- Compare with random search with large budget
143 -- > -- 100k random entities, equivalent to 1000 generations of GA
144 -- > es' <- randomSearch g 100000 charsPool fileName
145 -- > let e' = snd $ head es' :: String
146 -- >
147 -- > putStrLn $ "best entity (random search): " ++ (show e')
148 --
149
150 module GA (Entity(..),
151 ScoredEntity,
152 Archive,
5945e9b @boegel fix Cabal file, adjust documentation for Haddock, define ScoredGen ty…
authored
153 GAConfig(..),
088bb64 @boegel introduce evolveChkpt, which required liftIO and allows checkpointing…
authored
154 evolve,
ba290b1 @boegel implement random search, remove FIXMEs
authored
155 evolveVerbose,
156 randomSearch) where
079879b @boegel initial commit: GA v0.1, ready to release on Hackage
authored
157
64852b2 @boegel make return values of crossover/mutation operators monadic
authored
158 import Control.Monad (zipWithM)
088bb64 @boegel introduce evolveChkpt, which required liftIO and allows checkpointing…
authored
159 import Control.Monad.IO.Class (MonadIO, liftIO)
420d2ec @boegel add support for letting user decide whether evolution should continue…
authored
160 import Data.List (sortBy, nub, nubBy)
2773d86 @boegel make score and evolve functions more general (abstract over a random …
authored
161 import Data.Maybe (catMaybes, fromJust, isJust)
079879b @boegel initial commit: GA v0.1, ready to release on Hackage
authored
162 import Data.Ord (comparing)
163 import System.Directory (createDirectoryIfMissing, doesFileExist)
ba290b1 @boegel implement random search, remove FIXMEs
authored
164 import System.Random (StdGen, mkStdGen, random, randoms)
079879b @boegel initial commit: GA v0.1, ready to release on Hackage
authored
165
5945e9b @boegel fix Cabal file, adjust documentation for Haddock, define ScoredGen ty…
authored
166 -- |Currify a list of elements into tuples.
655ee46 @boegel make genRandom return a monadic value, cosmetic changes (mostly docum…
authored
167 currify :: [a] -- ^ list
168 -> [(a,a)] -- ^ list of tuples
079879b @boegel initial commit: GA v0.1, ready to release on Hackage
authored
169 currify (x:y:xs) = (x,y):currify xs
170 currify [] = []
171 currify [_] = error "(currify) ERROR: only one element left?!?"
172
5945e9b @boegel fix Cabal file, adjust documentation for Haddock, define ScoredGen ty…
authored
173 -- |Take and drop elements of a list in a single pass.
655ee46 @boegel make genRandom return a monadic value, cosmetic changes (mostly docum…
authored
174 takeAndDrop :: Int -- ^ number of elements to take/drop
175 -> [a] -- ^ list
176 -> ([a],[a]) -- ^ result: taken list element and rest of list
079879b @boegel initial commit: GA v0.1, ready to release on Hackage
authored
177 takeAndDrop n xs
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
178 | n > 0 = let (hs,ts) = takeAndDrop (n-1) (tail xs)
179 in (head xs:hs, ts)
180 | otherwise = ([],xs)
079879b @boegel initial commit: GA v0.1, ready to release on Hackage
authored
181
d80ab67 @boegel version bump (v1.0), fix documentation, slight API changes, fix bug i…
authored
182 -- |A scored entity.
183 type ScoredEntity e s = (Maybe s, e)
184
185 -- |Archive of scored entities.
186 type Archive e s = [ScoredEntity e s]
187
188 -- |Scored generation (population and archive).
189 type Generation e s = ([e], Archive e s)
190
191 -- |Universe of entities.
192 type Universe e = [e]
193
5945e9b @boegel fix Cabal file, adjust documentation for Haddock, define ScoredGen ty…
authored
194 -- |Configuration for genetic algorithm.
079879b @boegel initial commit: GA v0.1, ready to release on Hackage
authored
195 data GAConfig = GAConfig {
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
196 -- |population size
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
197 getPopSize :: Int,
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
198 -- |size of archive (best entities so far)
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
199 getArchiveSize :: Int,
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
200 -- |maximum number of generations to evolve
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
201 getMaxGenerations :: Int,
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
202 -- |fraction of entities generated by crossover (tip: >= 0.80)
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
203 getCrossoverRate :: Float,
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
204 -- |fraction of entities generated by mutation (tip: <= 0.20)
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
205 getMutationRate :: Float,
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
206 -- |parameter for crossover (semantics depend on crossover operator)
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
207 getCrossoverParam :: Float,
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
208 -- |parameter for mutation (semantics depend on mutation operator)
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
209 getMutationParam :: Float,
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
210 -- |enable/disable built-in checkpointing mechanism
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
211 getWithCheckpointing :: Bool,
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
212 -- |rescore archive in each generation?
213 getRescoreArchive :: Bool
079879b @boegel initial commit: GA v0.1, ready to release on Hackage
authored
214 }
215
5945e9b @boegel fix Cabal file, adjust documentation for Haddock, define ScoredGen ty…
authored
216 -- |Type class for entities that represent a candidate solution.
217 --
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
218 -- Five parameters:
5945e9b @boegel fix Cabal file, adjust documentation for Haddock, define ScoredGen ty…
authored
219 --
41849c7 @boegel pass archive to scorePop
authored
220 -- * data structure representing an entity (e)
5945e9b @boegel fix Cabal file, adjust documentation for Haddock, define ScoredGen ty…
authored
221 --
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
222 -- * score type (s), e.g. Double
223 --
41849c7 @boegel pass archive to scorePop
authored
224 -- * data used to score an entity, e.g. a list of numbers (d)
5945e9b @boegel fix Cabal file, adjust documentation for Haddock, define ScoredGen ty…
authored
225 --
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
226 -- * some kind of pool used to generate random entities,
227 -- e.g. a Hoogle database (p)
41849c7 @boegel pass archive to scorePop
authored
228 --
229 -- * monad to operate in (m)
5945e9b @boegel fix Cabal file, adjust documentation for Haddock, define ScoredGen ty…
authored
230 --
d80ab67 @boegel version bump (v1.0), fix documentation, slight API changes, fix bug i…
authored
231 -- Minimal implementation should include 'genRandom', 'crossover', 'mutation',
232 -- and either 'score'', 'score' or 'scorePop'.
233 --
234 -- The 'isPerfect', 'showGeneration' and 'hasConverged' functions are optional.
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
235 --
420d2ec @boegel add support for letting user decide whether evolution should continue…
authored
236 class (Eq e, Ord e, Read e, Show e,
6b43bd9 @boegel abstract score type (doesn't typecheck yet)
authored
237 Ord s, Read s, Show s,
238 Monad m)
239 => Entity e s d p m
240 | e -> s, e -> d, e -> p, e -> m where
241
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
242 -- |Generate a random entity. [required]
41849c7 @boegel pass archive to scorePop
authored
243 genRandom :: p -- ^ pool for generating random entities
244 -> Int -- ^ random seed
245 -> m e -- ^ random entity
246
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
247 -- |Crossover operator: combine two entities into a new entity. [required]
41849c7 @boegel pass archive to scorePop
authored
248 crossover :: p -- ^ entity pool
249 -> Float -- ^ crossover parameter
250 -> Int -- ^ random seed
251 -> e -- ^ first entity
252 -> e -- ^ second entity
253 -> m (Maybe e) -- ^ entity resulting from crossover
254
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
255 -- |Mutation operator: mutate an entity into a new entity. [required]
41849c7 @boegel pass archive to scorePop
authored
256 mutation :: p -- ^ entity pool
257 -> Float -- ^ mutation parameter
258 -> Int -- ^ random seed
259 -> e -- ^ entity to mutate
260 -> m (Maybe e) -- ^ mutated entity
261
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
262 -- |Score an entity (lower is better), pure version. [optional]
263 --
264 -- Overridden if score or scorePop are implemented.
41849c7 @boegel pass archive to scorePop
authored
265 score' :: d -- ^ dataset for scoring entities
266 -> e -- ^ entity to score
6b43bd9 @boegel abstract score type (doesn't typecheck yet)
authored
267 -> (Maybe s) -- ^ entity score
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
268 score' _ _ = error $ "(GA) score' is not defined, "
269 ++ "nor is score or scorePop!"
41849c7 @boegel pass archive to scorePop
authored
270
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
271 -- |Score an entity (lower is better), monadic version. [optional]
41849c7 @boegel pass archive to scorePop
authored
272 --
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
273 -- Default implementation hoists score' into monad,
274 -- overriden if scorePop is implemented.
41849c7 @boegel pass archive to scorePop
authored
275 score :: d -- ^ dataset for scoring entities
276 -> e -- ^ entity to score
6b43bd9 @boegel abstract score type (doesn't typecheck yet)
authored
277 -> m (Maybe s) -- ^ entity score
3f6ef27 @boegel introduce scorePop to score an entire population at once,
authored
278 score d e = do
279 return $ score' d e
41849c7 @boegel pass archive to scorePop
authored
280
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
281 -- |Score an entire population of entites. [optional]
41849c7 @boegel pass archive to scorePop
authored
282 --
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
283 -- Default implementation returns Nothing,
284 -- and triggers indivual of entities.
41849c7 @boegel pass archive to scorePop
authored
285 scorePop :: d -- ^ dataset to score entities
ce59f10 @boegel pass universe of all known entities to scorePop
authored
286 -> [e] -- ^ universe of known entities
41849c7 @boegel pass archive to scorePop
authored
287 -> [e] -- ^ population of entities to score
dd1a378 @boegel changed return type of scorePop to "m (Maybe [Maybe s])"
authored
288 -> m (Maybe [Maybe s]) -- ^ scores for population entities
289 scorePop _ _ _ = return Nothing
079879b @boegel initial commit: GA v0.1, ready to release on Hackage
authored
290
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
291 -- |Determines whether a score indicates a perfect entity. [optional]
292 --
293 -- Default implementation returns always False.
25a02ca @boegel fix compilation issues after generalizing score type, fix examples
authored
294 isPerfect :: (e,s) -- ^ scored entity
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
295 -> Bool -- ^ whether or not scored entity is perfect
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
296 isPerfect _ = False
6b43bd9 @boegel abstract score type (doesn't typecheck yet)
authored
297
f7d74b4 @boegel adjust comment for showProgress (show, not print)
authored
298 -- |Show progress made in this generation.
c42b82a @boegel make printing of progress per generation user-definable
authored
299 --
300 -- Default implementation shows best entity.
d80ab67 @boegel version bump (v1.0), fix documentation, slight API changes, fix bug i…
authored
301 showGeneration :: Int -- ^ generation index
302 -> Generation e s -- ^ generation (population and archive)
303 -> String -- ^ string describing this generation
304 showGeneration gi (_,archive) = "best entity (gen. "
c42b82a @boegel make printing of progress per generation user-definable
authored
305 ++ show gi ++ "): " ++ (show e)
306 ++ " [fitness: " ++ show fitness ++ "]"
307 where
308 (Just fitness, e) = head archive
6b43bd9 @boegel abstract score type (doesn't typecheck yet)
authored
309
420d2ec @boegel add support for letting user decide whether evolution should continue…
authored
310 -- |Determine whether evolution should continue or not,
311 -- based on lists of archive fitnesses of previous generations.
312 --
d80ab67 @boegel version bump (v1.0), fix documentation, slight API changes, fix bug i…
authored
313 -- Note: most recent archives are at the head of the list.
420d2ec @boegel add support for letting user decide whether evolution should continue…
authored
314 --
d80ab67 @boegel version bump (v1.0), fix documentation, slight API changes, fix bug i…
authored
315 -- Default implementation always returns False.
316 hasConverged :: [Archive e s] -- ^ archives so far
317 -> Bool -- ^ whether or not convergence was detected
318 hasConverged _ = False
ce59f10 @boegel pass universe of all known entities to scorePop
authored
319
5945e9b @boegel fix Cabal file, adjust documentation for Haddock, define ScoredGen ty…
authored
320 -- |Initialize: generate initial population.
6b43bd9 @boegel abstract score type (doesn't typecheck yet)
authored
321 initPop :: (Entity e s d p m) => p -- ^ pool for generating random entities
655ee46 @boegel make genRandom return a monadic value, cosmetic changes (mostly docum…
authored
322 -> Int -- ^ population size
323 -> Int -- ^ random seed
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
324 -> m [e] -- ^ initialized population
655ee46 @boegel make genRandom return a monadic value, cosmetic changes (mostly docum…
authored
325 initPop pool n seed = do
326 let g = mkStdGen seed
327 seeds = take n $ randoms g
41849c7 @boegel pass archive to scorePop
authored
328 entities <- mapM (genRandom pool) seeds
655ee46 @boegel make genRandom return a monadic value, cosmetic changes (mostly docum…
authored
329 return entities
079879b @boegel initial commit: GA v0.1, ready to release on Hackage
authored
330
5945e9b @boegel fix Cabal file, adjust documentation for Haddock, define ScoredGen ty…
authored
331 -- |Binary tournament selection operator.
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
332 tournamentSelection :: (Ord s) => [ScoredEntity e s] -- ^ set of entities
6b43bd9 @boegel abstract score type (doesn't typecheck yet)
authored
333 -> Int -- ^ random seed
334 -> e -- ^ selected entity
079879b @boegel initial commit: GA v0.1, ready to release on Hackage
authored
335 tournamentSelection xs seed = if s1 < s2 then x1 else x2
336 where
337 len = length xs
338 g = mkStdGen seed
339 is = take 2 $ map (flip mod len) $ randoms g
340 [(s1,x1),(s2,x2)] = map ((!!) xs) is
341
3277f4d @boegel introduce performCrossover/performMutation, fix small bug in generati…
authored
342 -- |Apply crossover to obtain new entites.
6b43bd9 @boegel abstract score type (doesn't typecheck yet)
authored
343 performCrossover :: (Entity e s d p m) => Float -- ^ crossover parameter
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
344 -> Int -- ^ number of entities
655ee46 @boegel make genRandom return a monadic value, cosmetic changes (mostly docum…
authored
345 -> Int -- ^ random seed
346 -> p -- ^ pool for combining entities
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
347 -> [ScoredEntity e s] -- ^ entities
64852b2 @boegel make return values of crossover/mutation operators monadic
authored
348 -> m [e] -- combined entities
349 performCrossover p n seed pool es = do
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
350 let g = mkStdGen seed
351 (selSeeds,seeds) = takeAndDrop (2*2*n) $ randoms g
352 (crossSeeds,_) = takeAndDrop (2*n) seeds
353 tuples = currify $ map (tournamentSelection es) selSeeds
354 resEntities <- zipWithM ($)
355 (map (uncurry . (crossover pool p)) crossSeeds)
356 tuples
357 return $ take n $ catMaybes $ resEntities
3277f4d @boegel introduce performCrossover/performMutation, fix small bug in generati…
authored
358
359 -- |Apply mutation to obtain new entites.
6b43bd9 @boegel abstract score type (doesn't typecheck yet)
authored
360 performMutation :: (Entity e s d p m) => Float -- ^ mutation parameter
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
361 -> Int -- ^ number of entities
655ee46 @boegel make genRandom return a monadic value, cosmetic changes (mostly docum…
authored
362 -> Int -- ^ random seed
363 -> p -- ^ pool for mutating entities
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
364 -> [ScoredEntity e s] -- ^ entities
64852b2 @boegel make return values of crossover/mutation operators monadic
authored
365 -> m [e] -- mutated entities
366 performMutation p n seed pool es = do
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
367 let g = mkStdGen seed
368 (selSeeds,seeds) = takeAndDrop (2*n) $ randoms g
369 (mutSeeds,_) = takeAndDrop (2*n) seeds
370 resEntities <- zipWithM ($)
371 (map (mutation pool p) mutSeeds)
372 (map (tournamentSelection es) selSeeds)
373 return $ take n $ catMaybes $ resEntities
3277f4d @boegel introduce performCrossover/performMutation, fix small bug in generati…
authored
374
bcd1a7d @boegel rescore archive in each generation if desired, redefine Universe as list
authored
375 -- |Score a list of entities.
376 scoreAll :: (Entity e s d p m) => d -- ^ dataset for scoring entities
377 -> [e] -- ^ universe of known entities
378 -> [e] -- ^ set of entities to score
379 -> m [Maybe s]
380 scoreAll dataset univEnts ents = do
381 scores <- scorePop dataset univEnts ents
382 case scores of
383 (Just ss) -> return ss
384 -- score one by one if scorePop failed
385 Nothing -> mapM (score dataset) ents
386
5945e9b @boegel fix Cabal file, adjust documentation for Haddock, define ScoredGen ty…
authored
387 -- |Function to perform a single evolution step:
388 --
655ee46 @boegel make genRandom return a monadic value, cosmetic changes (mostly docum…
authored
389 -- * score all entities in the population
5945e9b @boegel fix Cabal file, adjust documentation for Haddock, define ScoredGen ty…
authored
390 --
655ee46 @boegel make genRandom return a monadic value, cosmetic changes (mostly docum…
authored
391 -- * combine with best entities so far (archive)
5945e9b @boegel fix Cabal file, adjust documentation for Haddock, define ScoredGen ty…
authored
392 --
393 -- * sort by fitness
394 --
395 -- * create new population using crossover/mutation
655ee46 @boegel make genRandom return a monadic value, cosmetic changes (mostly docum…
authored
396 --
397 -- * retain best scoring entities in the archive
6b43bd9 @boegel abstract score type (doesn't typecheck yet)
authored
398 evolutionStep :: (Entity e s d p m) => p -- ^ pool for crossover/mutation
655ee46 @boegel make genRandom return a monadic value, cosmetic changes (mostly docum…
authored
399 -> d -- ^ dataset for scoring entities
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
400 -> (Int,Int,Int) -- ^ # of c/m/a entities
401 -> (Float,Float) -- ^ c/m parameters
bcd1a7d @boegel rescore archive in each generation if desired, redefine Universe as list
authored
402 -> Bool -- ^ rescore archive in each step?
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
403 -> Universe e -- ^ known entities
6b43bd9 @boegel abstract score type (doesn't typecheck yet)
authored
404 -> Generation e s -- ^ current generation
655ee46 @boegel make genRandom return a monadic value, cosmetic changes (mostly docum…
authored
405 -> Int -- ^ seed for next generation
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
406 -> m (Universe e, Generation e s)
407 -- ^ renewed universe, next generation
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
408 evolutionStep pool
409 dataset
410 (cn,mn,an)
411 (crossPar,mutPar)
412 rescoreArchive
413 universe
414 (pop,archive)
415 seed = do
416 -- score population
417 -- try to score in a single go first
418 scores <- scoreAll dataset universe pop
419 archive' <- if rescoreArchive
420 then return archive
421 else do
422 let as = map snd archive
423 scores' <- scoreAll dataset universe as
424 return $ zip scores' as
425 let scoredPop = zip scores pop
426 -- combine with archive for selection
427 combo = scoredPop ++ archive'
428 -- split seeds for crossover/mutation selection/seeds
429 g = mkStdGen seed
430 [crossSeed,mutSeed] = take 2 $ randoms g
431 -- apply crossover and mutation
432 crossEnts <- performCrossover crossPar cn crossSeed pool combo
433 mutEnts <- performMutation mutPar mn mutSeed pool combo
434 let -- new population: crossovered + mutated entities
435 newPop = crossEnts ++ mutEnts
436 -- new archive: best entities so far
420d2ec @boegel add support for letting user decide whether evolution should continue…
authored
437 newArchive = take an
438 $ nubBy (\x y -> comparing snd x y == EQ)
439 $ sortBy (comparing fst) combo
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
440 newUniverse = nub $ universe ++ pop
441 return (newUniverse, (newPop,newArchive))
079879b @boegel initial commit: GA v0.1, ready to release on Hackage
authored
442
088bb64 @boegel introduce evolveChkpt, which required liftIO and allows checkpointing…
authored
443 -- |Evolution: evaluate generation and continue.
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
444 evolution :: (Entity e s d p m) => GAConfig -- ^ configuration for GA
445 -> Universe e -- ^ known entities
d80ab67 @boegel version bump (v1.0), fix documentation, slight API changes, fix bug i…
authored
446 -> [Archive e s] -- ^ previous archives
6b43bd9 @boegel abstract score type (doesn't typecheck yet)
authored
447 -> Generation e s -- ^ current generation
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
448 -> ( Universe e
449 -> Generation e s
450 -> Int
451 -> m (Universe e, Generation e s)
452 ) -- ^ function that evolves a generation
453 -> [(Int,Int)] -- ^ gen indicies and seeds
454 -> m (Generation e s) -- ^evolved generation
420d2ec @boegel add support for letting user decide whether evolution should continue…
authored
455 evolution cfg universe pastArchives gen step ((_,seed):gss) = do
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
456 (universe',nextGen) <- step universe gen seed
457 let (Just fitness, e) = (head $ snd nextGen)
420d2ec @boegel add support for letting user decide whether evolution should continue…
authored
458 newArchive = snd nextGen
d80ab67 @boegel version bump (v1.0), fix documentation, slight API changes, fix bug i…
authored
459 if hasConverged pastArchives || isPerfect (e,fitness)
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
460 then return nextGen
420d2ec @boegel add support for letting user decide whether evolution should continue…
authored
461 else evolution cfg universe' (newArchive:pastArchives) nextGen step gss
088bb64 @boegel introduce evolveChkpt, which required liftIO and allows checkpointing…
authored
462 -- no more gen. indices/seeds => quit
420d2ec @boegel add support for letting user decide whether evolution should continue…
authored
463 evolution _ _ _ gen _ [] = return gen
088bb64 @boegel introduce evolveChkpt, which required liftIO and allows checkpointing…
authored
464
5945e9b @boegel fix Cabal file, adjust documentation for Haddock, define ScoredGen ty…
authored
465 -- |Generate file name for checkpoint.
655ee46 @boegel make genRandom return a monadic value, cosmetic changes (mostly docum…
authored
466 chkptFileName :: GAConfig -- ^ configuration for generation algorithm
467 -> (Int,Int) -- ^ generation index and random seed
468 -> FilePath -- ^ path of checkpoint file
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
469 chkptFileName cfg (gi,seed) = "checkpoints/GA-"
470 ++ cfgTxt ++ "-gen"
471 ++ (show gi) ++ "-seed-"
472 ++ (show seed) ++ ".chk"
079879b @boegel initial commit: GA v0.1, ready to release on Hackage
authored
473 where
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
474 cfgTxt = (show $ getPopSize cfg) ++ "-" ++
475 (show $ getArchiveSize cfg) ++ "-" ++
476 (show $ getCrossoverRate cfg) ++ "-" ++
477 (show $ getMutationRate cfg) ++ "-" ++
478 (show $ getCrossoverParam cfg) ++ "-" ++
479 (show $ getMutationParam cfg)
079879b @boegel initial commit: GA v0.1, ready to release on Hackage
authored
480
5945e9b @boegel fix Cabal file, adjust documentation for Haddock, define ScoredGen ty…
authored
481 -- |Checkpoint a single generation.
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
482 checkpointGen :: (Entity e s d p m) => GAConfig -- ^ configuraton for GA
d80ab67 @boegel version bump (v1.0), fix documentation, slight API changes, fix bug i…
authored
483 -> Int -- ^ generation index
484 -> Int -- ^ random seed for generation
485 -> Generation e s -- ^ current generation
486 -> IO() -- ^ writes to file
079879b @boegel initial commit: GA v0.1, ready to release on Hackage
authored
487 checkpointGen cfg index seed (pop,archive) = do
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
488 let txt = show $ (pop,archive)
489 fn = chkptFileName cfg (index,seed)
490 putStrLn $ "writing checkpoint for gen "
491 ++ (show index) ++ " to " ++ fn
492 createDirectoryIfMissing True "checkpoints"
493 writeFile fn txt
079879b @boegel initial commit: GA v0.1, ready to release on Hackage
authored
494
5945e9b @boegel fix Cabal file, adjust documentation for Haddock, define ScoredGen ty…
authored
495 -- |Evolution: evaluate generation, (maybe) checkpoint, continue.
71a989f @boegel rename evolutionChkpt to evolutionVerbose
authored
496 evolutionVerbose :: (Entity e s d p m,
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
497 MonadIO m) => GAConfig -- ^ configuration for GA
498 -> Universe e -- ^ universe of known entities
d80ab67 @boegel version bump (v1.0), fix documentation, slight API changes, fix bug i…
authored
499 -> [Archive e s] -- ^ previous archives
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
500 -> Generation e s -- ^ current generation
501 -> ( Universe e
502 -> Generation e s
503 -> Int
504 -> m (Universe e, Generation e s)
505 ) -- ^ function that evolves a generation
506 -> [(Int,Int)] -- ^ gen indicies and seeds
507 -> m (Generation e s) -- ^ evolved generation
71a989f @boegel rename evolutionChkpt to evolutionVerbose
authored
508 evolutionVerbose cfg universe pastArchives gen step ((gi,seed):gss) = do
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
509 (universe',newPa@(_,archive')) <- step universe gen seed
510 let (Just fitness, e) = head archive'
511 -- checkpoint generation if desired
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
512 liftIO $ if (getWithCheckpointing cfg)
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
513 then checkpointGen cfg gi seed newPa
514 else return () -- skip checkpoint
d80ab67 @boegel version bump (v1.0), fix documentation, slight API changes, fix bug i…
authored
515 liftIO $ putStrLn $ showGeneration gi newPa
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
516 -- check for perfect entity
d80ab67 @boegel version bump (v1.0), fix documentation, slight API changes, fix bug i…
authored
517 if hasConverged pastArchives || isPerfect (e,fitness)
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
518 then do
420d2ec @boegel add support for letting user decide whether evolution should continue…
authored
519 liftIO $ putStrLn $ if isPerfect (e,fitness)
520 then "perfect entity found, "
521 ++ "finished after " ++ show gi
522 ++ " generations!"
523 else "no progress for 3 generations, "
524 ++ "stopping after " ++ show gi
525 ++ " generations!"
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
526 return newPa
71a989f @boegel rename evolutionChkpt to evolutionVerbose
authored
527 else evolutionVerbose cfg universe' (archive':pastArchives) newPa step gss
088bb64 @boegel introduce evolveChkpt, which required liftIO and allows checkpointing…
authored
528
079879b @boegel initial commit: GA v0.1, ready to release on Hackage
authored
529 -- no more gen. indices/seeds => quit
71a989f @boegel rename evolutionChkpt to evolutionVerbose
authored
530 evolutionVerbose _ _ _ gen _ [] = do
ce59f10 @boegel pass universe of all known entities to scorePop
authored
531 liftIO $ putStrLn $ "done evolving!"
532 return gen
088bb64 @boegel introduce evolveChkpt, which required liftIO and allows checkpointing…
authored
533
534 -- |Initialize.
6b43bd9 @boegel abstract score type (doesn't typecheck yet)
authored
535 initGA :: (Entity e s d p m) => StdGen -- ^ random generator
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
536 -> GAConfig -- ^ configuration for GA
655ee46 @boegel make genRandom return a monadic value, cosmetic changes (mostly docum…
authored
537 -> p -- ^ pool for generating random entities
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
538 -> m ([e],Int,Int,Int,
539 Float,Float,[(Int,Int)]
540 ) -- ^ initialization result
655ee46 @boegel make genRandom return a monadic value, cosmetic changes (mostly docum…
authored
541 initGA g cfg pool = do
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
542 -- generate list of random integers
543 let (seed:rs) = randoms g :: [Int]
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
544 ps = getPopSize cfg
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
545 -- initial population
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
546 pop <- initPop pool ps seed
547 let -- number of entities generated by crossover/mutation
548 cCnt = round $ (getCrossoverRate cfg) * (fromIntegral ps)
549 mCnt = round $ (getMutationRate cfg) * (fromIntegral ps)
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
550 -- archive size
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
551 aSize = getArchiveSize cfg
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
552 -- crossover/mutation parameters
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
553 crossPar = getCrossoverParam cfg
554 mutPar = getMutationParam cfg
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
555 -- seeds for evolution
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
556 seeds = take (getMaxGenerations cfg) rs
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
557 -- seeds per generation
558 genSeeds = zip [0..] seeds
559 return (pop, cCnt, mCnt, aSize, crossPar, mutPar, genSeeds)
ac79b9b @boegel changed type of ScoredEntity (no more Maybe); rename ScoredGen to Gen…
authored
560
5945e9b @boegel fix Cabal file, adjust documentation for Haddock, define ScoredGen ty…
authored
561 -- |Do the evolution!
6b43bd9 @boegel abstract score type (doesn't typecheck yet)
authored
562 evolve :: (Entity e s d p m) => StdGen -- ^ random generator
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
563 -> GAConfig -- ^ configuration for GA
564 -> p -- ^ random entities pool
6b43bd9 @boegel abstract score type (doesn't typecheck yet)
authored
565 -> d -- ^ dataset required to score entities
d80ab67 @boegel version bump (v1.0), fix documentation, slight API changes, fix bug i…
authored
566 -> m (Archive e s) -- ^ best entities
3277f4d @boegel introduce performCrossover/performMutation, fix small bug in generati…
authored
567 evolve g cfg pool dataset = do
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
568 -- initialize
569 (pop, cCnt, mCnt, aSize,
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
570 crossPar, mutPar, genSeeds) <- if not (getWithCheckpointing cfg)
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
571 then initGA g cfg pool
572 else error $ "(evolve) No checkpointing support "
573 ++ "(requires liftIO); see evolveVerbose."
574 -- do the evolution
575 let rescoreArchive = getRescoreArchive cfg
576 (_,resArchive) <- evolution
420d2ec @boegel add support for letting user decide whether evolution should continue…
authored
577 cfg [] [] (pop,[])
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
578 (evolutionStep pool dataset
579 (cCnt,mCnt,aSize)
580 (crossPar,mutPar)
581 rescoreArchive )
582 genSeeds
583 -- return best entity
584 return resArchive
585
586 -- |Try to restore from checkpoint.
587 --
588 -- First checkpoint for which a checkpoint file is found is restored.
589 restoreFromChkpt :: (Entity e s d p m) => GAConfig -- ^ configuration for GA
590 -> [(Int,Int)] -- ^ gen indices/seeds
591 -> IO (Maybe (Int,Generation e s))
592 -- ^ restored generation (if any)
593 restoreFromChkpt cfg ((gi,seed):genSeeds) = do
594 chkptFound <- doesFileExist fn
595 if chkptFound
596 then do
597 txt <- readFile fn
598 return $ Just (gi, read txt)
599 else restoreFromChkpt cfg genSeeds
088bb64 @boegel introduce evolveChkpt, which required liftIO and allows checkpointing…
authored
600 where
601 fn = chkptFileName cfg (gi,seed)
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
602 restoreFromChkpt _ [] = return Nothing
603
d80ab67 @boegel version bump (v1.0), fix documentation, slight API changes, fix bug i…
authored
604 -- |Do the evolution, verbosely.
605 --
606 -- Prints progress to stdout, and supports checkpointing.
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
607 --
d80ab67 @boegel version bump (v1.0), fix documentation, slight API changes, fix bug i…
authored
608 -- Note: requires support for liftIO in monad used.
609 evolveVerbose :: (Entity e s d p m, MonadIO m)
610 => StdGen -- ^ random generator
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
611 -> GAConfig -- ^ configuration for GA
612 -> p -- ^ random entities pool
613 -> d -- ^ dataset required to score entities
d80ab67 @boegel version bump (v1.0), fix documentation, slight API changes, fix bug i…
authored
614 -> m (Archive e s) -- ^ best entities
edcdf8d @boegel renamed evolveChkpt to evolveVerbose, hard-coded GA config in example…
authored
615 evolveVerbose g cfg pool dataset = do
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
616 -- initialize
617 (pop, cCnt, mCnt, aSize,
618 crossPar, mutPar, genSeeds) <- initGA g cfg pool
3a10fce @boegel fix documentation issues, adjust ChangeLog and README for release of
authored
619 let checkpointing = getWithCheckpointing cfg
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
620 -- (maybe) restore from checkpoint
621 restored <- liftIO $ if checkpointing
622 then restoreFromChkpt cfg (reverse genSeeds)
623 else return Nothing
624 let (gi,gen) = if isJust restored
625 -- restored pop/archive from checkpoint
626 then fromJust restored
627 -- restore failed, new population and empty archive
628 else (-1, (pop, []))
629 -- filter out seeds from past generations
630 genSeeds' = filter ((>gi) . fst) genSeeds
631 rescoreArchive = getRescoreArchive cfg
632 -- do the evolution
71a989f @boegel rename evolutionChkpt to evolutionVerbose
authored
633 (_,resArchive) <- evolutionVerbose
420d2ec @boegel add support for letting user decide whether evolution should continue…
authored
634 cfg [] [] gen
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
635 (evolutionStep pool dataset
636 (cCnt,mCnt,aSize)
637 (crossPar,mutPar)
638 rescoreArchive)
639 genSeeds'
640 -- return best entity
641 return resArchive
ce59f10 @boegel pass universe of all known entities to scorePop
authored
642
d80ab67 @boegel version bump (v1.0), fix documentation, slight API changes, fix bug i…
authored
643 -- |Random searching.
ba290b1 @boegel implement random search, remove FIXMEs
authored
644 --
645 -- Useful to compare with results from genetic algorithm.
646 randomSearch :: (Entity e s d p m) => StdGen -- ^ random generator
647 -> Int -- ^ number of random entities
eac3e67 @boegel code cleanup, respect 80-column style limit in GA.hs
authored
648 -> p -- ^ random entity pool
649 -> d -- ^ scoring dataset
d80ab67 @boegel version bump (v1.0), fix documentation, slight API changes, fix bug i…
authored
650 -> m (Archive e s) -- ^ scored entities (sorted)
ba290b1 @boegel implement random search, remove FIXMEs
authored
651 randomSearch g n pool dataset = do
652 let seed = fst $ random g :: Int
653 es <- initPop pool n seed
bcd1a7d @boegel rescore archive in each generation if desired, redefine Universe as list
authored
654 scores <- scoreAll dataset [] es
d80ab67 @boegel version bump (v1.0), fix documentation, slight API changes, fix bug i…
authored
655 return $ nubBy (\x y -> comparing snd x y == EQ)
656 $ sortBy (comparing fst)
657 $ zip scores es
Something went wrong with that request. Please try again.