module Moo.GeneticAlgorithm.Constraints
    (
      ConstraintFunction
    , Constraint()
    , isFeasible
    -- *** Simple equalities and inequalities

    , (.<.), (.<=.), (.>.), (.>=.), (.==.)
    -- *** Double inequalities

    , LeftHandSideInequality()
    , (.<), (.<=), (<.), (<=.)
    -- ** Constrained initalization

    , getConstrainedGenomes
    , getConstrainedBinaryGenomes
    -- ** Constrained selection

    , withDeathPenalty
    , withFinalDeathPenalty
    , withConstraints
    , numberOfViolations
    , degreeOfViolation
    ) where


import Moo.GeneticAlgorithm.Types
import Moo.GeneticAlgorithm.Random
import Moo.GeneticAlgorithm.Utilities (getRandomGenomes)
import Moo.GeneticAlgorithm.Selection (withPopulationTransform, bestFirst)


type ConstraintFunction a b = Genome a -> b


-- Defining a constraint as a pair of function and its boundary value

-- (vs just a boolean valued function) allows for estimating the

-- degree of constraint violation when necessary.


-- | Define constraints using '.<.', '.<=.', '.>.', '.>=.', and '.==.'

-- operators, with a 'ConstraintFunction' on the left hand side.

--

-- For double inequality constraints use pairs of '.<', '<.' and

-- '.<=', '<=.' respectively, with a 'ConstraintFunction' in the middle.

--

-- Examples:

--

-- @

-- function .>=. lowerBound

-- lowerBound .<= function <=. upperBound

-- @

data Constraint a b
    = LessThan (ConstraintFunction a b) b
    -- ^ strict inequality constraint,

    -- function value is less than the constraint value

    | LessThanOrEqual (ConstraintFunction a b) b
    -- ^ non-strict inequality constraint,

    -- function value is less than or equal to the constraint value

    | Equal (ConstraintFunction a b) b
    -- ^ equality constraint,

    -- function value is equal to the constraint value

    | InInterval (ConstraintFunction a b) (Bool, b) (Bool, b)
    -- ^ double inequality, boolean flags indicate if the

    -- bound is inclusive.



(.<.) :: (Real b) => ConstraintFunction a b -> b -> Constraint a b
.<. :: ConstraintFunction a b -> b -> Constraint a b
(.<.) = ConstraintFunction a b -> b -> Constraint a b
forall a b. ConstraintFunction a b -> b -> Constraint a b
LessThan

(.<=.) :: (Real b) => ConstraintFunction a b -> b -> Constraint a b
.<=. :: ConstraintFunction a b -> b -> Constraint a b
(.<=.) = ConstraintFunction a b -> b -> Constraint a b
forall a b. ConstraintFunction a b -> b -> Constraint a b
LessThanOrEqual

(.>.) :: (Real b) => ConstraintFunction a b -> b -> Constraint a b
.>. :: ConstraintFunction a b -> b -> Constraint a b
(.>.) ConstraintFunction a b
f b
v = ConstraintFunction a b -> b -> Constraint a b
forall a b. ConstraintFunction a b -> b -> Constraint a b
LessThan (b -> b
forall a. Num a => a -> a
negate (b -> b) -> ConstraintFunction a b -> ConstraintFunction a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstraintFunction a b
f) (b -> b
forall a. Num a => a -> a
negate b
v)

(.>=.) :: (Real b) => ConstraintFunction a b -> b -> Constraint a b
.>=. :: ConstraintFunction a b -> b -> Constraint a b
(.>=.) ConstraintFunction a b
f b
v = ConstraintFunction a b -> b -> Constraint a b
forall a b. ConstraintFunction a b -> b -> Constraint a b
LessThanOrEqual (b -> b
forall a. Num a => a -> a
negate (b -> b) -> ConstraintFunction a b -> ConstraintFunction a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstraintFunction a b
f) (b -> b
forall a. Num a => a -> a
negate b
v)

(.==.) :: (Real b) => ConstraintFunction a b -> b -> Constraint a b
.==. :: ConstraintFunction a b -> b -> Constraint a b
(.==.) = ConstraintFunction a b -> b -> Constraint a b
forall a b. ConstraintFunction a b -> b -> Constraint a b
Equal


-- Left hand side of the double inequality defined in the form:

