module GA (Entity(..),
GAConfig(..),
evolve,
evolveVerbose,
randomSearch) where
import Control.Monad (zipWithM)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.List (sortBy, nub)
import Data.Maybe (catMaybes, fromJust, isJust)
import Data.Ord (comparing)
import System.Directory (createDirectoryIfMissing, doesFileExist)
import System.Random (StdGen, mkStdGen, random, randoms)
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 {
getPopSize :: Int,
getArchiveSize :: Int,
getMaxGenerations :: Int,
getCrossoverRate :: Float,
getMutationRate :: Float,
getCrossoverParam :: Float,
getMutationParam :: Float,
getWithCheckpointing :: Bool,
getRescoreArchive :: Bool
}
class (Eq e, Read e, Show e,
Ord s, Read s, Show s,
Monad m)
=> Entity e s d p m
| e -> s, e -> d, e -> p, e -> m where
genRandom :: p
-> Int
-> m e
crossover :: p
-> Float
-> Int
-> e
-> e
-> m (Maybe e)
mutation :: p
-> Float
-> Int
-> e
-> m (Maybe e)
score' :: d
-> e
-> (Maybe s)
score' _ _ = error $ "(GA) score' is not defined, "
++ "nor is score or scorePop!"
score :: d
-> e
-> m (Maybe s)
score d e = do
return $ score' d e
scorePop :: d
-> [e]
-> [e]
-> m (Maybe [Maybe s])
scorePop _ _ _ = return Nothing
isPerfect :: (e,s)
-> Bool
isPerfect _ = False
type ScoredEntity e s = (Maybe s, e)
type Generation e s = ([e],[ScoredEntity e s])
type Universe e = [e]
initPop :: (Entity e s d p m) => p
-> Int
-> Int
-> m [e]
initPop pool n seed = do
let g = mkStdGen seed
seeds = take n $ randoms g
entities <- mapM (genRandom pool) seeds
return entities
tournamentSelection :: (Ord s) => [ScoredEntity e s]
-> Int
-> e
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
performCrossover :: (Entity e s d p m) => Float
-> Int
-> Int
-> p
-> [ScoredEntity e s]
-> m [e]
performCrossover p n seed pool es = do
let g = mkStdGen seed
(selSeeds,seeds) = takeAndDrop (2*2*n) $ randoms g
(crossSeeds,_) = takeAndDrop (2*n) seeds
tuples = currify $ map (tournamentSelection es) selSeeds
resEntities <- zipWithM ($)
(map (uncurry . (crossover pool p)) crossSeeds)
tuples
return $ take n $ catMaybes $ resEntities
performMutation :: (Entity e s d p m) => Float
-> Int
-> Int
-> p
-> [ScoredEntity e s]
-> m [e]
performMutation p n seed pool es = do
let g = mkStdGen seed
(selSeeds,seeds) = takeAndDrop (2*n) $ randoms g
(mutSeeds,_) = takeAndDrop (2*n) seeds
resEntities <- zipWithM ($)
(map (mutation pool p) mutSeeds)
(map (tournamentSelection es) selSeeds)
return $ take n $ catMaybes $ resEntities
scoreAll :: (Entity e s d p m) => d
-> [e]
-> [e]
-> m [Maybe s]
scoreAll dataset univEnts ents = do
scores <- scorePop dataset univEnts ents
case scores of
(Just ss) -> return ss
Nothing -> mapM (score dataset) ents
evolutionStep :: (Entity e s d p m) => p
-> d
-> (Int,Int,Int)
-> (Float,Float)
-> Bool
-> Universe e
-> Generation e s
-> Int
-> m (Universe e, Generation e s)
evolutionStep pool
dataset
(cn,mn,an)
(crossPar,mutPar)
rescoreArchive
universe
(pop,archive)
seed = do
scores <- scoreAll dataset universe pop
archive' <- if rescoreArchive
then return archive
else do
let as = map snd archive
scores' <- scoreAll dataset universe as
return $ zip scores' as
let scoredPop = zip scores pop
combo = scoredPop ++ archive'
g = mkStdGen seed
[crossSeed,mutSeed] = take 2 $ randoms g
crossEnts <- performCrossover crossPar cn crossSeed pool combo
mutEnts <- performMutation mutPar mn mutSeed pool combo
let
newPop = crossEnts ++ mutEnts
newArchive = take an $ nub $ sortBy (comparing fst) $ combo
newUniverse = nub $ universe ++ pop
return (newUniverse, (newPop,newArchive))
evolution :: (Entity e s d p m) => GAConfig
-> Universe e
-> Generation e s
-> ( Universe e
-> Generation e s
-> Int
-> m (Universe e, Generation e s)
)
-> [(Int,Int)]
-> m (Generation e s)
evolution cfg universe gen step ((_,seed):gss) = do
(universe',nextGen) <- step universe gen seed
let (Just fitness, e) = (head $ snd nextGen)
if isPerfect (e,fitness)
then return nextGen
else evolution cfg universe' nextGen step gss
evolution _ _ gen _ [] = return gen
chkptFileName :: GAConfig
-> (Int,Int)
-> FilePath
chkptFileName cfg (gi,seed) = "checkpoints/GA-"
++ cfgTxt ++ "-gen"
++ (show gi) ++ "-seed-"
++ (show seed) ++ ".chk"
where
cfgTxt = (show $ getPopSize cfg) ++ "-" ++
(show $ getArchiveSize cfg) ++ "-" ++
(show $ getCrossoverRate cfg) ++ "-" ++
(show $ getMutationRate cfg) ++ "-" ++
(show $ getCrossoverParam cfg) ++ "-" ++
(show $ getMutationParam cfg)
checkpointGen :: (Entity e s d p m) => GAConfig
-> Int
-> Int
-> Generation e s
-> IO()
checkpointGen cfg index seed (pop,archive) = do
let txt = show $ (pop,archive)
fn = chkptFileName cfg (index,seed)
putStrLn $ "writing checkpoint for gen "
++ (show index) ++ " to " ++ fn
createDirectoryIfMissing True "checkpoints"
writeFile fn txt
evolutionChkpt :: (Entity e s d p m,
MonadIO m) => GAConfig
-> Universe e
-> Generation e s
-> ( Universe e
-> Generation e s
-> Int
-> m (Universe e, Generation e s)
)
-> [(Int,Int)]
-> m (Generation e s)
evolutionChkpt cfg universe gen step ((gi,seed):gss) = do
(universe',newPa@(_,archive')) <- step universe gen seed
let (Just fitness, e) = head archive'
liftIO $ if (getWithCheckpointing cfg)
then checkpointGen cfg gi seed newPa
else return ()
liftIO $ putStrLn $ "best entity (gen. "
++ show gi ++ "): " ++ (show e)
++ " [fitness: " ++ show fitness ++ "]"
if isPerfect (e, fitness)
then do
liftIO $ putStrLn $ "perfect entity found, "
++ "finished after " ++ show gi
++ " generations!"
return newPa
else evolutionChkpt cfg universe' newPa step gss
evolutionChkpt _ _ gen _ [] = do
liftIO $ putStrLn $ "done evolving!"
return gen
initGA :: (Entity e s d p m) => StdGen
-> GAConfig
-> p
-> m ([e],Int,Int,Int,
Float,Float,[(Int,Int)]
)
initGA g cfg pool = do
let (seed:rs) = randoms g :: [Int]
ps = getPopSize cfg
pop <- initPop pool ps seed
let
cCnt = round $ (getCrossoverRate cfg) * (fromIntegral ps)
mCnt = round $ (getMutationRate cfg) * (fromIntegral ps)
aSize = getArchiveSize cfg
crossPar = getCrossoverParam cfg
mutPar = getMutationParam cfg
seeds = take (getMaxGenerations cfg) rs
genSeeds = zip [0..] seeds
return (pop, cCnt, mCnt, aSize, crossPar, mutPar, genSeeds)
evolve :: (Entity e s d p m) => StdGen
-> GAConfig
-> p
-> d
-> m [ScoredEntity e s]
evolve g cfg pool dataset = do
(pop, cCnt, mCnt, aSize,
crossPar, mutPar, genSeeds) <- if not (getWithCheckpointing cfg)
then initGA g cfg pool
else error $ "(evolve) No checkpointing support "
++ "(requires liftIO); see evolveVerbose."
let rescoreArchive = getRescoreArchive cfg
(_,resArchive) <- evolution
cfg [] (pop,[])
(evolutionStep pool dataset
(cCnt,mCnt,aSize)
(crossPar,mutPar)
rescoreArchive )
genSeeds
return resArchive
restoreFromChkpt :: (Entity e s d p m) => GAConfig
-> [(Int,Int)]
-> IO (Maybe (Int,Generation e s))
restoreFromChkpt cfg ((gi,seed):genSeeds) = do
chkptFound <- doesFileExist fn
if chkptFound
then do
txt <- readFile fn
return $ Just (gi, read txt)
else restoreFromChkpt cfg genSeeds
where
fn = chkptFileName cfg (gi,seed)
restoreFromChkpt _ [] = return Nothing
evolveVerbose :: (Entity e s d p m,
MonadIO m) => StdGen
-> GAConfig
-> p
-> d
-> m [ScoredEntity e s]
evolveVerbose g cfg pool dataset = do
(pop, cCnt, mCnt, aSize,
crossPar, mutPar, genSeeds) <- initGA g cfg pool
let checkpointing = getWithCheckpointing cfg
restored <- liftIO $ if checkpointing
then restoreFromChkpt cfg (reverse genSeeds)
else return Nothing
let (gi,gen) = if isJust restored
then fromJust restored
else (1, (pop, []))
genSeeds' = filter ((>gi) . fst) genSeeds
rescoreArchive = getRescoreArchive cfg
(_,resArchive) <- evolutionChkpt
cfg [] gen
(evolutionStep pool dataset
(cCnt,mCnt,aSize)
(crossPar,mutPar)
rescoreArchive)
genSeeds'
return resArchive
randomSearch :: (Entity e s d p m) => StdGen
-> Int
-> p
-> d
-> m [ScoredEntity e s]
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