{-# 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 :: Rand [Genome a] -> ([Genome a] -> Rand b) -> IO b
runGA Rand [Genome a]
initialize [Genome a] -> Rand b
ga = do
PureMT
rng <- IO PureMT
newPureMT
let ([Genome a]
genomes0, PureMT
rng') = Rand [Genome a] -> PureMT -> ([Genome a], PureMT)
forall g a. Rand g a -> g -> (a, g)
runRand Rand [Genome a]
initialize PureMT
rng
b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> IO b) -> b -> IO b
forall a b. (a -> b) -> a -> b
$ Rand b -> PureMT -> b
forall g a. Rand g a -> g -> a
evalRand ([Genome a] -> Rand b
ga [Genome a]
genomes0) PureMT
rng'
runIO :: Rand [Genome a]
-> (IORef PureMT -> [Genome a] -> IO (Population a))
-> IO (Population a)
runIO :: Rand [Genome a]
-> (IORef PureMT -> [Genome a] -> IO (Population a))
-> IO (Population a)
runIO Rand [Genome a]
initialize IORef PureMT -> [Genome a] -> IO (Population a)
gaIO = do
PureMT
rng <- IO PureMT
newPureMT
let ([Genome a]
genomes0, PureMT
rng') = Rand [Genome a] -> PureMT -> ([Genome a], PureMT)
forall g a. Rand g a -> g -> (a, g)
runRand Rand [Genome a]
initialize PureMT
rng
IORef PureMT
rngref <- PureMT -> IO (IORef PureMT)
forall a. a -> IO (IORef a)
newIORef PureMT
rng'
IORef PureMT -> [Genome a] -> IO (Population a)
gaIO IORef PureMT
rngref [Genome a]
genomes0
nextGeneration
:: (ObjectiveFunction objectivefn a)
=> ProblemType
-> objectivefn
-> SelectionOp a
-> Int
-> CrossoverOp a
-> MutationOp a
-> StepGA Rand a
nextGeneration :: ProblemType
-> objectivefn
-> SelectionOp a
-> Int
-> CrossoverOp a
-> MutationOp a
-> StepGA Rand a
nextGeneration ProblemType
problem objectivefn
objective SelectionOp a
selectOp Int
elite CrossoverOp a
xoverOp MutationOp a
mutationOp =
objectivefn -> SelectionOp a -> StepGA Rand a
forall objectivefn a (m :: * -> *).
(ObjectiveFunction objectivefn a, Monad m) =>
objectivefn -> (Population a -> m (Population a)) -> StepGA m a
makeStoppable objectivefn
objective (SelectionOp a -> StepGA Rand a) -> SelectionOp a -> StepGA Rand a
forall a b. (a -> b) -> a -> b
$ \Population a
pop -> do
[Genome a]
genomes' <- (Population a -> [Genome a])
-> RandT PureMT Identity (Population a)
-> RandT PureMT Identity [Genome a]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((Phenotype a -> Genome a) -> Population a -> [Genome a]
forall a b. (a -> b) -> [a] -> [b]
map Phenotype a -> Genome a
forall gt a. GenomeState gt a => gt -> Genome a
takeGenome) (RandT PureMT Identity (Population a)
-> RandT PureMT Identity [Genome a])
-> RandT PureMT Identity (Population a)
-> RandT PureMT Identity [Genome a]
forall a b. (a -> b) -> a -> b
$ ProblemType -> Int -> SelectionOp a -> SelectionOp a
forall a. ProblemType -> Int -> SelectionOp a -> SelectionOp a
withElite ProblemType
problem Int
elite SelectionOp a
selectOp Population a
pop
let top :: [Genome a]
top = Int -> [Genome a] -> [Genome a]
forall a. Int -> [a] -> [a]
take Int
elite [Genome a]
genomes'
let rest :: [Genome a]
rest = Int -> [Genome a] -> [Genome a]
forall a. Int -> [a] -> [a]
drop Int
elite [Genome a]
genomes'
[Genome a]
genomes' <- [Genome a] -> RandT PureMT Identity [Genome a]
forall a. [a] -> Rand [a]
shuffle [Genome a]
rest
[Genome a]
genomes' <- [Genome a] -> CrossoverOp a -> RandT PureMT Identity [Genome a]
forall a. [Genome a] -> CrossoverOp a -> Rand [Genome a]
doCrossovers [Genome a]
genomes' CrossoverOp a
xoverOp
[Genome a]
genomes' <- MutationOp a -> [Genome a] -> RandT PureMT Identity [Genome a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM MutationOp a
mutationOp [Genome a]
genomes'
SelectionOp a
forall (m :: * -> *) a. Monad m => a -> m a
return SelectionOp a -> SelectionOp a
forall a b. (a -> b) -> a -> b
$ objectivefn -> [Genome a] -> Population a
forall f a.
ObjectiveFunction f a =>
f -> [Genome a] -> Population a
evalObjective objectivefn
objective ([Genome a]
top [Genome a] -> [Genome a] -> [Genome a]
forall a. [a] -> [a] -> [a]
++ [Genome a]
genomes')
nextSteadyState
:: (ObjectiveFunction objectivefn a)
=> Int
-> ProblemType
-> objectivefn
-> SelectionOp a
-> CrossoverOp a
-> MutationOp a
-> StepGA Rand a
nextSteadyState :: Int
-> ProblemType
-> objectivefn
-> SelectionOp a
-> CrossoverOp a
-> MutationOp a
-> StepGA Rand a
nextSteadyState Int
n ProblemType
problem objectivefn
objective SelectionOp a
selectOp CrossoverOp a
crossoverOp MutationOp a
mutationOp =
objectivefn -> SelectionOp a -> StepGA Rand a
forall objectivefn a (m :: * -> *).
(ObjectiveFunction objectivefn a, Monad m) =>
objectivefn -> (Population a -> m (Population a)) -> StepGA m a
makeStoppable objectivefn
objective (SelectionOp a -> StepGA Rand a) -> SelectionOp a -> StepGA Rand a
forall a b. (a -> b) -> a -> b
$ \Population a
pop -> do
let popsize :: Int
popsize = Population a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Population a
pop
[Genome a]
parents <- (Population a -> [Genome a])
-> RandT PureMT Identity (Population a)
-> RandT PureMT Identity [Genome a]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((Phenotype a -> Genome a) -> Population a -> [Genome a]
forall a b. (a -> b) -> [a] -> [b]
map Phenotype a -> Genome a
forall gt a. GenomeState gt a => gt -> Genome a
takeGenome) (SelectionOp a
selectOp Population a
pop)
[Genome a]
children <- MutationOp a -> [Genome a] -> RandT PureMT Identity [Genome a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM MutationOp a
mutationOp ([Genome a] -> RandT PureMT Identity [Genome a])
-> RandT PureMT Identity [Genome a]
-> RandT PureMT Identity [Genome a]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int
-> [Genome a] -> CrossoverOp a -> RandT PureMT Identity [Genome a]
forall a. Int -> [Genome a] -> CrossoverOp a -> Rand [Genome a]
doNCrossovers Int
n [Genome a]
parents CrossoverOp a
crossoverOp
let sortedPop :: Population a
sortedPop = ProblemType -> Population a -> Population a
forall a. ProblemType -> Population a -> Population a
bestFirst ProblemType
problem Population a
pop
let cpop :: Population a
cpop = objectivefn -> [Genome a] -> Population a
forall f a.
ObjectiveFunction f a =>
f -> [Genome a] -> Population a
evalObjective objectivefn
objective [Genome a]
children
SelectionOp a
forall (m :: * -> *) a. Monad m => a -> m a
return SelectionOp a -> (Population a -> Population a) -> SelectionOp a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Population a -> Population a
forall a. Int -> [a] -> [a]
take Int
popsize SelectionOp a -> SelectionOp a
forall a b. (a -> b) -> a -> b
$ Population a
cpop Population a -> Population a -> Population a
forall a. [a] -> [a] -> [a]
++ Population a
sortedPop
makeStoppable
:: (ObjectiveFunction objectivefn a, Monad m)
=> objectivefn
-> (Population a -> m (Population a))
-> StepGA m a
makeStoppable :: objectivefn -> (Population a -> m (Population a)) -> StepGA m a
makeStoppable objectivefn
objective Population a -> m (Population a)
onestep Cond a
stop PopulationState a
input = do
let pop :: Population a
pop = ([Genome a] -> Population a)
-> (Population a -> Population a)
-> PopulationState a
-> Population a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (objectivefn -> [Genome a] -> Population a
forall f a.
ObjectiveFunction f a =>
f -> [Genome a] -> Population a
evalObjective objectivefn
objective) Population a -> Population a
forall a. a -> a
id PopulationState a
input
if PopulationState a -> Bool
forall a b. Either a b -> Bool
isGenomes PopulationState a
input Bool -> Bool -> Bool
&& Cond a -> Population a -> Bool
forall a. Cond a -> Population a -> Bool
evalCond Cond a
stop Population a
pop
then StepResult (Population a) -> m (StepResult (Population a))
forall (m :: * -> *) a. Monad m => a -> m a
return (StepResult (Population a) -> m (StepResult (Population a)))
-> StepResult (Population a) -> m (StepResult (Population a))
forall a b. (a -> b) -> a -> b
$ Population a -> StepResult (Population a)
forall a. a -> StepResult a
StopGA Population a
pop
else do
Population a
newpop <- Population a -> m (Population a)
onestep Population a
pop
StepResult (Population a) -> m (StepResult (Population a))
forall (m :: * -> *) a. Monad m => a -> m a
return (StepResult (Population a) -> m (StepResult (Population a)))
-> StepResult (Population a) -> m (StepResult (Population a))
forall a b. (a -> b) -> a -> b
$ if Cond a -> Population a -> Bool
forall a. Cond a -> Population a -> Bool
evalCond Cond a
stop Population a
newpop
then Population a -> StepResult (Population a)
forall a. a -> StepResult a
StopGA Population a
newpop
else Population a -> StepResult (Population a)
forall a. a -> StepResult a
ContinueGA Population a
newpop
where
isGenomes :: Either a b -> Bool
isGenomes (Left a
_) = Bool
True
isGenomes (Right b
_) = Bool
False
withElite :: ProblemType -> Int -> SelectionOp a -> SelectionOp a
withElite :: ProblemType -> Int -> SelectionOp a -> SelectionOp a
withElite ProblemType
problem Int
n SelectionOp a
select = \Population a
population -> do
let elite :: Population a
elite = Int -> Population a -> Population a
forall a. Int -> [a] -> [a]
take Int
n (Population a -> Population a)
-> (Population a -> Population a) -> Population a -> Population a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Population a -> Population a
eliteGenomes (Population a -> Population a) -> Population a -> Population a
forall a b. (a -> b) -> a -> b
$ Population a
population
Population a
selected <- SelectionOp a
select Population a
population
SelectionOp a
forall (m :: * -> *) a. Monad m => a -> m a
return (Population a
elite Population a -> Population a -> Population a
forall a. [a] -> [a] -> [a]
++ Population a
selected)
where
eliteGenomes :: Population a -> Population a
eliteGenomes = ProblemType -> Population a -> Population a
forall a. ProblemType -> Population a -> Population a
bestFirst ProblemType
problem
{-# INLINE loop #-}
loop :: (Monad m)
=> Cond a
-> StepGA m a
-> [Genome a]
-> m (Population a)
loop :: Cond a -> StepGA m a -> [Genome a] -> m (Population a)
loop Cond a
cond StepGA m a
step [Genome a]
genomes0 = Cond a -> Either [Genome a] (Population a) -> m (Population a)
go Cond a
cond ([Genome a] -> Either [Genome a] (Population a)
forall a b. a -> Either a b
Left [Genome a]
genomes0)
where
go :: Cond a -> Either [Genome a] (Population a) -> m (Population a)
go Cond a
cond !Either [Genome a] (Population a)
x = do
StepResult (Population a)
x' <- StepGA m a
step Cond a
cond Either [Genome a] (Population a)
x
case StepResult (Population a)
x' of
(StopGA Population a
pop) -> Population a -> m (Population a)
forall (m :: * -> *) a. Monad m => a -> m a
return Population a
pop
(ContinueGA Population a
pop) -> Cond a -> Either [Genome a] (Population a) -> m (Population a)
go (Population a -> Cond a -> Cond a
forall a. Population a -> Cond a -> Cond a
updateCond Population a
pop Cond a
cond) (Population a -> Either [Genome a] (Population a)
forall a b. b -> Either a b
Right Population a
pop)
{-# INLINE loopWithLog #-}
loopWithLog :: (Monad m, Monoid w)
=> LogHook a m w
-> Cond a
-> StepGA m a
-> [Genome a]
-> m (Population a, w)
loopWithLog :: LogHook a m w
-> Cond a -> StepGA m a -> [Genome a] -> m (Population a, w)
loopWithLog LogHook a m w
hook Cond a
cond StepGA m a
step [Genome a]
genomes0 = Cond a
-> Int
-> w
-> Either [Genome a] (Population a)
-> m (Population a, w)
go Cond a
cond Int
0 w
forall a. Monoid a => a
mempty ([Genome a] -> Either [Genome a] (Population a)
forall a b. a -> Either a b
Left [Genome a]
genomes0)
where
go :: Cond a
-> Int
-> w
-> Either [Genome a] (Population a)
-> m (Population a, w)
go Cond a
cond !Int
i !w
w !Either [Genome a] (Population a)
x = do
StepResult (Population a)
x' <- StepGA m a
step Cond a
cond Either [Genome a] (Population a)
x
case StepResult (Population a)
x' of
(StopGA Population a
pop) -> (Population a, w) -> m (Population a, w)
forall (m :: * -> *) a. Monad m => a -> m a
return (Population a
pop, w
w)
(ContinueGA Population a
pop) -> do
let w' :: w
w' = w -> w -> w
forall a. Monoid a => a -> a -> a
mappend w
w (Int -> Population a -> LogHook a m w -> w
forall a (m :: * -> *) p.
Int -> [Phenotype a] -> LogHook a m p -> p
runHook Int
i Population a
pop LogHook a m w
hook)
let cond' :: Cond a
cond' = Population a -> Cond a -> Cond a
forall a. Population a -> Cond a -> Cond a
updateCond Population a
pop Cond a
cond
Cond a
-> Int
-> w
-> Either [Genome a] (Population a)
-> m (Population a, w)
go Cond a
cond' (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) w
w' (Population a -> Either [Genome a] (Population a)
forall a b. b -> Either a b
Right Population a
pop)
runHook :: Int -> [Phenotype a] -> LogHook a m p -> p
runHook !Int
i ![Phenotype a]
x (WriteEvery Int
n Int -> [Phenotype a] -> p
write)
| (Int -> Int -> Int
forall a. Integral a => a -> a -> a
rem Int
i Int
n) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Int -> [Phenotype a] -> p
write Int
i [Phenotype a]
x
| Bool
otherwise = p
forall a. Monoid a => a
mempty
{-# INLINE loopIO #-}
loopIO
:: [IOHook a]
-> Cond a
-> StepGA Rand a
-> IORef PureMT
-> [Genome a]
-> IO (Population a)
loopIO :: [IOHook a]
-> Cond a
-> StepGA Rand a
-> IORef PureMT
-> [Genome a]
-> IO (Population a)
loopIO [IOHook a]
hooks Cond a
cond StepGA Rand a
step IORef PureMT
rngref [Genome a]
genomes0 = do
PureMT
rng <- IORef PureMT -> IO PureMT
forall a. IORef a -> IO a
readIORef IORef PureMT
rngref
Double
start <- POSIXTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (POSIXTime -> Double) -> IO POSIXTime -> IO Double
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` IO POSIXTime
getPOSIXTime
(Population a
pop, PureMT
rng') <- Double
-> Cond a
-> Int
-> PureMT
-> Either [Genome a] (Population a)
-> IO (Population a, PureMT)
go Double
start Cond a
cond Int
0 PureMT
rng ([Genome a] -> Either [Genome a] (Population a)
forall a b. a -> Either a b
Left [Genome a]
genomes0)
IORef PureMT -> PureMT -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef PureMT
rngref PureMT
rng'
Population a -> IO (Population a)
forall (m :: * -> *) a. Monad m => a -> m a
return Population a
pop
where
go :: Double
-> Cond a
-> Int
-> PureMT
-> Either [Genome a] (Population a)
-> IO (Population a, PureMT)
go Double
start Cond a
cond !Int
i !PureMT
rng !Either [Genome a] (Population a)
x = do
Bool
stop <- ((Bool -> Bool) -> [Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Bool -> Bool
forall a. a -> a
id) ([Bool] -> Bool) -> IO [Bool] -> IO Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` ((IOHook a -> IO Bool) -> [IOHook a] -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Double
-> Int -> Either [Genome a] (Population a) -> IOHook a -> IO Bool
forall a.
Double
-> Int -> Either [Genome a] [Phenotype a] -> IOHook a -> IO Bool
runhook Double
start Int
i Either [Genome a] (Population a)
x) [IOHook a]
hooks)
if (Bool
stop Bool -> Bool -> Bool
|| ([Genome a] -> Bool)
-> (Population a -> Bool)
-> Either [Genome a] (Population a)
-> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> [Genome a] -> Bool
forall a b. a -> b -> a
const Bool
False) (Cond a -> Population a -> Bool
forall a. Cond a -> Population a -> Bool
evalCond Cond a
cond) Either [Genome a] (Population a)
x)
then (Population a, PureMT) -> IO (Population a, PureMT)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Genome a] (Population a) -> Population a
forall a. Either [Genome a] [Phenotype a] -> [Phenotype a]
asPopulation Either [Genome a] (Population a)
x, PureMT
rng)
else do
let (StepResult (Population a)
x', PureMT
rng') = Rand PureMT (StepResult (Population a))
-> PureMT -> (StepResult (Population a), PureMT)
forall g a. Rand g a -> g -> (a, g)
runRand (StepGA Rand a
step Cond a
cond Either [Genome a] (Population a)
x) PureMT
rng
case StepResult (Population a)
x' of
(StopGA Population a
pop) -> (Population a, PureMT) -> IO (Population a, PureMT)
forall (m :: * -> *) a. Monad m => a -> m a
return (Population a
pop, PureMT
rng')
(ContinueGA Population a
pop) ->
do
let i' :: Int
i' = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
let cond' :: Cond a
cond' = Population a -> Cond a -> Cond a
forall a. Population a -> Cond a -> Cond a
updateCond Population a
pop Cond a
cond
Double
-> Cond a
-> Int
-> PureMT
-> Either [Genome a] (Population a)
-> IO (Population a, PureMT)
go Double
start Cond a
cond' Int
i' PureMT
rng' (Population a -> Either [Genome a] (Population a)
forall a b. b -> Either a b
Right Population a
pop)
runhook :: Double
-> Int -> Either [Genome a] [Phenotype a] -> IOHook a -> IO Bool
runhook Double
_ Int
i Either [Genome a] [Phenotype a]
x (DoEvery Int
n Int -> [Phenotype a] -> IO ()
io) = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Int -> Int -> Int
forall a. Integral a => a -> a -> a
rem Int
i Int
n) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (Int -> [Phenotype a] -> IO ()
io Int
i (Either [Genome a] [Phenotype a] -> [Phenotype a]
forall a. Either [Genome a] [Phenotype a] -> [Phenotype a]
asPopulation Either [Genome a] [Phenotype a]
x))
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
runhook Double
_ Int
_ Either [Genome a] [Phenotype a]
_ (StopWhen IO Bool
iotest) = IO Bool
iotest
runhook Double
start Int
_ Either [Genome a] [Phenotype a]
_ (TimeLimit Double
limit) = do
Double
now <- POSIXTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (POSIXTime -> Double) -> IO POSIXTime -> IO Double
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` IO POSIXTime
getPOSIXTime
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Double
now Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
start Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
limit)
dummyObjective :: Genome a -> Phenotype a
dummyObjective :: Genome a -> Phenotype a
dummyObjective Genome a
g = (Genome a
g, Double
0.0)
asPopulation :: Either [Genome a] [Phenotype a] -> [Phenotype a]
asPopulation = ([Genome a] -> [Phenotype a])
-> ([Phenotype a] -> [Phenotype a])
-> Either [Genome a] [Phenotype a]
-> [Phenotype a]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((Genome a -> Phenotype a) -> [Genome a] -> [Phenotype a]
forall a b. (a -> b) -> [a] -> [b]
map Genome a -> Phenotype a
forall a. Genome a -> Phenotype a
dummyObjective) [Phenotype a] -> [Phenotype a]
forall a. a -> a
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 { IOHook a -> Int
io'n :: Int, IOHook a -> Int -> Population a -> IO ()
io'action :: (Int -> Population a -> IO ()) }
| StopWhen (IO Bool)
| TimeLimit { IOHook a -> Double
io't :: Double }