{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, GADTs, ExistentialQuantification #-}

module Moo.GeneticAlgorithm.Types
    (
    -- * Data structures

      Genome
    , Objective
    , Phenotype
    , Population
    , GenomeState(..)
    , takeObjectiveValue
    -- * GA operators

    , ProblemType (..)
    , ObjectiveFunction(..)
    , SelectionOp
    , CrossoverOp
    , MutationOp
    -- * Dummy operators

    , noMutation
    , noCrossover
    -- * Life cycle

    , StepGA
    , Cond(..)
    , PopulationState
    , StepResult(..)
    ) where

import Moo.GeneticAlgorithm.Random
import Control.Parallel.Strategies (parMap, rseq)

-- | A genetic representation of an individual solution.

type Genome a = [a]

-- | A measure of the observed performance. It may be called cost

-- for minimization problems, or fitness for maximization problems.

type Objective = Double

-- | A genome associated with its observed 'Objective' value.

type Phenotype a = (Genome a, Objective)

-- | An entire population of observed 'Phenotype's.

type Population a = [Phenotype a]


-- | 'takeGenome' extracts a raw genome from any type which embeds it.

class GenomeState gt a where
    takeGenome :: gt -> Genome a


instance (a1 ~ a2) => GenomeState (Genome a1) a2 where
    takeGenome :: Genome a1 -> Genome a2
takeGenome = Genome a1 -> Genome a2
forall a. a -> a
id


instance (a1 ~ a2) => GenomeState (Phenotype a1) a2 where
    takeGenome :: Phenotype a1 -> Genome a2
takeGenome = Phenotype a1 -> Genome a2
forall a b. (a, b) -> a
fst


takeObjectiveValue :: Phenotype a -> Objective
takeObjectiveValue :: Phenotype a -> Objective
takeObjectiveValue = Phenotype a -> Objective
forall a b. (a, b) -> b
snd

-- | A type of optimization problem: whether the objective function

-- has to be miminized, or maximized.

data ProblemType = Minimizing | Maximizing deriving (Int -> ProblemType -> ShowS
[ProblemType] -> ShowS
ProblemType -> String
(Int -> ProblemType -> ShowS)
-> (ProblemType -> String)
-> ([ProblemType] -> ShowS)
-> Show ProblemType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProblemType] -> ShowS
$cshowList :: [ProblemType] -> ShowS
show :: ProblemType -> String
$cshow :: ProblemType -> String
showsPrec :: Int -> ProblemType -> ShowS
$cshowsPrec :: Int -> ProblemType -> ShowS
Show, ProblemType -> ProblemType -> Bool
(ProblemType -> ProblemType -> Bool)
-> (ProblemType -> ProblemType -> Bool) -> Eq ProblemType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ProblemType -> ProblemType -> Bool
$c/= :: ProblemType -> ProblemType -> Bool
== :: ProblemType -> ProblemType -> Bool
$c== :: ProblemType -> ProblemType -> Bool
Eq)

-- | A function to evaluate a genome should be an instance of

-- 'ObjectiveFunction' class. It may be called a cost function for

-- minimization problems, or a fitness function for maximization

-- problems.

--

-- Some genetic algorithm operators, like 'rouletteSelect', require

-- the 'Objective' to be non-negative.

class ObjectiveFunction f a where
    evalObjective :: f -> [Genome a] -> Population a

-- | Evaluate fitness (cost) values genome per genome in parallel.

instance (a1 ~ a2) =>
    ObjectiveFunction (Genome a1 -> Objective) a2 where
        evalObjective :: (Genome a1 -> Objective) -> [Genome a2] -> Population a2
evalObjective Genome a1 -> Objective
f [Genome a2]
gs = Strategy (Genome a1, Objective)
-> (Genome a1 -> (Genome a1, Objective))
-> [Genome a1]
-> [(Genome a1, Objective)]
forall b a. Strategy b -> (a -> b) -> [a] -> [b]
parMap Strategy (Genome a1, Objective)
forall a. Strategy a
rseq (\Genome a1
g -> (Genome a1
g, Genome a1 -> Objective
f Genome a1
g)) [Genome a1]
[Genome a2]
gs

-- | Evaluate all fitness (cost) values at once.

instance (a1 ~ a2) =>
    ObjectiveFunction ([Genome a1] -> [Objective]) a2 where
        evalObjective :: ([Genome a1] -> [Objective]) -> [Genome a2] -> Population a2
