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 (Real b) => 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
(.<.) = LessThan
(.<=.) :: (Real b) => ConstraintFunction a b -> b -> Constraint a b
(.<=.) = LessThanOrEqual
(.>.) :: (Real b) => ConstraintFunction a b -> b -> Constraint a b
(.>.) f v = LessThan (negate . f) (negate v)
(.>=.) :: (Real b) => ConstraintFunction a b -> b -> Constraint a b
(.>=.) f v = LessThanOrEqual (negate . f) (negate v)
(.==.) :: (Real b) => ConstraintFunction a b -> b -> Constraint a b
(.==.) = Equal
data (Real b) => LeftHandSideInequality a b
= LeftHandSideInequality (ConstraintFunction a b) (Bool, b)
(.<=) :: (Real b) => b -> ConstraintFunction a b -> LeftHandSideInequality a b
lval .<= f = LeftHandSideInequality f (True, lval)
(.<) :: (Real b) => b -> ConstraintFunction a b -> LeftHandSideInequality a b
lval .< f = LeftHandSideInequality f (False, lval)
(<.) :: (Real b) => LeftHandSideInequality a b -> b -> Constraint a b
(LeftHandSideInequality f l) <. rval = InInterval f l (False, rval)
(<=.) :: (Real b) => LeftHandSideInequality a b -> b -> Constraint a b
(LeftHandSideInequality f l) <=. rval = InInterval f l (True, rval)
satisfiesConstraint :: (Real b)
=> Genome a
-> Constraint a b
-> Bool
satisfiesConstraint g (LessThan f v) = f g < v
satisfiesConstraint g (LessThanOrEqual f v) = f g <= v
satisfiesConstraint g (Equal f v) = f g == v
satisfiesConstraint g (InInterval f (inclusive1,v1) (inclusive2,v2)) =
let v' = f g
c1 = if inclusive1 then v1 <= v' else v1 < v'
c2 = if inclusive2 then v' <= v2 else v' < v2
in c1 && c2
isFeasible :: (GenomeState gt a, Real b)
=> [Constraint a b]
-> gt
-> Bool
isFeasible constraints genome = all ((takeGenome genome) `satisfiesConstraint`) constraints
getConstrainedGenomes :: (Random a, Ord a, Real b)
=> [Constraint a b]
-> Int
-> [(a, a)]
-> Rand ([Genome a])
getConstrainedGenomes constraints n ranges
| n <= 0 = return []
| otherwise = do
candidates <- getRandomGenomes n ranges
let feasible = filter (isFeasible constraints) candidates
let found = length feasible
more <- getConstrainedGenomes constraints (n found) ranges
return $ feasible ++ more
getConstrainedBinaryGenomes :: (Real b)
=> [Constraint Bool b]
-> Int
-> Int
-> Rand [Genome Bool]
getConstrainedBinaryGenomes constraints n len =
getConstrainedGenomes constraints n (replicate len (False,True))
numberOfViolations :: (Real b)
=> [Constraint a b]
-> Genome a
-> Int
numberOfViolations constraints genome =
let satisfied = map (genome `satisfiesConstraint`) constraints
in length $ filter not satisfied
degreeOfViolation :: Double
-> Double
-> [Constraint a Double]
-> Genome a
-> Double
degreeOfViolation beta eta constraints genome =
sum $ map violation constraints
where
violation (LessThan f v) =
let v' = f genome
in if v' < v
then 0.0
else (abs $ v' v) ** beta + eta
violation (LessThanOrEqual f v) =
let v' = f genome
in if v' <= v
then 0.0
else (abs $ v' v) ** beta
violation (Equal f v) =
let v' = f genome
in if v' == v
then 0.0
else (abs $ v' v) ** beta
violation (InInterval f (incleft, l) (incright, r)) =
let v' = f genome
leftok = if incleft
then l <= v'
else l < v'
rightok = if incright
then r >= v'
else r > v'
in case (leftok, rightok) of
(True, True) -> 0.0
(False, _) -> (abs $ l v') ** beta
+ (fromIntegral . fromEnum . not $ incleft) * eta
(_, False) -> (abs $ v' r) ** beta
+ (fromIntegral . fromEnum . not $ incright) * eta
withConstraints :: (Real b, Real c)
=> [Constraint a b]
-> ([Constraint a b] -> Genome a -> c)
-> ProblemType
-> SelectionOp a
-> SelectionOp a
withConstraints constraints violation ptype =
withPopulationTransform (penalizeInfeasible constraints violation ptype)
penalizeInfeasible :: (Real b, Real c)
=> [Constraint a b]
-> ([Constraint a b] -> Genome a -> c)
-> ProblemType
-> Population a
-> Population a
penalizeInfeasible constraints violation ptype phenotypes =
let worst = takeObjectiveValue . head . worstFirst ptype $ phenotypes
penalize p = let g = takeGenome p
v = fromRational . toRational . violation constraints $ g
in if (v > 0)
then (g, worst `worsen` v)
else p
in map penalize phenotypes
where
worstFirst Minimizing = bestFirst Maximizing
worstFirst Maximizing = bestFirst Minimizing
worsen x delta = if ptype == Minimizing
then x + delta
else x delta
withDeathPenalty :: (Monad m, Real b)
=> [Constraint a b]
-> StepGA m a
-> StepGA m a
withDeathPenalty cs step =
\stop popstate -> do
stepresult <- step stop popstate
case stepresult of
StopGA pop -> return (StopGA (filterFeasible cs pop))
ContinueGA pop -> return (ContinueGA (filterFeasible cs pop))
withFinalDeathPenalty :: (Monad m, Real b)
=> [Constraint a b]
-> StepGA m a
-> StepGA m a
withFinalDeathPenalty cs step =
\stop popstate -> do
result <- step stop popstate
case result of
(ContinueGA _) -> return result
(StopGA pop) -> return (StopGA (filterFeasible cs pop))
filterFeasible :: (Real b) => [Constraint a b] -> Population a -> Population a
filterFeasible cs = filter (isFeasible cs . takeGenome)