-- @lowerBound .<= function <=. upperBound@.

data LeftHandSideInequality a b
    = LeftHandSideInequality (ConstraintFunction a b) (Bool, b)
    -- ^ boolean flag indicates if the bound is inclusive


(.<=) :: (Real b) => b -> ConstraintFunction a b -> LeftHandSideInequality a b
b
lval .<= :: b -> ConstraintFunction a b -> LeftHandSideInequality a b
.<= ConstraintFunction a b
f = ConstraintFunction a b -> (Bool, b) -> LeftHandSideInequality a b
forall a b.
ConstraintFunction a b -> (Bool, b) -> LeftHandSideInequality a b
LeftHandSideInequality ConstraintFunction a b
f (Bool
True, b
lval)

(.<) :: (Real b) => b -> ConstraintFunction a b -> LeftHandSideInequality a b
b
lval .< :: b -> ConstraintFunction a b -> LeftHandSideInequality a b
.< ConstraintFunction a b
f  = ConstraintFunction a b -> (Bool, b) -> LeftHandSideInequality a b
forall a b.
ConstraintFunction a b -> (Bool, b) -> LeftHandSideInequality a b
LeftHandSideInequality ConstraintFunction a b
f (Bool
False, b
lval)

(<.) :: (Real b) => LeftHandSideInequality a b -> b -> Constraint a b
(LeftHandSideInequality ConstraintFunction a b
f (Bool, b)
l) <. :: LeftHandSideInequality a b -> b -> Constraint a b
<. b
rval  = ConstraintFunction a b -> (Bool, b) -> (Bool, b) -> Constraint a b
forall a b.
ConstraintFunction a b -> (Bool, b) -> (Bool, b) -> Constraint a b
InInterval ConstraintFunction a b
f (Bool, b)
l (Bool
False, b
rval)

(<=.) :: (Real b) => LeftHandSideInequality a b -> b -> Constraint a b
(LeftHandSideInequality ConstraintFunction a b
f (Bool, b)
l) <=. :: LeftHandSideInequality a b -> b -> Constraint a b
<=. b
rval = ConstraintFunction a b -> (Bool, b) -> (Bool, b) -> Constraint a b
forall a b.
ConstraintFunction a b -> (Bool, b) -> (Bool, b) -> Constraint a b
InInterval ConstraintFunction a b
f (Bool, b)
l (Bool
True,  b
rval)



-- | Returns @True@ if a @genome@ represents a feasible solution

-- with respect to the @constraint@.

satisfiesConstraint :: (Real b)
          => Genome a        -- ^ @genome@

          -> Constraint a b  -- ^ @constraint@

          -> Bool
satisfiesConstraint :: Genome a -> Constraint a b -> Bool
satisfiesConstraint Genome a
g (LessThan ConstraintFunction a b
f b
v)  = ConstraintFunction a b
f Genome a
g b -> b -> Bool
forall a. Ord a => a -> a -> Bool
< b
v
satisfiesConstraint Genome a
g (LessThanOrEqual ConstraintFunction a b
f b
v) = ConstraintFunction a b
f Genome a
g b -> b -> Bool
forall a. Ord a => a -> a -> Bool
<= b
v
satisfiesConstraint Genome a
g (Equal ConstraintFunction a b
f b
v) = ConstraintFunction a b
f Genome a
g b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
v
satisfiesConstraint Genome a
g (InInterval ConstraintFunction a b
f (Bool
inclusive1,b
v1) (Bool
inclusive2,b
v2)) =
    let v' :: b
v' = ConstraintFunction a b
f Genome a
g
        c1 :: Bool
c1 = if Bool
inclusive1 then b
v1 b -> b -> Bool
forall a. Ord a => a -> a -> Bool
<= b
v' else b
v1 b -> b -> Bool
forall a. Ord a => a -> a -> Bool
< b
v'
        c2 :: Bool
c2 = if Bool
inclusive2 then b
v' b -> b -> Bool
forall a. Ord a => a -> a -> Bool
<= b
v2 else b
v' b -> b -> Bool
forall a. Ord a => a -> a -> Bool
< b
v2
    in  Bool
c1 Bool -> Bool -> Bool
&& Bool
c2



-- | Returns @True@ if a @genome@ represents a feasible solution,

