{-# LANGUAGE BangPatterns, Rank2Types #-}
{-# LANGUAGE GADTs #-}
{- |

Helper functions to run genetic algorithms and control iterations.

-}

module Moo.GeneticAlgorithm.Run (
  -- * Running algorithm

    runGA
  , runIO
  , nextGeneration
  , nextSteadyState
  , makeStoppable
  -- * Iteration control

  , 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)

-- | Helper function to run the entire algorithm in the 'Rand' monad.

-- It takes care of generating a new random number generator.

runGA :: Rand [Genome a]             -- ^ function to create initial population

      -> ([Genome a] -> Rand b)       -- ^ genetic algorithm, see also 'loop' and 'loopWithLog'

      -> IO b                        -- ^ final population

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'

-- | Helper function to run the entire algorithm in the 'IO' monad.

runIO :: Rand [Genome a]                  -- ^ function to create initial population

      -> (IORef PureMT -> [Genome a] -> IO (Population a))
                                          -- ^ genetic algorithm, see also 'loopIO'

      -> IO (Population a)                -- ^ final population

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

-- | Construct a single step of the genetic algorithm.

--

-- See "Moo.GeneticAlgorithm.Binary" and "Moo.GeneticAlgorithm.Continuous"

-- for the building blocks of the algorithm.

--

nextGeneration
    :: (ObjectiveFunction objectivefn a)
    => ProblemType          -- ^ a type of the optimization @problem@

    -> objectivefn          -- ^ objective function

    -> SelectionOp a        -- ^ selection operator

    -> Int                  -- ^ @elite@, the number of genomes to keep intact

    -> CrossoverOp a        -- ^ crossover operator

    -> MutationOp a         -- ^ mutation operator

    -> 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         -- just in case if @selectOp@ preserves order

    [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')


-- | Construct a single step of the incremental (steady-steate) genetic algorithm.

-- Exactly @n@ worst solutions are replaced with newly born children.

--

-- See "Moo.GeneticAlgorithm.Binary" and "Moo.GeneticAlgorithm.Continuous"

-- for the building blocks of the algorithm.

--

nextSteadyState
    :: (ObjectiveFunction objectivefn a)
    => Int                  -- ^ @n@, number of worst solutions to replace

    -> ProblemType          -- ^ a type of the optimization @problem@

    -> objectivefn          -- ^ objective function

    -> SelectionOp a        -- ^ selection operator

    -> CrossoverOp a        -- ^ crossover operator

    -> MutationOp a         -- ^ mutation operator

    -> 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


-- | Wrap a population transformation with pre- and post-conditions

-- to indicate the end of simulation.

--

-- Use this function to define custom replacement strategies

-- in addition to 'nextGeneration' and 'nextSteadyState'.

makeStoppable
    :: (ObjectiveFunction objectivefn a, Monad m)
    => objectivefn
    -> (Population a -> m (Population a))  -- single step

    -> 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   -- stop before the first iteration

     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


-- | Select @n@ best genomes, then select more genomes from the

-- /entire/ population (elite genomes inclusive). Elite genomes will

-- be the first in the list.

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

-- | Run strict iterations of the genetic algorithm defined by @step@.

-- Return the result of the last step.  Usually only the first two

-- arguments are given, and the result is passed to 'runGA'.

{-# INLINE loop #-}
loop :: (Monad m)
     => Cond a
     -- ^ termination condition @cond@

     -> StepGA m a
     -- ^ @step@ function to produce the next generation

     -> [Genome a]
     -- ^ initial population

     -> m (Population a)
      -- ^ final population

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)

-- | GA iteration interleaved with the same-monad logging hooks.

-- Usually only the first three arguments are given, and the result is

-- passed to 'runGA'.

{-# INLINE loopWithLog #-}
loopWithLog :: (Monad m, Monoid w)
     => LogHook a m w
     -- ^ periodic logging action

     -> Cond a
     -- ^ termination condition @cond@

     -> StepGA m a
     -- ^ @step@ function to produce the next generation

     -> [Genome a]
     -- ^ initial population

     -> m (Population a, w)
     -- ^ final population

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


-- | GA iteration interleaved with IO (for logging or saving the

-- intermediate results); it takes and returns the updated random

-- number generator via an IORef. Usually only the first three

-- arguments are given, and the result is passed to 'runIO'.

{-# INLINE loopIO #-}
loopIO
     :: [IOHook a]
     -- ^ input-output actions, special and time-dependent stop conditions

     -> Cond a
     -- ^ termination condition @cond@

     -> StepGA Rand a
     -- ^ @step@ function to produce the next generation

     -> IORef PureMT
     -- ^ reference to the random number generator

     -> [Genome a]
     -- ^ initial population @pop0@

     -> IO (Population a)
     -- ^ final population

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 returns True to terminate the loop

    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)

    -- assign dummy objective value to a genome

    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

-- | Logging to run every @n@th iteration starting from 0 (the first parameter).

-- The logging function takes the current generation count and population.

data LogHook a m w where
    WriteEvery :: (Monad m, Monoid w)
               => Int
               -> (Int -> Population a -> w)
               -> LogHook a m w

-- | Input-output actions, interactive and time-dependent stop conditions.

data IOHook a
    = DoEvery { IOHook a -> Int
io'n :: Int, IOHook a -> Int -> Population a -> IO ()
io'action :: (Int -> Population a -> IO ()) }
    -- ^ action to run every @n@th iteration, starting from 0;

    -- initially (at iteration 0) the objective value is zero.

    | StopWhen (IO Bool)
    -- ^ custom or interactive stop condition

    | TimeLimit { IOHook a -> Double
io't :: Double }
    -- ^ terminate iteration after @t@ seconds