evalObjective [Genome a1] -> [Objective]
f [Genome a2]
gs = [Genome a2] -> [Objective] -> Population a2
forall a b. [a] -> [b] -> [(a, b)]
zip [Genome a2]
gs ([Genome a1] -> [Objective]
f [Genome a1]
[Genome a2]
gs)

-- | Evaluate fitness (cost) of all genomes, possibly changing their

-- order.

instance (a1 ~ a2) =>
    ObjectiveFunction ([Genome a1] -> [(Genome a1, Objective)]) a2 where
        evalObjective :: ([Genome a1] -> [(Genome a1, Objective)])
-> [Genome a2] -> Population a2
evalObjective [Genome a1] -> [(Genome a1, Objective)]
f [Genome a2]
gs = [Genome a1] -> [(Genome a1, Objective)]
f [Genome a1]
[Genome a2]
gs

-- | A selection operator selects a subset (probably with repetition)

-- of genomes for reproduction via crossover and mutation.

type SelectionOp a = Population a -> Rand (Population a)

-- | A crossover operator takes some /parent/ genomes and returns some

-- /children/ along with the remaining parents. Many crossover

-- operators use only two parents, but some require three (like UNDX)

-- or more. Crossover operator should consume as many parents as

-- necessary and stop when the list of parents is empty.

type CrossoverOp a = [Genome a] -> Rand ([Genome a], [Genome a])

-- | A mutation operator takes a genome and returns an altered copy of it.

type MutationOp a = Genome a -> Rand (Genome a)

-- | Don't crossover.

noCrossover :: CrossoverOp a
noCrossover :: CrossoverOp a
noCrossover [Genome a]
genomes = ([Genome a], [Genome a])
-> RandT PureMT Identity ([Genome a], [Genome a])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Genome a]
genomes, [])

-- | Don't mutate.

noMutation :: MutationOp a
noMutation :: MutationOp a
noMutation = MutationOp a
forall (m :: * -> *) a. Monad m => a -> m a
return


-- | A single step of the genetic algorithm. See also 'nextGeneration'.

type StepGA m a = Cond a              -- ^ stop condition

                -> PopulationState a  -- ^ population of the current generation

                -> m (StepResult (Population a))  -- ^ population of the next generation



-- | Iterations stop when the condition evaluates as @True@.

data Cond a =
      Generations Int                   -- ^ stop after @n@ generations

    | IfObjective ([Objective] -> Bool) -- ^ stop when objective values satisfy the @predicate@

    | forall b . Eq b => GensNoChange
      { Cond a -> Int
c'maxgens ::  Int                 -- ^ max number of generations for an indicator to be the same

      , ()
c'indicator ::  [Objective] -> b  -- ^ stall indicator function

      , ()
c'counter :: Maybe (b, Int)       -- ^ a counter (initially @Nothing@)

      }                                 -- ^ terminate when evolution stalls

    | Or (Cond a) (Cond a)              -- ^ stop when at least one of two conditions holds

    | And (Cond a) (Cond a)             -- ^ stop when both conditions hold



{-| On life cycle of the genetic algorithm:

>
>   [ start ]
>       |
>       v
>   (genomes) --> [calculate objective] --> (evaluated genomes) --> [ stop ]
>       ^  ^                                       |
>       |  |                                       |
>       |  `-----------.                           |
>       |               \                          v
>   [ mutate ]        (elite) <-------------- [ select ]
>       ^                                          |
>       |                                          |
>       |                                          |
>       |                                          v
>   (genomes) <----- [ crossover ] <-------- (evaluted genomes)
>

PopulationState can represent either @genomes@ or @evaluated genomed@.
-}
type PopulationState a = Either [Genome a] [Phenotype a]


-- | A data type to distinguish the last and intermediate steps results.

data StepResult a = StopGA a | ContinueGA a deriving (Int -> StepResult a -> ShowS
[StepResult a] -> ShowS
StepResult a -> String
(Int -> StepResult a -> ShowS)
-> (StepResult a -> String)
-> ([StepResult a] -> ShowS)
-> Show (StepResult a)
forall a. Show a => Int -> StepResult a -> ShowS
forall a. Show a => [StepResult a] -> ShowS
forall a. Show a => StepResult a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StepResult a] -> ShowS
$cshowList :: forall a. Show a => [StepResult a] -> ShowS
show :: StepResult a -> String
$cshow :: forall a. Show a => StepResult a -> String
showsPrec :: Int -> StepResult a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> StepResult a -> ShowS
Show)