-- i.e. satisfies all @constraints@.

isFeasible :: (GenomeState gt a, Real b)
           => [Constraint a b]  -- ^ constraints

           -> gt                -- ^ genome

           -> Bool
isFeasible :: [Constraint a b] -> gt -> Bool
isFeasible [Constraint a b]
constraints gt
genome = (Constraint a b -> Bool) -> [Constraint a b] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((gt -> Genome a
forall gt a. GenomeState gt a => gt -> Genome a
takeGenome gt
genome) Genome a -> Constraint a b -> Bool
forall b a. Real b => Genome a -> Constraint a b -> Bool
`satisfiesConstraint`) [Constraint a b]
constraints


-- | Generate @n@ feasible random genomes with individual genome elements

-- bounded by @ranges@.

getConstrainedGenomes :: (Random a, Ord a, Real b)
    => [Constraint a b]   -- ^ constraints

    -> Int                -- ^ @n@, how many genomes to generate

    -> [(a, a)]           -- ^ ranges for individual genome elements

    -> Rand ([Genome a])  -- ^ random feasible genomes

getConstrainedGenomes :: [Constraint a b] -> Int -> [(a, a)] -> Rand [Genome a]
getConstrainedGenomes [Constraint a b]
constraints Int
n [(a, a)]
ranges
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0            = [Genome a] -> Rand [Genome a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  | Bool
otherwise         = do
  [Genome a]
candidates <- Int -> [(a, a)] -> Rand [Genome a]
forall a. (Random a, Ord a) => Int -> [(a, a)] -> Rand [Genome a]
getRandomGenomes Int
n [(a, a)]
ranges
  let feasible :: [Genome a]
feasible = (Genome a -> Bool) -> [Genome a] -> [Genome a]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Constraint a b] -> Genome a -> Bool
forall gt a b.
(GenomeState gt a, Real b) =>
[Constraint a b] -> gt -> Bool
isFeasible [Constraint a b]
constraints) [Genome a]
candidates
  let found :: Int
found = [Genome a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Genome a]
feasible
  [Genome a]
more <- [Constraint a b] -> Int -> [(a, a)] -> Rand [Genome a]
forall a b.
(Random a, Ord a, Real b) =>
[Constraint a b] -> Int -> [(a, a)] -> Rand [Genome a]
getConstrainedGenomes [Constraint a b]
constraints (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
found) [(a, a)]
ranges
  [Genome a] -> Rand [Genome a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Genome a] -> Rand [Genome a]) -> [Genome a] -> Rand [Genome a]
forall a b. (a -> b) -> a -> b
$ [Genome a]
feasible [Genome a] -> [Genome a] -> [Genome a]
forall a. [a] -> [a] -> [a]
++ [Genome a]
more


-- | Generate @n@ feasible random binary genomes.

getConstrainedBinaryGenomes :: (Real b)
    => [Constraint Bool b]  -- ^ constraints

    -> Int                  -- ^ @n@, how many genomes to generate

    -> Int                  -- ^ @L@, genome length

    -> Rand [Genome Bool]   -- ^ random feasible genomes

getConstrainedBinaryGenomes :: [Constraint Bool b] -> Int -> Int -> Rand [Genome Bool]
getConstrainedBinaryGenomes [Constraint Bool b]
constraints Int
n Int
len =
    [Constraint Bool b] -> Int -> [(Bool, Bool)] -> Rand [Genome Bool]
forall a b.
(Random a, Ord a, Real b) =>
[Constraint a b] -> Int -> [(a, a)] -> Rand [Genome a]
getConstrainedGenomes [Constraint Bool b]
constraints Int
n (Int -> (Bool, Bool) -> [(Bool, Bool)]
forall a. Int -> a -> [a]
replicate Int
len (Bool
False,Bool
True))


-- | A simple estimate of the degree of (in)feasibility.

--

-- Count the number of constraint violations. Return @0@ if the solution is feasible.

numberOfViolations :: (Real b)
                   => [Constraint a b]  -- ^ constraints

                   -> Genome a  -- ^ genome

                   -> Int  -- ^ the number of violated constraints

numberOfViolations :: [Constraint a b] -> Genome a -> Int
numberOfViolations [Constraint a b]
constraints Genome a
genome =
    let satisfied :: Genome Bool
