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)
debug :: Bool
debug = False
dbg :: String -> a -> a
dbg str x = if debug
then trace str x
else x
currify :: [a] -> [(a,a)]
currify (x:y:xs) = (x,y):currify xs
currify [] = []
currify [_] = error "(currify) ERROR: only one element left?!?"
takeAndDrop :: Int -> [a] -> ([a],[a])
takeAndDrop n xs
| n > 0 = let (hs,ts) = takeAndDrop (n1) (tail xs) in (head xs:hs, ts)
| otherwise = ([],xs)
data GAConfig = GAConfig {
popSize :: Int,
archiveSize :: Int,
maxGenerations :: Int,
crossoverRate :: Float,
mutationRate :: Float,
crossoverParam :: Float,
mutationParam :: Float,
withCheckpointing :: Bool
}
class (Eq a, Read a, Show a, ShowEntity a) => Entity a b c | a -> b, a -> c where
genRandom :: c -> Int -> a
crossover :: c -> Float -> Int -> a -> a -> Maybe a
mutation :: c -> Float -> Int -> a -> Maybe a
score :: a -> b -> Double
type ScoredEntity a = (Maybe Double, a)
type ScoredGen a = ([ScoredEntity a],[ScoredEntity a])
class ShowEntity a where
showEntity :: a -> String
showScoredEntity :: ShowEntity a => ScoredEntity a -> String
showScoredEntity (score,e) = "(" ++ show score ++ ", " ++ showEntity e ++ ")"
showScoredEntities :: ShowEntity a => [ScoredEntity a] -> String
showScoredEntities es = ("["++) . (++"]") . concat . intersperse "," $ map showScoredEntity es
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'
scoreEnt :: (Entity a b c) => b -> ScoredEntity a -> ScoredEntity a
scoreEnt d e@(Just _,_) = e
scoreEnt d (Nothing,x) = (Just $ score x d, x)
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
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
scoredPop = map (scoreEnt d) pop
combo = scoredPop ++ archive
seeds = randoms (mkStdGen seed) :: [Int]
(crossSelSeeds,seeds') = takeAndDrop (2*2*cn) seeds
(crossSeeds ,seeds'') = takeAndDrop (2*cn) seeds'
(mutSelSeeds ,seeds''') = takeAndDrop (2*mn) seeds''
(mutSeeds ,_) = takeAndDrop (2*mn) seeds'''
crossSel = currify $ map (tournamentSelection combo) crossSelSeeds
crossEnts = take cn $ map fromJust $ filter isJust $ zipWith ($) (map (uncurry . (crossover src crossPar)) crossSeeds) crossSel
mutSel = map (tournamentSelection combo) mutSelSeeds
mutEnts = take cn $ map fromJust $ filter isJust $ zipWith ($) (map (mutation src mutPar) mutSeeds) mutSel
pop' = zip (repeat Nothing) $ crossEnts ++ mutEnts
archive' = take an $ nub $ sortBy (comparing fst) $ filter (isJust . fst) combo
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"
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
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 :: (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'
if (withCheckpointing cfg)
then checkpointGen cfg gi seed newPa
else return ()
putStrLn $ "best entity (gen. " ++ show gi ++ "): " ++ (show e) ++ " [fitness: " ++ show fitness ++ "]"
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
evolution cfg (pop,archive) _ [] = do
putStrLn $ "done evolving!"
return (pop,archive)
evolve :: (Entity a b c) => StdGen -> GAConfig -> c -> b -> IO a
evolve g cfg src dataset = do
let rs = randoms g :: [Int]
let (rs',pop) = initPop src (popSize cfg) rs
let ps = popSize cfg
cCnt = round $ (crossoverRate cfg) * (fromIntegral ps)
mCnt = round $ (mutationRate cfg) * (fromIntegral ps)
aSize = archiveSize cfg
crossPar = crossoverParam cfg
mutPar = mutationParam cfg
seeds = take (maxGenerations cfg) rs'
genSeeds = zip [0..] seeds
checkpointing = withCheckpointing cfg
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
then dbg ("restored from checkpoint!\n\n") $ fromJust restored
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