{-# LANGUAGE BangPatterns, Rank2Types #-}
{-# LANGUAGE GADTs #-}
module Moo.GeneticAlgorithm.Run (
runGA
, runIO
, nextGeneration
, nextSteadyState
, makeStoppable
, loop, loopWithLog, loopIO
, Cond(..), LogHook(..), IOHook(..)
) where
import Moo.GeneticAlgorithm.Random
import Moo.GeneticAlgorithm.Selection (bestFirst)
import Moo.GeneticAlgorithm.Types
import Moo.GeneticAlgorithm.StopCondition
import Moo.GeneticAlgorithm.Utilities (doCrossovers, doNCrossovers)
import Data.Monoid (Monoid, mempty, mappend)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Control.Monad (liftM, when)
runGA :: Rand [Genome a]
-> ([Genome a] -> Rand b)
-> IO b
runGA initialize ga = do
rng <- newPureMT
let (genomes0, rng') = runRand initialize rng
return $ evalRand (ga genomes0) rng'
runIO :: Rand [Genome a]
-> (IORef PureMT -> [Genome a] -> IO (Population a))
-> IO (Population a)
runIO initialize gaIO = do
rng <- newPureMT
let (genomes0, rng') = runRand initialize rng
rngref <- newIORef rng'
gaIO rngref genomes0
nextGeneration
:: (ObjectiveFunction objectivefn a)
=> ProblemType
-> objectivefn
-> SelectionOp a
-> Int
-> CrossoverOp a
-> MutationOp a
-> StepGA Rand a
nextGeneration problem objective selectOp elite xoverOp mutationOp =
makeStoppable objective $ \pop -> do
genomes' <- liftM (map takeGenome) $ withElite problem elite selectOp pop
let top = take elite genomes'
let rest = drop elite genomes'
genomes' <- shuffle rest
genomes' <- doCrossovers genomes' xoverOp
genomes' <- mapM mutationOp genomes'
return $ evalObjective objective (top ++ genomes')
nextSteadyState
:: (ObjectiveFunction objectivefn a)
=> Int
-> ProblemType
-> objectivefn
-> SelectionOp a
-> CrossoverOp a
-> MutationOp a
-> StepGA Rand a
nextSteadyState n problem objective selectOp crossoverOp mutationOp =
makeStoppable objective $ \pop -> do
let popsize = length pop
parents <- liftM (map takeGenome) (selectOp pop)
children <- mapM mutationOp =<< doNCrossovers n parents crossoverOp
let sortedPop = bestFirst problem pop
let cpop = evalObjective objective children
return . take popsize $ cpop ++ sortedPop
makeStoppable
:: (ObjectiveFunction objectivefn a, Monad m)
=> objectivefn
-> (Population a -> m (Population a))
-> StepGA m a
makeStoppable objective onestep stop input = do
let pop = either (evalObjective objective) id input
if isGenomes input && evalCond stop pop
then return $ StopGA pop
else do
newpop <- onestep pop
return $ if evalCond stop newpop
then StopGA newpop
else ContinueGA newpop
where
isGenomes (Left _) = True
isGenomes (Right _) = False
withElite :: ProblemType -> Int -> SelectionOp a -> SelectionOp a
withElite problem n select = \population -> do
let elite = take n . eliteGenomes $ population
selected <- select population
return (elite ++ selected)
where
eliteGenomes = bestFirst problem
{-# INLINE loop #-}
loop :: (Monad m)
=> Cond a
-> StepGA m a
-> [Genome a]
-> m (Population a)
loop cond step genomes0 = go cond (Left genomes0)
where
go cond !x = do
x' <- step cond x
case x' of
(StopGA pop) -> return pop
(ContinueGA pop) -> go (updateCond pop cond) (Right pop)
{-# INLINE loopWithLog #-}
loopWithLog :: (Monad m, Monoid w)
=> LogHook a m w
-> Cond a
-> StepGA m a
-> [Genome a]
-> m (Population a, w)
loopWithLog hook cond step genomes0 = go cond 0 mempty (Left genomes0)
where
go cond !i !w !x = do
x' <- step cond x
case x' of
(StopGA pop) -> return (pop, w)
(ContinueGA pop) -> do
let w' = mappend w (runHook i pop hook)
let cond' = updateCond pop cond
go cond' (i+1) w' (Right pop)
runHook !i !x (WriteEvery n write)
| (rem i n) == 0 = write i x
| otherwise = mempty
{-# INLINE loopIO #-}
loopIO
:: [IOHook a]
-> Cond a
-> StepGA Rand a
-> IORef PureMT
-> [Genome a]
-> IO (Population a)
loopIO hooks cond step rngref genomes0 = do
rng <- readIORef rngref
start <- realToFrac `liftM` getPOSIXTime
(pop, rng') <- go start cond 0 rng (Left genomes0)
writeIORef rngref rng'
return pop
where
go start cond !i !rng !x = do
stop <- (any id) `liftM` (mapM (runhook start i x) hooks)
if (stop || either (const False) (evalCond cond) x)
then return (asPopulation x, rng)
else do
let (x', rng') = runRand (step cond x) rng
case x' of
(StopGA pop) -> return (pop, rng')
(ContinueGA pop) ->
do
let i' = i + 1
let cond' = updateCond pop cond
go start cond' i' rng' (Right pop)
runhook _ i x (DoEvery n io) = do
when ((rem i n) == 0) (io i (asPopulation x))
return False
runhook _ _ _ (StopWhen iotest) = iotest
runhook start _ _ (TimeLimit limit) = do
now <- realToFrac `liftM` getPOSIXTime
return (now >= start + limit)
dummyObjective :: Genome a -> Phenotype a
dummyObjective g = (g, 0.0)
asPopulation = either (map dummyObjective) id
data LogHook a m w where
WriteEvery :: (Monad m, Monoid w)
=> Int
-> (Int -> Population a -> w)
-> LogHook a m w
data IOHook a
= DoEvery { io'n :: Int, io'action :: (Int -> Population a -> IO ()) }
| StopWhen (IO Bool)
| TimeLimit { io't :: Double }