satisfied = (Constraint a b -> Bool) -> [Constraint a b] -> Genome Bool
forall a b. (a -> b) -> [a] -> [b]
map (Genome a
genome Genome a -> Constraint a b -> Bool
forall b a. Real b => Genome a -> Constraint a b -> Bool
`satisfiesConstraint`) [Constraint a b]
constraints
    in  Genome Bool -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Genome Bool -> Int) -> Genome Bool -> Int
forall a b. (a -> b) -> a -> b
$ (Bool -> Bool) -> Genome Bool -> Genome Bool
forall a. (a -> Bool) -> [a] -> [a]
filter Bool -> Bool
not Genome Bool
satisfied


-- | An estimate of the degree of (in)feasibility.

--

-- Given @f_j@ is the excess of @j@-th constraint function value,

-- return @sum |f_j|^beta@.  For strict inequality constraints, return

-- @sum (|f_j|^beta + eta)@.  Return @0.0@ if the solution is

-- feasible.

--

degreeOfViolation :: Double  -- ^ beta, single violation exponent

                  -> Double  -- ^ eta, equality penalty in strict inequalities

                  -> [Constraint a Double] -- ^ constrains

                  -> Genome a  -- ^ genome

                  -> Double    -- ^ total degree of violation

degreeOfViolation :: Double -> Double -> [Constraint a Double] -> Genome a -> Double
degreeOfViolation Double
beta Double
eta [Constraint a Double]
constraints Genome a
genome =
    [Double] -> Double
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Double] -> Double) -> [Double] -> Double
forall a b. (a -> b) -> a -> b
$ (Constraint a Double -> Double)
-> [Constraint a Double] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map Constraint a Double -> Double
violation [Constraint a Double]
constraints
  where
    violation :: Constraint a Double -> Double
violation (LessThan Genome a -> Double
f Double
v) =
        let v' :: Double
v' = Genome a -> Double
f Genome a
genome
        in  if Double
v' Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
v
            then Double
0.0
            else (Double -> Double
forall a. Num a => a -> a
abs (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double
v' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
v) Double -> Double -> Double
forall a. Floating a => a -> a -> a
** Double
beta Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
eta
    violation (LessThanOrEqual Genome a -> Double
f Double
v) =
        let v' :: Double
v' = Genome a -> Double
f Genome a
genome
        in  if Double
v' Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
v
            then Double
0.0
            else (Double -> Double
forall a. Num a => a -> a
abs (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double
v' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
v) Double -> Double -> Double
forall a. Floating a => a -> a -> a
** Double
beta
    violation (Equal Genome a -> Double
f Double
v) =
        let v' :: Double
v' = Genome a -> Double
f Genome a
genome
        in  if Double
v' Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
v
            then Double
0.0
            else (Double -> Double
forall a. Num a => a -> a
abs (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double
v' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
v) Double -> Double -> Double
forall a. Floating a => a -> a -> a
** Double
beta
    violation (InInterval Genome a -> Double
f (Bool
incleft, Double
l) (Bool
incright, Double
r)) =
        let v' :: Double
v' = Genome a -> Double
f Genome a
genome
            leftok :: Bool
leftok = if Bool
incleft
                     then Double
l Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
v'
                     else Double
l Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
v'
            rightok :: Bool
rightok = if Bool
incright
                      then Double
r Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
v'
                      else Double
r Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
v'
        in  case (Bool
leftok, Bool
rightok) of
            (Bool
True, Bool
True) -> Double
0.0
            (Bool
False, Bool
_)   -> (Double -> Double
forall a. Num a => a -> a
abs (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double
l Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
v') Double -> Double -> Double
forall a. Floating a => a -> a -> a
** Double
beta
                            Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> (Bool -> Int) -> Bool -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> Int) -> (Bool -> Bool) -> Bool -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Double) -> Bool -> Double
forall a b. (a -> b) -> a -> b
$ Bool
incleft) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
eta
            (Bool
_, Bool
False)   -> (Double -> Double
forall a. Num a => a -> a
abs (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double
v' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
r) Double -> Double -> Double
forall a. Floating a => a -> a -> a
** Double
beta
                            Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> (Bool -> Int) -> Bool -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> Int) -> (Bool -> Bool) -> Bool -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Double) -> Bool -> Double
forall a b. (a -> b) -> a -> b
$ Bool
incright) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
eta


