module Moo.GeneticAlgorithm.Constraints
(
ConstraintFunction
, Constraint()
, isFeasible
, (.<.), (.<=.), (.>.), (.>=.), (.==.)
, LeftHandSideInequality()
, (.<), (.<=), (<.), (<=.)
, getConstrainedGenomes
, getConstrainedBinaryGenomes
, 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
data Constraint a b
= LessThan (ConstraintFunction a b) b
| LessThanOrEqual (ConstraintFunction a b) b
| Equal (ConstraintFunction a b) b
| InInterval (ConstraintFunction a b) (Bool, b) (Bool, b)
(.<.) :: (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
data LeftHandSideInequality a b
= LeftHandSideInequality (ConstraintFunction a b) (Bool, b)
(.<=) :: (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)
satisfiesConstraint :: (Real b)
=> Genome a
-> Constraint a b
-> 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
isFeasible :: (GenomeState gt a, Real b)
=> [Constraint a b]
-> gt
-> 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
getConstrainedGenomes :: (Random a, Ord a, Real b)
=> [Constraint a b]
-> Int
-> [(a, a)]
-> Rand ([Genome a])
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
getConstrainedBinaryGenomes :: (Real b)
=> [Constraint Bool b]
-> Int
-> Int
-> Rand [Genome Bool]
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))
numberOfViolations :: (Real b)
=> [Constraint a b]
-> Genome a
-> Int
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
degreeOfViolation :: Double
-> Double
-> [Constraint a Double]
-> Genome a
-> Double
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
withConstraints :: (Real b, Real c)
=> [Constraint a b]
-> ([Constraint a b] -> Genome a -> c)
-> 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
withDeathPenalty :: (Monad m, Real b)
=> [Constraint a b]
-> StepGA m a
-> StepGA m a
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))
withFinalDeathPenalty :: (Monad m, Real b)
=> [Constraint a b]
-> StepGA m a
-> StepGA m a
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)