-- | Modify objective function in such a way that 1) any feasible

-- solution is preferred to any infeasible solution, 2) among two

-- feasible solutions the one having better objective function value

-- is preferred, 3) among two infeasible solution the one having

-- smaller constraint violation is preferred.

--

-- Reference: Deb, K. (2000). An efficient constraint handling method

-- for genetic algorithms. Computer methods in applied mechanics and

-- engineering, 186(2), 311-338.

withConstraints :: (Real b, Real c)
    => [Constraint a b]                      -- ^ constraints

    -> ([Constraint a b] -> Genome a -> c)   -- ^ non-negative degree of violation,

                                             -- see 'numberOfViolations' and 'degreeOfViolation'

    -> ProblemType
    -> SelectionOp a
    -> SelectionOp a
withConstraints :: [Constraint a b]
-> ([Constraint a b] -> Genome a -> c)
-> ProblemType
-> SelectionOp a
-> SelectionOp a
withConstraints [Constraint a b]
constraints [Constraint a b] -> Genome a -> c
violation ProblemType
ptype =
    (Population a -> Population a) -> SelectionOp a -> SelectionOp a
forall a.
(Population a -> Population a) -> SelectionOp a -> SelectionOp a
withPopulationTransform ([Constraint a b]
-> ([Constraint a b] -> Genome a -> c)
-> ProblemType
-> Population a
-> Population a
forall b c a.
(Real b, Real c) =>
[Constraint a b]
-> ([Constraint a b] -> Genome a -> c)
-> ProblemType
-> Population a
-> Population a
penalizeInfeasible [Constraint a b]
constraints [Constraint a b] -> Genome a -> c
violation ProblemType
ptype)


penalizeInfeasible :: (Real b, Real c)
    => [Constraint a b]
    -> ([Constraint a b] -> Genome a -> c)
    -> ProblemType
    -> Population a
    -> Population a
penalizeInfeasible :: [Constraint a b]
-> ([Constraint a b] -> Genome a -> c)
-> ProblemType
-> Population a
-> Population a
penalizeInfeasible [Constraint a b]
constraints [Constraint a b] -> Genome a -> c
violation ProblemType
ptype Population a
phenotypes =
        let worst :: Double
worst = Phenotype a -> Double
forall a. Phenotype a -> Double
takeObjectiveValue (Phenotype a -> Double)
-> (Population a -> Phenotype a) -> Population a -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Population a -> Phenotype a
forall a. [a] -> a
head (Population a -> Phenotype a)
-> (Population a -> Population a) -> Population a -> Phenotype a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProblemType -> Population a -> Population a
forall a. ProblemType -> Population a -> Population a
worstFirst ProblemType
ptype (Population a -> Double) -> Population a -> Double
forall a b. (a -> b) -> a -> b
$ Population a
phenotypes
            penalize :: Phenotype a -> Phenotype a
penalize Phenotype a
p = let g :: Genome a
g = Phenotype a -> Genome a
forall gt a. GenomeState gt a => gt -> Genome a
takeGenome Phenotype a
p
                             v :: Double
v = Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double)
-> (Genome a -> Rational) -> Genome a -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> Rational
forall a. Real a => a -> Rational
toRational (c -> Rational) -> (Genome a -> c) -> Genome a -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Constraint a b] -> Genome a -> c
violation [Constraint a b]
constraints (Genome a -> Double) -> Genome a -> Double
forall a b. (a -> b) -> a -> b
$ Genome a
g
                         in  if (Double
v Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0)
                             then (Genome a
g, Double
worst Double -> Double -> Double
forall a. Num a => a -> a -> a
`worsen` Double
v)
                             else Phenotype a
p
        in  (Phenotype a -> Phenotype a) -> Population a -> Population a
forall a b. (a -> b) -> [a] -> [b]
map Phenotype a -> Phenotype a
penalize Population a
phenotypes
   where
    worstFirst :: ProblemType -> Population a -> Population a
worstFirst ProblemType
Minimizing = ProblemType -> Population a -> Population a
forall a. ProblemType -> Population a -> Population a
bestFirst ProblemType
Maximizing
    worstFirst ProblemType
Maximizing = ProblemType -> Population a -> Population a
forall a. ProblemType -> Population a -> Population a
bestFirst ProblemType
Minimizing

    worsen :: a -> a -> a
worsen a
x a
delta = if ProblemType
ptype ProblemType -> ProblemType -> Bool
forall a. Eq a => a -> a -> Bool
== ProblemType
Minimizing
                     then a
x a -> a -> a
forall a. Num a => a -> a -> a
+ a
delta
                     else a
x a -> a -> a
forall a. Num a => a -> a -> a
- a
delta


-- | Kill all infeasible solutions after every step of the genetic algorithm.

--

-- “Death penalty is very popular within the evolution strategies community,

-- but it is limited to problems in which the feasible search space is convex

-- and constitutes a reasonably large portion of the whole search space,” --

-- (Coello 1999).

--

-- Coello, C. A. C., & Carlos, A. (1999). A survey of constraint

-- handling techniques used with evolutionary algorithms.

-- Lania-RI-99-04, Laboratorio Nacional de Informática Avanzada.

withDeathPenalty :: (Monad m, Real b)
                 => [Constraint a b]  -- ^ constraints

                 -> StepGA m a        -- ^ unconstrained step

                 -> StepGA m a        -- ^ constrained step

withDeathPenalty :: [Constraint a b] -> StepGA m a -> StepGA m a
withDeathPenalty [Constraint a b]
cs StepGA m a
step =
    \Cond a
stop PopulationState a
popstate -> do
      StepResult (Population a)
stepresult <- StepGA m a
step Cond a
stop PopulationState a
popstate
      case StepResult (Population a)
stepresult of
        StopGA Population a
pop -> StepResult (Population a) -> m (StepResult (Population a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Population a -> StepResult (Population a)
forall a. a -> StepResult a
StopGA ([Constraint a b] -> Population a -> Population a
forall b a.
Real b =>
[Constraint a b] -> Population a -> Population a
filterFeasible [Constraint a b]
cs Population a
pop))
        ContinueGA Population a
pop -> StepResult (Population a) -> m (StepResult (Population a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Population a -> StepResult (Population a)
forall a. a -> StepResult a
ContinueGA ([Constraint a b] -> Population a -> Population a
forall b a.
Real b =>
[Constraint a b] -> Population a -> Population a
filterFeasible [Constraint a b]
cs Population a
pop))


-- | Kill all infeasible solutions once after the last step of the

-- genetic algorithm. See also 'withDeathPenalty'.

withFinalDeathPenalty :: (Monad m, Real b)
                      => [Constraint a b]  -- ^ constriants

                      -> StepGA m a        -- ^ unconstrained step

                      -> StepGA m a        -- ^ constrained step

withFinalDeathPenalty :: [Constraint a b] -> StepGA m a -> StepGA m a
withFinalDeathPenalty [Constraint a b]
cs StepGA m a
step =
    \Cond a
stop PopulationState a
popstate -> do
      StepResult (Population a)
result <- StepGA m a
step Cond a
stop PopulationState a
popstate
      case StepResult (Population a)
result of
        (ContinueGA Population a
_) -> StepResult (Population a) -> m (StepResult (Population a))
forall (m :: * -> *) a. Monad m => a -> m a
return StepResult (Population a)
result
        (StopGA Population a
pop) -> StepResult (Population a) -> m (StepResult (Population a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Population a -> StepResult (Population a)
forall a. a -> StepResult a
StopGA ([Constraint a b] -> Population a -> Population a
forall b a.
Real b =>
[Constraint a b] -> Population a -> Population a
filterFeasible [Constraint a b]
cs Population a
pop))


filterFeasible :: (Real b) => [Constraint a b] -> Population a -> Population a
filterFeasible :: [Constraint a b] -> Population a -> Population a
filterFeasible [Constraint a b]
cs = (Phenotype a -> Bool) -> Population a -> Population a
forall a. (a -> Bool) -> [a] -> [a]
filter ([Constraint a b] -> Genome a -> Bool
forall gt a b.
(GenomeState gt a, Real b) =>
[Constraint a b] -> gt -> Bool
isFeasible [Constraint a b]
cs (Genome a -> Bool)
-> (Phenotype a -> Genome a) -> Phenotype a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Phenotype a -> Genome a
forall gt a. GenomeState gt a => gt -> Genome a
takeGenome)