{-# LANGUAGE Rank2Types, ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{- |

NSGA-II. A Fast Elitist Non-Dominated Sorting Genetic
Algorithm for Multi-Objective Optimization.

Deb, K., Pratap, A., Agarwal, S., & Meyarivan, T. A. M. T. (2002). A
fast and elitist multiobjective genetic algorithm:
NSGA-II. Evolutionary Computation, IEEE Transactions on, 6(2),
182-197.

Functions to be used:

  'stepNSGA2', 'stepNSGA2bt',
  'stepConstrainedNSGA2', 'stepConstrainedNSGA2bt'

The other functions are exported for testing only.

-}

module Moo.GeneticAlgorithm.Multiobjective.NSGA2 where


import Moo.GeneticAlgorithm.Types
import Moo.GeneticAlgorithm.Multiobjective.Types
import Moo.GeneticAlgorithm.Random
import Moo.GeneticAlgorithm.Utilities (doCrossovers)
import Moo.GeneticAlgorithm.Selection (tournamentSelect)
import Moo.GeneticAlgorithm.Constraints
import Moo.GeneticAlgorithm.Run (makeStoppable)


import Control.Monad (forM_, (<=<), when, liftM)
import Control.Monad.ST (ST)
import Data.Array (array, (!), elems, listArray)
import Data.Array.ST (STArray, runSTArray, newArray, readArray, writeArray, getElems, getBounds)
import Data.Function (on)
import Data.List (sortBy)
import Data.STRef


-- | Returns @True@ if the first solution dominates the second one in

-- some sense.

type DominationCmp a = MultiPhenotype a -> MultiPhenotype a -> Bool


-- | A solution @p@ dominates another solution @q@ if at least one 'Objective'

-- values of @p@ is better than the respective value of @q@, and the other

-- are not worse.

domination :: [ProblemType] -- ^ problem types per every objective

           -> DominationCmp a
domination :: [ProblemType] -> DominationCmp a
domination [ProblemType]
ptypes MultiPhenotype a
p MultiPhenotype a
q =
    let pvs :: [Objective]
pvs = MultiPhenotype a -> [Objective]
forall a. MultiPhenotype a -> [Objective]
takeObjectiveValues MultiPhenotype a
p
        qvs :: [Objective]
qvs = MultiPhenotype a -> [Objective]
forall a. MultiPhenotype a -> [Objective]
takeObjectiveValues MultiPhenotype a
q
        pqs :: [(ProblemType, Objective, Objective)]
pqs = [ProblemType]
-> [Objective]
-> [Objective]
-> [(ProblemType, Objective, Objective)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [ProblemType]
ptypes [Objective]
pvs [Objective]
qvs
        qps :: [(ProblemType, Objective, Objective)]
qps = [ProblemType]
-> [Objective]
-> [Objective]
-> [(ProblemType, Objective, Objective)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [ProblemType]
ptypes [Objective]
qvs [Objective]
pvs
    in  (((ProblemType, Objective, Objective) -> Bool)
-> [(ProblemType, Objective, Objective)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ProblemType, Objective, Objective) -> Bool
better1 [(ProblemType, Objective, Objective)]
pqs) Bool -> Bool -> Bool
&& (((ProblemType, Objective, Objective) -> Bool)
-> [(ProblemType, Objective, Objective)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool)
-> ((ProblemType, Objective, Objective) -> Bool)
-> (ProblemType, Objective, Objective)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProblemType, Objective, Objective) -> Bool
better1) [(ProblemType, Objective, Objective)]
qps)
  where
    better1 :: (ProblemType, Objective, Objective) -> Bool
    better1 :: (ProblemType, Objective, Objective) -> Bool
better1 (ProblemType
Minimizing, Objective
pv, Objective
qv) = Objective
pv Objective -> Objective -> Bool
forall a. Ord a => a -> a -> Bool
< Objective
qv
    better1 (ProblemType
Maximizing, Objective
pv, Objective
qv) = Objective
pv Objective -> Objective -> Bool
forall a. Ord a => a -> a -> Bool
> Objective
qv


-- | A solution p is said to constrain-dominate a solution q, if any of the

-- following is true: 1) Solution p is feasible and q is not. 2) Solutions

-- p and q are both infeasible but solution p has a smaller overall constraint

-- violation. 3) Solutions p and q are feasible, and solution p dominates solution q.

--

-- Reference: (Deb, 2002).

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

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

                      -> [ProblemType]     -- ^ problem types per every objective

                      -> DominationCmp a
constrainedDomination :: [Constraint a b]
-> ([Constraint a b] -> Genome a -> c)
-> [ProblemType]
-> DominationCmp a
constrainedDomination [Constraint a b]
constraints [Constraint a b] -> Genome a -> c
violation [ProblemType]
ptypes MultiPhenotype a
p MultiPhenotype a
q =
    let pok :: Bool
pok = [Constraint a b] -> MultiPhenotype a -> Bool
forall gt a b.
(GenomeState gt a, Real b) =>
[Constraint a b] -> gt -> Bool
isFeasible [Constraint a b]
constraints MultiPhenotype a
p
        qok :: Bool
qok = [Constraint a b] -> MultiPhenotype a -> Bool
forall gt a b.
(GenomeState gt a, Real b) =>
[Constraint a b] -> gt -> Bool
isFeasible [Constraint a b]
constraints MultiPhenotype a
q
    in  case (Bool
pok, Bool
qok) of
          (Bool
True, Bool
True) -> [ProblemType] -> DominationCmp a
forall a. [ProblemType] -> DominationCmp a
domination [ProblemType]
ptypes MultiPhenotype a
p MultiPhenotype a
q
          (Bool
False, Bool
True) -> Bool
False
          (Bool
True, Bool
False) -> Bool
True
          (Bool
False, Bool
False) ->
              let pviolation :: c
pviolation = [Constraint a b] -> Genome a -> c
violation [Constraint a b]
constraints (MultiPhenotype a -> Genome a
forall gt a. GenomeState gt a => gt -> Genome a
takeGenome MultiPhenotype a
p)
                  qviolation :: c
qviolation = [Constraint a b] -> Genome a -> c
violation [Constraint a b]
constraints (MultiPhenotype a -> Genome a
forall gt a. GenomeState gt a => gt -> Genome a
takeGenome MultiPhenotype a
q)
              in  c
pviolation c -> c -> Bool
forall a. Ord a => a -> a -> Bool
< c
qviolation


-- | Solution and its non-dominated rank and local crowding distance.

data RankedSolution a = RankedSolution {
      RankedSolution a -> MultiPhenotype a
rs'phenotype :: MultiPhenotype a
    , RankedSolution a -> Int
rs'nondominationRank :: Int  -- ^ @0@ is the best

    , RankedSolution a -> Objective
rs'localCrowdingDistnace :: Double  -- ^ @Infinity@ for less-crowded boundary points

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


-- | Fast non-dominated sort from (Deb et al. 2002).

-- It is should be O(m N^2), with storage requirements of O(N^2).

nondominatedSort :: DominationCmp a -> [MultiPhenotype a] -> [[MultiPhenotype a]]
nondominatedSort :: DominationCmp a -> [MultiPhenotype a] -> [[MultiPhenotype a]]
nondominatedSort DominationCmp a
dominates = DominationCmp a -> [MultiPhenotype a] -> [[MultiPhenotype a]]
forall a.
DominationCmp a -> [MultiPhenotype a] -> [[MultiPhenotype a]]
nondominatedSortFast DominationCmp a
dominates


-- | This is a direct translation of the pseudocode from (Deb et al. 2002).

nondominatedSortFast :: DominationCmp a -> [MultiPhenotype a] -> [[MultiPhenotype a]]
nondominatedSortFast :: DominationCmp a -> [MultiPhenotype a] -> [[MultiPhenotype a]]
nondominatedSortFast DominationCmp a
dominates [MultiPhenotype a]
gs =
    let n :: Int
n = [MultiPhenotype a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [MultiPhenotype a]
gs   -- number of genomes

        garray :: Array Int (MultiPhenotype a)
garray = (Int, Int) -> [MultiPhenotype a] -> Array Int (MultiPhenotype a)
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [MultiPhenotype a]
gs
        fronts :: Array (Int, Int) Int
fronts = (forall s. ST s (STArray s (Int, Int) Int)) -> Array (Int, Int) Int
forall i e. (forall s. ST s (STArray s i e)) -> Array i e
runSTArray ((forall s. ST s (STArray s (Int, Int) Int))
 -> Array (Int, Int) Int)
-> (forall s. ST s (STArray s (Int, Int) Int))
-> Array (Int, Int) Int
forall a b. (a -> b) -> a -> b
$ do
                     -- structure of sp array:

                     -- sp [pi][0]    -- n_p, number of genomes dominating pi-th genome

                     -- sp [pi][1]    -- size of S_p, how many genomes pi-th genome dominates

                     -- sp [pi][2..]  -- indices of the genomes dominated by pi-th genome

                     --               -- where pi in [0..n-1]

                     --

                     -- structure of the fronts array:

                     -- fronts [0][i]        -- size of the i-th front

                     -- fronts [1][start..start+fsizes[i]-1] -- indices of the elements of the i-th front

                     --                                      -- where start = sum (take (i-1) fsizes)

                     --

                     -- domination table

                     STArray s (Int, Int) Int
sp <- ((Int, Int), (Int, Int)) -> Int -> ST s (STArray s (Int, Int) Int)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray ((Int
0,Int
0), (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1, (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2)Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) Int
0 :: ST s (STArray s (Int,Int) Int)
                     -- at most n fronts with 1 element each

                     STArray s (Int, Int) Int
fronts <- ((Int, Int), (Int, Int)) -> Int -> ST s (STArray s (Int, Int) Int)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray ((Int
0,Int
0), (Int
1,Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) Int
0 :: ST s (STArray s (Int,Int) Int)
                     [(MultiPhenotype a, Int)]
-> ((MultiPhenotype a, Int) -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([MultiPhenotype a] -> [Int] -> [(MultiPhenotype a, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [MultiPhenotype a]
gs [Int
0..]) (((MultiPhenotype a, Int) -> ST s ()) -> ST s ())
-> ((MultiPhenotype a, Int) -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \(MultiPhenotype a
p, Int
pi) -> do  -- for each p in P

                       [(MultiPhenotype a, Int)]
-> ((MultiPhenotype a, Int) -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([MultiPhenotype a] -> [Int] -> [(MultiPhenotype a, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [MultiPhenotype a]
gs [Int
0..]) (((MultiPhenotype a, Int) -> ST s ()) -> ST s ())
-> ((MultiPhenotype a, Int) -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \(MultiPhenotype a
q, Int
qi) -> do  -- for each q in P

                         Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ( MultiPhenotype a
p DominationCmp a
`dominates` MultiPhenotype a
q ) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$
                              -- if p dominates q, include q in S_p

                              STArray s (Int, Int) Int -> Int -> Int -> ST s ()
forall (m :: * -> *) (a :: * -> * -> *) a a.
(MArray a a m, Ix a, Ix a, Num a) =>
a (a, a) a -> a -> a -> m ()
includeInSp STArray s (Int, Int) Int
sp Int
pi Int
qi
                         Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ( MultiPhenotype a
q DominationCmp a
`dominates` MultiPhenotype a
p) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$
                              -- if q dominates p, increment n_p

                              STArray s (Int, Int) Int -> Int -> ST s ()
forall (m :: * -> *) (a :: * -> * -> *) a a b.
(MArray a a m, Ix a, Ix b, Num b, Num a) =>
a (a, b) a -> a -> m ()
incrementNp STArray s (Int, Int) Int
sp Int
pi
                       Int
np <- STArray s (Int, Int) Int -> (Int, Int) -> ST s Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STArray s (Int, Int) Int
sp (Int
pi, Int
0)
                       Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
np Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$
                            Int -> STArray s (Int, Int) Int -> Int -> ST s ()
forall a (a :: * -> * -> *) s a.
(Enum a, MArray a a (ST s), Ix a, Ix a, Num a, Num a) =>
a -> a (a, a) a -> a -> ST s ()
addToFront Int
0 STArray s (Int, Int) Int
fronts Int
pi
                     STArray s (Int, Int) Int
-> STArray s (Int, Int) Int
-> Int
-> ST s (STArray s (Int, Int) Int)
forall a (a :: * -> * -> *) s (a :: * -> * -> *).
(Ix a, Num a, MArray a Int (ST s), MArray a Int (ST s)) =>
a (Int, Int) Int -> a (a, Int) Int -> Int -> ST s (a (a, Int) Int)
buildFronts STArray s (Int, Int) Int
sp STArray s (Int, Int) Int
fronts Int
0
        frontSizes :: [Int]
frontSizes = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0) ([Int] -> [Int]) -> ([Int] -> [Int]) -> [Int] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
n ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ Array (Int, Int) Int -> [Int]
forall i e. Array i e -> [e]
elems Array (Int, Int) Int
fronts
        frontElems :: [MultiPhenotype a]
frontElems = (Int -> MultiPhenotype a) -> [Int] -> [MultiPhenotype a]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> Array Int (MultiPhenotype a)
garray Array Int (MultiPhenotype a) -> Int -> MultiPhenotype a
forall i e. Ix i => Array i e -> i -> e
! Int
i) ([Int] -> [MultiPhenotype a])
-> ([Int] -> [Int]) -> [Int] -> [MultiPhenotype a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
n ([Int] -> [MultiPhenotype a]) -> [Int] -> [MultiPhenotype a]
forall a b. (a -> b) -> a -> b
$ Array (Int, Int) Int -> [Int]
forall i e. Array i e -> [e]
elems Array (Int, Int) Int
fronts
    in  [Int] -> [MultiPhenotype a] -> [[MultiPhenotype a]]
forall a. [Int] -> [a] -> [[a]]
splitAll [Int]
frontSizes [MultiPhenotype a]
frontElems

  where

    includeInSp :: a (a, a) a -> a -> a -> m ()
includeInSp a (a, a) a
sp a
pi a
qi = do
      a
oldspsize <- a (a, a) a -> (a, a) -> m a
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray a (a, a) a
sp (a
pi, a
1)
      a (a, a) a -> (a, a) -> a -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray a (a, a) a
sp (a
pi, a
2 a -> a -> a
forall a. Num a => a -> a -> a
+ a
oldspsize) a
qi
      a (a, a) a -> (a, a) -> a -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray a (a, a) a
sp (a
pi, a
1) (a
oldspsize a -> a -> a
forall a. Num a => a -> a -> a
+ a
1)

    incrementNp :: a (a, b) a -> a -> m ()
incrementNp a (a, b) a
sp a
pi = do
      a
oldnp <- a (a, b) a -> (a, b) -> m a
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray a (a, b) a
sp (a
pi, b
0)
      a (a, b) a -> (a, b) -> a -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray a (a, b) a
sp (a
pi, b
0) (a
oldnp a -> a -> a
forall a. Num a => a -> a -> a
+ a
1)

    -- size of the i-th front

    frontSize :: a (a, b) e -> b -> m e
frontSize a (a, b) e
fronts b
i =
        a (a, b) e -> (a, b) -> m e
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray a (a, b) e
fronts (a
0, b
i)

    frontStartIndex :: a (a, b) b -> b -> ST s b
frontStartIndex a (a, b) b
fronts b
frontno = do
      -- start = sum (take (frontno-1) fsizes)

      STRef s b
startref <- b -> ST s (STRef s b)
forall a s. a -> ST s (STRef s a)
newSTRef b
0
      [b] -> (b -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [b
0..(b
frontnob -> b -> b
forall a. Num a => a -> a -> a
-b
1)] ((b -> ST s ()) -> ST s ()) -> (b -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \b
i -> do
          b
oldstart <- STRef s b -> ST s b
forall s a. STRef s a -> ST s a
readSTRef STRef s b
startref
          b
l <- a (a, b) b -> b -> ST s b
forall (a :: * -> * -> *) e (m :: * -> *) a b.
(MArray a e m, Ix a, Ix b, Num a) =>
a (a, b) e -> b -> m e
frontSize a (a, b) b
fronts b
i
          STRef s b -> b -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s b
startref (b
oldstart b -> b -> b
forall a. Num a => a -> a -> a
+ b
l)
      STRef s b -> ST s b
forall s a. STRef s a -> ST s a
readSTRef STRef s b
startref

    -- adjust fronts array by updating frontno-th front size and appending

    -- pi to its elements; frontno should be the last front!

    addToFront :: a -> a (a, a) a -> a -> ST s ()
addToFront a
frontno a (a, a) a
fronts a
pi = do
      -- update i-th front size and write an index in the correct position

      a
start <- a (a, a) a -> a -> ST s a
forall b (a :: * -> * -> *) b s a.
(Enum b, MArray a b (ST s), Ix a, Ix b, Num b, Num b, Num a) =>
a (a, b) b -> b -> ST s b
frontStartIndex a (a, a) a
fronts a
frontno
      a
sz <- a (a, a) a -> a -> ST s a
forall (a :: * -> * -> *) e (m :: * -> *) a b.
(MArray a e m, Ix a, Ix b, Num a) =>
a (a, b) e -> b -> m e
frontSize a (a, a) a
fronts a
frontno
      a (a, a) a -> (a, a) -> a -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray a (a, a) a
fronts (a
1, a
start a -> a -> a
forall a. Num a => a -> a -> a
+ a
sz) a
pi
      a (a, a) a -> (a, a) -> a -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray a (a, a) a
fronts (a
0, a
frontno) (a
sz a -> a -> a
forall a. Num a => a -> a -> a
+ a
1)

    -- elements of the i-th front

    frontElems :: a (a, Int) Int -> Int -> ST s [Int]
frontElems a (a, Int) Int
fronts Int
i = do
      Int
start <- a (a, Int) Int -> Int -> ST s Int
forall b (a :: * -> * -> *) b s a.
(Enum b, MArray a b (ST s), Ix a, Ix b, Num b, Num b, Num a) =>
a (a, b) b -> b -> ST s b
frontStartIndex a (a, Int) Int
fronts Int
i
      Int
sz <- a (a, Int) Int -> Int -> ST s Int
forall (a :: * -> * -> *) e (m :: * -> *) a b.
(MArray a e m, Ix a, Ix b, Num a) =>
a (a, b) e -> b -> m e
frontSize a (a, Int) Int
fronts Int
i
      STArray s Int Int
felems <- (Int, Int) -> Int -> ST s (STArray s Int Int)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int
0, Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (-Int
1) :: ST s (STArray s Int Int)
      [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
elix ->
          a (a, Int) Int -> (a, Int) -> ST s Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray a (a, Int) Int
fronts (a
1, Int
startInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
elix) ST s Int -> (Int -> ST s ()) -> ST s ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STArray s Int Int
felems Int
elix
      STArray s Int Int -> ST s [Int]
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> m [e]
getElems STArray s Int Int
felems

    -- elements which are dominated by the element pi

    dominatedSet :: a (a, Int) Int -> a -> ST s [Int]
dominatedSet a (a, Int) Int
sp a
pi = do
      Int
sz <- a (a, Int) Int -> (a, Int) -> ST s Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray a (a, Int) Int
sp (a
pi, Int
1)
      STArray s Int Int
delems <- (Int, Int) -> Int -> ST s (STArray s Int Int)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int
0, Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (-Int
1) :: ST s (STArray s Int Int)
      [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
elix ->
          a (a, Int) Int -> (a, Int) -> ST s Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray a (a, Int) Int
sp (a
pi, Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
elix) ST s Int -> (Int -> ST s ()) -> ST s ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STArray s Int Int
delems Int
elix
      STArray s Int Int -> ST s [Int]
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> m [e]
getElems STArray s Int Int
delems

    buildFronts :: a (Int, Int) Int -> a (a, Int) Int -> Int -> ST s (a (a, Int) Int)
buildFronts a (Int, Int) Int
sp a (a, Int) Int
fronts Int
i = do
      Int
maxI <- ((a, Int) -> Int
forall a b. (a, b) -> b
snd ((a, Int) -> Int)
-> (((a, Int), (a, Int)) -> (a, Int))
-> ((a, Int), (a, Int))
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Int), (a, Int)) -> (a, Int)
forall a b. (a, b) -> b
snd) (((a, Int), (a, Int)) -> Int)
-> ST s ((a, Int), (a, Int)) -> ST s Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` a (a, Int) Int -> ST s ((a, Int), (a, Int))
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> m (i, i)
getBounds a (a, Int) Int
fronts
      if (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxI Bool -> Bool -> Bool
|| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0) -- all fronts are singletons and the last is already built

         then a (a, Int) Int -> ST s (a (a, Int) Int)
forall (m :: * -> *) a. Monad m => a -> m a
return a (a, Int) Int
fronts
         else do

      Int
fsz <- a (a, Int) Int -> Int -> ST s Int
forall (a :: * -> * -> *) e (m :: * -> *) a b.
(MArray a e m, Ix a, Ix b, Num a) =>
a (a, b) e -> b -> m e
frontSize a (a, Int) Int
fronts Int
i
      if Int
fsz Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
         then a (a, Int) Int -> ST s (a (a, Int) Int)
forall (m :: * -> *) a. Monad m => a -> m a
return a (a, Int) Int
fronts
         else do

      [Int]
felems <- a (a, Int) Int -> Int -> ST s [Int]
forall (a :: * -> * -> *) s a.
(MArray a Int (ST s), Ix a, Num a) =>
a (a, Int) Int -> Int -> ST s [Int]
frontElems a (a, Int) Int
fronts Int
i
      [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int]
felems ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
pi -> do   -- for each member p in F_i

          [Int]
dominated <- a (Int, Int) Int -> Int -> ST s [Int]
forall (a :: * -> * -> *) s a.
(MArray a Int (ST s), Ix a) =>
a (a, Int) Int -> a -> ST s [Int]
dominatedSet a (Int, Int) Int
sp Int
pi
          [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int]
dominated ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
qi -> do  -- modify each member from the set S_p

               Int
nq <- (Int -> Int) -> ST s Int -> ST s Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (-Int
1::Int)) (ST s Int -> ST s Int) -> ST s Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ a (Int, Int) Int -> (Int, Int) -> ST s Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray a (Int, Int) Int
sp (Int
qi, Int
0)  -- decrement n_q by one

               a (Int, Int) Int -> (Int, Int) -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray a (Int, Int) Int
sp (Int
qi, Int
0) Int
nq
               Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
nq Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$  -- if n_q is zero, q is a member of the next front

                    Int -> a (a, Int) Int -> Int -> ST s ()
forall a (a :: * -> * -> *) s a.
(Enum a, MArray a a (ST s), Ix a, Ix a, Num a, Num a) =>
a -> a (a, a) a -> a -> ST s ()
addToFront (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) a (a, Int) Int
fronts Int
qi
      a (Int, Int) Int -> a (a, Int) Int -> Int -> ST s (a (a, Int) Int)
buildFronts a (Int, Int) Int
sp a (a, Int) Int
fronts (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

    splitAll :: [Int] -> [a] -> [[a]]
splitAll [] [a]
_ = []
    splitAll [Int]
_ [] = []
    splitAll (Int
sz:[Int]
szs) [a]
els =
        let ([a]
front, [a]
rest) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
sz [a]
els
        in  [a]
front [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: ([Int] -> [a] -> [[a]]
splitAll [Int]
szs [a]
rest)


-- | Crowding distance of a point @p@, as defined by Deb et

-- al. (2002), is an estimate (the sum of dimensions in their

-- pseudocode) of the largest cuboid enclosing the point without

-- including any other point in the population.

crowdingDistances :: [[Objective]] -> [Double]
crowdingDistances :: [[Objective]] -> [Objective]
crowdingDistances [] = []
crowdingDistances pop :: [[Objective]]
pop@([Objective]
objvals:[[Objective]]
_) =
    let m :: Int
m = [Objective] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Objective]
objvals  -- number of objectives

        n :: Int
n = [[Objective]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Objective]]
pop      -- number of genomes

        inf :: Objective
inf = Objective
1.0Objective -> Objective -> Objective
forall a. Fractional a => a -> a -> a
/Objective
0.0 :: Double
        -- (genome-idx, objective-idx) -> objective value

        ovTable :: Array (Int, Int) Objective
ovTable = ((Int, Int), (Int, Int))
-> [((Int, Int), Objective)] -> Array (Int, Int) Objective
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array ((Int
0,Int
0), (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1, Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1))
                  [ ((Int
i, Int
objid), ([[Objective]]
pop [[Objective]] -> Int -> [Objective]
forall a. [a] -> Int -> a
!! Int
i) [Objective] -> Int -> Objective
forall a. [a] -> Int -> a
!! Int
objid)
                  | Int
i <- [Int
0..(Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)], Int
objid <- [Int
0..(Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)] ]
        -- calculate crowding distances

        distances :: Array Int Objective
distances = (forall s. ST s (STArray s Int Objective)) -> Array Int Objective
forall i e. (forall s. ST s (STArray s i e)) -> Array i e
runSTArray ((forall s. ST s (STArray s Int Objective)) -> Array Int Objective)
-> (forall s. ST s (STArray s Int Objective))
-> Array Int Objective
forall a b. (a -> b) -> a -> b
$ do
          STArray s Int Objective
ss <- (Int, Int) -> Objective -> ST s (STArray s Int Objective)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int
0, Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Objective
0.0  -- initialize distances

          [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..(Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
objid -> do    -- for every objective

            let ixs :: [Int]
ixs = Int -> [[Objective]] -> [Int]
sortByObjective Int
objid [[Objective]]
pop
              -- for all inner points

            [(Int, Int, Int)] -> ((Int, Int, Int) -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [Int] -> [Int] -> [(Int, Int, Int)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Int]
ixs (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
1 [Int]
ixs) (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
2 [Int]
ixs)) (((Int, Int, Int) -> ST s ()) -> ST s ())
-> ((Int, Int, Int) -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \(Int
iprev, Int
i, Int
inext) -> do
              Objective
sum_of_si <- STArray s Int Objective -> Int -> ST s Objective
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STArray s Int Objective
ss Int
i
              let si :: Objective
si = (Array (Int, Int) Objective
ovTable Array (Int, Int) Objective -> (Int, Int) -> Objective
forall i e. Ix i => Array i e -> i -> e
! (Int
inext, Int
objid)) Objective -> Objective -> Objective
forall a. Num a => a -> a -> a
- (Array (Int, Int) Objective
ovTable Array (Int, Int) Objective -> (Int, Int) -> Objective
forall i e. Ix i => Array i e -> i -> e
! (Int
iprev, Int
objid))
              STArray s Int Objective -> Int -> Objective -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STArray s Int Objective
ss Int
i (Objective
sum_of_si Objective -> Objective -> Objective
forall a. Num a => a -> a -> a
+ Objective
si)
            STArray s Int Objective -> Int -> Objective -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STArray s Int Objective
ss ([Int] -> Int
forall a. [a] -> a
head [Int]
ixs) Objective
inf   -- boundary points have infinite cuboids

            STArray s Int Objective -> Int -> Objective -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STArray s Int Objective
ss ([Int] -> Int
forall a. [a] -> a
last [Int]
ixs) Objective
inf
          STArray s Int Objective -> ST s (STArray s Int Objective)
forall (m :: * -> *) a. Monad m => a -> m a
return STArray s Int Objective
ss
    in Array Int Objective -> [Objective]
forall i e. Array i e -> [e]
elems Array Int Objective
distances
  where
    sortByObjective :: Int -> [[Objective]] -> [Int]
    sortByObjective :: Int -> [[Objective]] -> [Int]
sortByObjective Int
i [[Objective]]
pop = ([Objective] -> [Objective] -> Ordering) -> [[Objective]] -> [Int]
forall a. (a -> a -> Ordering) -> [a] -> [Int]
sortIndicesBy (Objective -> Objective -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Objective -> Objective -> Ordering)
-> ([Objective] -> Objective)
-> [Objective]
-> [Objective]
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ([Objective] -> Int -> Objective
forall a. [a] -> Int -> a
!! Int
i)) [[Objective]]
pop

-- | Given there is non-domination rank @rank_i@, and local crowding

-- distance @distance_i@ assigned to every individual @i@, the partial

-- order between individuals @i@ and @q@ is defined by relation

--

-- @i ~ j@ if @rank_i < rank_j@ or (@rank_i = rank_j@ and @distance_i@

-- @>@ @distance_j@).

--

crowdedCompare :: RankedSolution a -> RankedSolution a -> Ordering
crowdedCompare :: RankedSolution a -> RankedSolution a -> Ordering
crowdedCompare (RankedSolution MultiPhenotype a
_ Int
ranki Objective
disti) (RankedSolution MultiPhenotype a
_ Int
rankj Objective
distj) =
    case (Int
ranki Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
rankj, Int
ranki Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
rankj, Objective
disti Objective -> Objective -> Bool
forall a. Ord a => a -> a -> Bool
> Objective
distj) of
      (Bool
True, Bool
_, Bool
_) -> Ordering
LT
      (Bool
_, Bool
True, Bool
True) -> Ordering
LT
      (Bool
_, Bool
True, Bool
False) -> if Objective
disti Objective -> Objective -> Bool
forall a. Eq a => a -> a -> Bool
== Objective
distj
                          then Ordering
EQ
                          else Ordering
GT
      (Bool, Bool, Bool)
_  -> Ordering
GT


-- | Assign non-domination rank and crowding distances to all solutions.

-- Return a list of non-domination fronts.

rankAllSolutions :: DominationCmp a -> [MultiPhenotype a] -> [[RankedSolution a]]
rankAllSolutions :: DominationCmp a -> [MultiPhenotype a] -> [[RankedSolution a]]
rankAllSolutions DominationCmp a
dominates [MultiPhenotype a]
genomes =
    let -- non-dominated fronts

        fronts :: [[MultiPhenotype a]]
fronts = DominationCmp a -> [MultiPhenotype a] -> [[MultiPhenotype a]]
forall a.
DominationCmp a -> [MultiPhenotype a] -> [[MultiPhenotype a]]
nondominatedSort DominationCmp a
dominates [MultiPhenotype a]
genomes
        -- for every non-dominated front

        frontsDists :: [[Objective]]
frontsDists = ([MultiPhenotype a] -> [Objective])
-> [[MultiPhenotype a]] -> [[Objective]]
forall a b. (a -> b) -> [a] -> [b]
map ([[Objective]] -> [Objective]
crowdingDistances ([[Objective]] -> [Objective])
-> ([MultiPhenotype a] -> [[Objective]])
-> [MultiPhenotype a]
-> [Objective]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MultiPhenotype a -> [Objective])
-> [MultiPhenotype a] -> [[Objective]]
forall a b. (a -> b) -> [a] -> [b]
map MultiPhenotype a -> [Objective]
forall a b. (a, b) -> b
snd) [[MultiPhenotype a]]
fronts
        ranks :: [Int]
ranks = (Int -> Int) -> Int -> [Int]
forall a. (a -> a) -> a -> [a]
iterate (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
1
    in  (([MultiPhenotype a], Int, [Objective]) -> [RankedSolution a])
-> [([MultiPhenotype a], Int, [Objective])] -> [[RankedSolution a]]
forall a b. (a -> b) -> [a] -> [b]
map ([MultiPhenotype a], Int, [Objective]) -> [RankedSolution a]
forall a.
([MultiPhenotype a], Int, [Objective]) -> [RankedSolution a]
rankedSolutions1 ([[MultiPhenotype a]]
-> [Int]
-> [[Objective]]
-> [([MultiPhenotype a], Int, [Objective])]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [[MultiPhenotype a]]
fronts [Int]
ranks [[Objective]]
frontsDists)
  where
    rankedSolutions1 :: ([MultiPhenotype a], Int, [Double]) -> [RankedSolution a]
    rankedSolutions1 :: ([MultiPhenotype a], Int, [Objective]) -> [RankedSolution a]
rankedSolutions1 ([MultiPhenotype a]
front, Int
rank, [Objective]
dists) =
        (MultiPhenotype a -> Objective -> RankedSolution a)
-> [MultiPhenotype a] -> [Objective] -> [RankedSolution a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\MultiPhenotype a
g Objective
d -> MultiPhenotype a -> Int -> Objective -> RankedSolution a
forall a. MultiPhenotype a -> Int -> Objective -> RankedSolution a
RankedSolution MultiPhenotype a
g Int
rank Objective
d) [MultiPhenotype a]
front [Objective]
dists


-- | To every genome in the population, assign a single objective

-- value according to its non-domination rank. This ranking is

-- supposed to be used once in the beginning of the NSGA-II algorithm.

--

-- Note: 'nondominatedRanking' reorders the genomes.

nondominatedRanking
    :: forall fn a . ObjectiveFunction fn a
    => DominationCmp a
    -> MultiObjectiveProblem fn     -- ^ list of @problems@

    -> [Genome a]                   -- ^ a population of raw @genomes@

    -> [(Genome a, Objective)]
nondominatedRanking :: DominationCmp a
-> MultiObjectiveProblem fn
-> [Genome a]
-> [(Genome a, Objective)]
nondominatedRanking DominationCmp a
dominates MultiObjectiveProblem fn
problems [Genome a]
genomes =
    let egs :: [MultiPhenotype a]
egs = MultiObjectiveProblem fn -> [Genome a] -> [MultiPhenotype a]
forall fn gt a.
(ObjectiveFunction fn a, GenomeState gt a) =>
MultiObjectiveProblem fn -> [gt] -> [MultiPhenotype a]
evalAllObjectives MultiObjectiveProblem fn
problems [Genome a]
genomes
        fronts :: [[MultiPhenotype a]]
fronts = DominationCmp a -> [MultiPhenotype a] -> [[MultiPhenotype a]]
forall a.
DominationCmp a -> [MultiPhenotype a] -> [[MultiPhenotype a]]
nondominatedSort DominationCmp a
dominates [MultiPhenotype a]
egs
        ranks :: [(Genome a, Objective)]
ranks = (([MultiPhenotype a], Int) -> [(Genome a, Objective)])
-> [([MultiPhenotype a], Int)] -> [(Genome a, Objective)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([MultiPhenotype a], Int) -> [(Genome a, Objective)]
forall a. ([MultiPhenotype a], Int) -> [(Genome a, Objective)]
assignRanks ([[MultiPhenotype a]] -> [Int] -> [([MultiPhenotype a], Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [[MultiPhenotype a]]
fronts ((Int -> Int) -> Int -> [Int]
forall a. (a -> a) -> a -> [a]
iterate (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
1))
    in  [(Genome a, Objective)]
ranks
  where
    assignRanks :: ([MultiPhenotype a], Int) -> [(Genome a, Objective)]
    assignRanks :: ([MultiPhenotype a], Int) -> [(Genome a, Objective)]
assignRanks ([MultiPhenotype a]
gs, Int
r) = ((MultiPhenotype a, Int) -> (Genome a, Objective))
-> [(MultiPhenotype a, Int)] -> [(Genome a, Objective)]
forall a b. (a -> b) -> [a] -> [b]
map (\(MultiPhenotype a
eg, Int
rank) -> (MultiPhenotype a -> Genome a
forall a b. (a, b) -> a
fst MultiPhenotype a
eg, Int -> Objective
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
rank)) ([(MultiPhenotype a, Int)] -> [(Genome a, Objective)])
-> [(MultiPhenotype a, Int)] -> [(Genome a, Objective)]
forall a b. (a -> b) -> a -> b
$ [MultiPhenotype a] -> [Int] -> [(MultiPhenotype a, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [MultiPhenotype a]
gs (Int -> [Int]
forall a. a -> [a]
repeat Int
r)


-- | To every genome in the population, assign a single objective value

-- equal to its non-domination rank, and sort genomes by the decreasing

-- local crowding distance within every rank

-- (i.e. sort the population with NSGA-II crowded comparision

-- operator)

nsga2Ranking
    :: forall fn a . ObjectiveFunction fn a
    => DominationCmp a
    -> MultiObjectiveProblem fn    -- ^ a list of @objective@ functions

    -> Int                          -- ^ @n@, number of top-ranked genomes to select

    -> [Genome a]                   -- ^ a population of raw @genomes@

    -> [(MultiPhenotype a, Double)] -- ^ selected genomes with their non-domination ranks

nsga2Ranking :: DominationCmp a
-> MultiObjectiveProblem fn
-> Int
-> [Genome a]
-> [(MultiPhenotype a, Objective)]
nsga2Ranking DominationCmp a
dominates MultiObjectiveProblem fn
problems Int
n [Genome a]
genomes =
    let evaledGenomes :: [MultiPhenotype a]
evaledGenomes = MultiObjectiveProblem fn -> [Genome a] -> [MultiPhenotype a]
forall fn gt a.
(ObjectiveFunction fn a, GenomeState gt a) =>
MultiObjectiveProblem fn -> [gt] -> [MultiPhenotype a]
evalAllObjectives MultiObjectiveProblem fn
problems [Genome a]
genomes
        fronts :: [[RankedSolution a]]
fronts = DominationCmp a -> [MultiPhenotype a] -> [[RankedSolution a]]
forall a.
DominationCmp a -> [MultiPhenotype a] -> [[RankedSolution a]]
rankAllSolutions DominationCmp a
dominates [MultiPhenotype a]
evaledGenomes
        frontSizes :: [Int]
frontSizes = ([RankedSolution a] -> Int) -> [[RankedSolution a]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [RankedSolution a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[RankedSolution a]]
fronts
        nFullFronts :: Int
nFullFronts = [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Int] -> Int) -> ([Int] -> [Int]) -> [Int] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n) ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Int) -> [Int] -> [Int]
forall a. (a -> a -> a) -> [a] -> [a]
scanl1 Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) [Int]
frontSizes
        partialSize :: Int
partialSize = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
nFullFronts [Int]
frontSizes))
        ([[RankedSolution a]]
frontsFull, [[RankedSolution a]]
frontsPartial) = Int
-> [[RankedSolution a]]
-> ([[RankedSolution a]], [[RankedSolution a]])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
nFullFronts [[RankedSolution a]]
fronts
        fromFullFronts :: [(MultiPhenotype a, Objective)]
fromFullFronts = ([RankedSolution a] -> [(MultiPhenotype a, Objective)])
-> [[RankedSolution a]] -> [(MultiPhenotype a, Objective)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((RankedSolution a -> (MultiPhenotype a, Objective))
-> [RankedSolution a] -> [(MultiPhenotype a, Objective)]
forall a b. (a -> b) -> [a] -> [b]
map RankedSolution a -> (MultiPhenotype a, Objective)
forall b a. Num b => RankedSolution a -> (MultiPhenotype a, b)
assignRank) [[RankedSolution a]]
frontsFull
        fromPartialFront :: [(MultiPhenotype a, Objective)]
fromPartialFront = ([RankedSolution a] -> [(MultiPhenotype a, Objective)])
-> [[RankedSolution a]] -> [(MultiPhenotype a, Objective)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((RankedSolution a -> (MultiPhenotype a, Objective))
-> [RankedSolution a] -> [(MultiPhenotype a, Objective)]
forall a b. (a -> b) -> [a] -> [b]
map RankedSolution a -> (MultiPhenotype a, Objective)
forall b a. Num b => RankedSolution a -> (MultiPhenotype a, b)
assignRank
                                      ([RankedSolution a] -> [(MultiPhenotype a, Objective)])
-> ([RankedSolution a] -> [RankedSolution a])
-> [RankedSolution a]
-> [(MultiPhenotype a, Objective)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [RankedSolution a] -> [RankedSolution a]
forall a. Int -> [a] -> [a]
take Int
partialSize
                                      ([RankedSolution a] -> [RankedSolution a])
-> ([RankedSolution a] -> [RankedSolution a])
-> [RankedSolution a]
-> [RankedSolution a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RankedSolution a -> RankedSolution a -> Ordering)
-> [RankedSolution a] -> [RankedSolution a]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy RankedSolution a -> RankedSolution a -> Ordering
forall a. RankedSolution a -> RankedSolution a -> Ordering
crowdedCompare) ([[RankedSolution a]] -> [(MultiPhenotype a, Objective)])
-> [[RankedSolution a]] -> [(MultiPhenotype a, Objective)]
forall a b. (a -> b) -> a -> b
$
                           Int -> [[RankedSolution a]] -> [[RankedSolution a]]
forall a. Int -> [a] -> [a]
take Int
1 [[RankedSolution a]]
frontsPartial
    in  [(MultiPhenotype a, Objective)]
fromFullFronts [(MultiPhenotype a, Objective)]
-> [(MultiPhenotype a, Objective)]
-> [(MultiPhenotype a, Objective)]
forall a. [a] -> [a] -> [a]
++ [(MultiPhenotype a, Objective)]
fromPartialFront
  where
    assignRank :: RankedSolution a -> (MultiPhenotype a, b)
assignRank RankedSolution a
eg =
        let r :: b
r = Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> b) -> Int -> b
forall a b. (a -> b) -> a -> b
$ RankedSolution a -> Int
forall a. RankedSolution a -> Int
rs'nondominationRank RankedSolution a
eg
            phenotype :: MultiPhenotype a
phenotype = RankedSolution a -> MultiPhenotype a
forall a. RankedSolution a -> MultiPhenotype a
rs'phenotype (RankedSolution a -> MultiPhenotype a)
-> RankedSolution a -> MultiPhenotype a
forall a b. (a -> b) -> a -> b
$ RankedSolution a
eg
        in  (MultiPhenotype a
phenotype, b
r)


sortIndicesBy :: (a -> a -> Ordering) -> [a] -> [Int]
sortIndicesBy :: (a -> a -> Ordering) -> [a] -> [Int]
sortIndicesBy a -> a -> Ordering
cmp [a]
xs = ((a, Int) -> Int) -> [(a, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (a, Int) -> Int
forall a b. (a, b) -> b
snd ([(a, Int)] -> [Int]) -> [(a, Int)] -> [Int]
forall a b. (a -> b) -> a -> b
$ ((a, Int) -> (a, Int) -> Ordering) -> [(a, Int)] -> [(a, Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (a -> a -> Ordering
cmp (a -> a -> Ordering)
-> ((a, Int) -> a) -> (a, Int) -> (a, Int) -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (a, Int) -> a
forall a b. (a, b) -> a
fst) ([a] -> [Int] -> [(a, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
xs ((Int -> Int) -> Int -> [Int]
forall a. (a -> a) -> a -> [a]
iterate (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
0))

-- | A single step of the NSGA-II algorithm (Non-Dominated Sorting

-- Genetic Algorithm for Multi-Objective Optimization).

--

-- The next population is selected from a common pool of parents and

-- their children minimizing the non-domination rank and maximizing

-- the crowding distance within the same rank.

-- The first generation of children is produced without taking

-- crowding into account.

-- Every solution is assigned a single objective value which is its

-- sequence number after sorting with the crowded comparison operator.

-- The smaller value corresponds to solutions which are not worse

-- the one with the bigger value. Use 'evalAllObjectives' to restore

-- individual objective values.

--

-- Reference:

-- Deb, K., Pratap, A., Agarwal, S., & Meyarivan, T. A. M. T. (2002). A

-- fast and elitist multiobjective genetic algorithm:

-- NSGA-II. Evolutionary Computation, IEEE Transactions on, 6(2),

-- 182-197.

--

-- Deb et al. used a binary tournament selection, base on crowded

-- comparison operator. To achieve the same effect, use

-- 'stepNSGA2bt' (or 'stepNSGA2' with 'tournamentSelect'

-- @Minimizing 2 n@, where @n@ is the size of the population).

--

stepNSGA2
    :: forall fn a . ObjectiveFunction fn a
    => MultiObjectiveProblem fn    -- ^ a list of @objective@ functions

    -> SelectionOp a
    -> CrossoverOp a
    -> MutationOp a
    -> StepGA Rand a
stepNSGA2 :: MultiObjectiveProblem fn
-> SelectionOp a -> CrossoverOp a -> MutationOp a -> StepGA Rand a
stepNSGA2 MultiObjectiveProblem fn
problems SelectionOp a
select CrossoverOp a
crossover MutationOp a
mutate Cond a
stop PopulationState a
input = do
  let dominates :: DominationCmp a
dominates = [ProblemType] -> DominationCmp a
forall a. [ProblemType] -> DominationCmp a
domination (((ProblemType, fn) -> ProblemType)
-> MultiObjectiveProblem fn -> [ProblemType]
forall a b. (a -> b) -> [a] -> [b]
map (ProblemType, fn) -> ProblemType
forall a b. (a, b) -> a
fst MultiObjectiveProblem fn
problems)
  case PopulationState a
input of
    (Left [Genome a]
_) ->  -- raw genomes => it's the first generation

        DominationCmp a
-> MultiObjectiveProblem fn
-> SelectionOp a
-> CrossoverOp a
-> MutationOp a
-> StepGA Rand a
forall fn a.
ObjectiveFunction fn a =>
DominationCmp a
-> MultiObjectiveProblem fn
-> SelectionOp a
-> CrossoverOp a
-> MutationOp a
-> StepGA Rand a
stepNSGA2'firstGeneration DominationCmp a
forall a. DominationCmp a
dominates MultiObjectiveProblem fn
problems SelectionOp a
select CrossoverOp a
crossover MutationOp a
mutate Cond a
stop PopulationState a
input
    (Right Population a
_) ->  -- ranked genomes => it's the second or later generation

        DominationCmp a
-> MultiObjectiveProblem fn
-> SelectionOp a
-> CrossoverOp a
-> MutationOp a
-> StepGA Rand a
forall fn a.
ObjectiveFunction fn a =>
DominationCmp a
-> MultiObjectiveProblem fn
-> SelectionOp a
-> CrossoverOp a
-> MutationOp a
-> StepGA Rand a
stepNSGA2'nextGeneration DominationCmp a
forall a. DominationCmp a
dominates MultiObjectiveProblem fn
problems SelectionOp a
select CrossoverOp a
crossover MutationOp a
mutate Cond a
stop PopulationState a
input


-- | A single step of NSGA-II algorithm with binary tournament selection.

-- See also 'stepNSGA2'.

stepNSGA2bt
    :: forall fn a . ObjectiveFunction fn a
    => MultiObjectiveProblem fn    -- ^ a list of @objective@ functions

    -> CrossoverOp a
    -> MutationOp a
    -> StepGA Rand a
stepNSGA2bt :: MultiObjectiveProblem fn
-> CrossoverOp a -> MutationOp a -> StepGA Rand a
stepNSGA2bt MultiObjectiveProblem fn
problems CrossoverOp a
crossover MutationOp a
mutate Cond a
stop PopulationState a
popstate =
    let n :: Int
n = ([Genome a] -> Int)
-> ([Phenotype a] -> Int) -> PopulationState a -> Int
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Genome a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Phenotype a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length PopulationState a
popstate
        select :: SelectionOp a
select = ProblemType -> Int -> Int -> SelectionOp a
forall a. ProblemType -> Int -> Int -> SelectionOp a
tournamentSelect ProblemType
Minimizing Int
2 Int
n
    in  MultiObjectiveProblem fn
-> SelectionOp a -> CrossoverOp a -> MutationOp a -> StepGA Rand a
forall fn a.
ObjectiveFunction fn a =>
MultiObjectiveProblem fn
-> SelectionOp a -> CrossoverOp a -> MutationOp a -> StepGA Rand a
stepNSGA2 MultiObjectiveProblem fn
problems SelectionOp a
forall a. SelectionOp a
select CrossoverOp a
crossover MutationOp a
mutate Cond a
stop PopulationState a
popstate


-- | A single step of the constrained NSGA-II algorithm, which uses a

-- constraint-domination rule:

--

-- “A solution @i@ is said to constrain-dominate a solution @j@, if any of the

-- following is true: 1) Solution @i@ is feasible and @j@ is not. 2) Solutions

-- @i@ and @j@ are both infeasible but solution @i@ has a smaller overall constraint

-- violation. 3) Solutions @i@ and @j@ are feasible, and solution @i@ dominates solution @j@.”

--

-- Reference: (Deb, 2002).

--

stepConstrainedNSGA2
    :: forall fn a b c . (ObjectiveFunction fn a, Real b, Real c)
    => [Constraint a b]                     -- ^ constraints

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

    -> MultiObjectiveProblem fn             -- ^ a list of @objective@ functions

    -> SelectionOp a
    -> CrossoverOp a
    -> MutationOp a
    -> StepGA Rand a
stepConstrainedNSGA2 :: [Constraint a b]
-> ([Constraint a b] -> Genome a -> c)
-> MultiObjectiveProblem fn
-> SelectionOp a
-> CrossoverOp a
-> MutationOp a
-> StepGA Rand a
stepConstrainedNSGA2 [Constraint a b]
constraints [Constraint a b] -> Genome a -> c
violation MultiObjectiveProblem fn
problems SelectionOp a
select CrossoverOp a
crossover MutationOp a
mutate Cond a
stop PopulationState a
input = do
  let dominates :: DominationCmp a
dominates = [Constraint a b]
-> ([Constraint a b] -> Genome a -> c)
-> [ProblemType]
-> DominationCmp a
forall b c a.
(Real b, Real c) =>
[Constraint a b]
-> ([Constraint a b] -> Genome a -> c)
-> [ProblemType]
-> DominationCmp a
constrainedDomination [Constraint a b]
constraints [Constraint a b] -> Genome a -> c
violation (((ProblemType, fn) -> ProblemType)
-> MultiObjectiveProblem fn -> [ProblemType]
forall a b. (a -> b) -> [a] -> [b]
map (ProblemType, fn) -> ProblemType
forall a b. (a, b) -> a
fst MultiObjectiveProblem fn
problems)
  case PopulationState a
input of
    (Left [Genome a]
_) ->
        DominationCmp a
-> MultiObjectiveProblem fn
-> SelectionOp a
-> CrossoverOp a
-> MutationOp a
-> StepGA Rand a
forall fn a.
ObjectiveFunction fn a =>
DominationCmp a
-> MultiObjectiveProblem fn
-> SelectionOp a
-> CrossoverOp a
-> MutationOp a
-> StepGA Rand a
stepNSGA2'firstGeneration DominationCmp a
dominates MultiObjectiveProblem fn
problems SelectionOp a
select CrossoverOp a
crossover MutationOp a
mutate Cond a
stop PopulationState a
input
    (Right Population a
_) ->
        DominationCmp a
-> MultiObjectiveProblem fn
-> SelectionOp a
-> CrossoverOp a
-> MutationOp a
-> StepGA Rand a
forall fn a.
ObjectiveFunction fn a =>
DominationCmp a
-> MultiObjectiveProblem fn
-> SelectionOp a
-> CrossoverOp a
-> MutationOp a
-> StepGA Rand a
stepNSGA2'nextGeneration DominationCmp a
dominates MultiObjectiveProblem fn
problems SelectionOp a
select CrossoverOp a
crossover MutationOp a
mutate Cond a
stop PopulationState a
input


-- | A single step of the constrained NSGA-II algorithm with binary tournament

-- selection. See also 'stepConstrainedNSGA2'.

stepConstrainedNSGA2bt
    :: forall fn a b c . (ObjectiveFunction fn a, Real b, Real c)
    => [Constraint a b]                     -- ^ constraints

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

    -> MultiObjectiveProblem fn             -- ^ a list of @objective@ functions

    -> CrossoverOp a
    -> MutationOp a
    -> StepGA Rand a
stepConstrainedNSGA2bt :: [Constraint a b]
-> ([Constraint a b] -> Genome a -> c)
-> MultiObjectiveProblem fn
-> CrossoverOp a
-> MutationOp a
-> StepGA Rand a
stepConstrainedNSGA2bt [Constraint a b]
constraints [Constraint a b] -> Genome a -> c
violation MultiObjectiveProblem fn
problems CrossoverOp a
crossover MutationOp a
mutate Cond a
stop PopulationState a
popstate =
  let n :: Int
n = ([Genome a] -> Int)
-> ([Phenotype a] -> Int) -> PopulationState a -> Int
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Genome a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Phenotype a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length PopulationState a
popstate
      tournament :: SelectionOp a
tournament = ProblemType -> Int -> Int -> SelectionOp a
forall a. ProblemType -> Int -> Int -> SelectionOp a
tournamentSelect ProblemType
Minimizing Int
2 Int
n
  in  [Constraint a b]
-> ([Constraint a b] -> Genome a -> c)
-> MultiObjectiveProblem fn
-> SelectionOp a
-> CrossoverOp a
-> MutationOp a
-> StepGA Rand a
forall fn a b c.
(ObjectiveFunction fn a, Real b, Real c) =>
[Constraint a b]
-> ([Constraint a b] -> Genome a -> c)
-> MultiObjectiveProblem fn
-> SelectionOp a
-> CrossoverOp a
-> MutationOp a
-> StepGA Rand a
stepConstrainedNSGA2 [Constraint a b]
constraints [Constraint a b] -> Genome a -> c
violation MultiObjectiveProblem fn
problems SelectionOp a
forall a. SelectionOp a
tournament CrossoverOp a
crossover MutationOp a
mutate Cond a
stop PopulationState a
popstate


stepNSGA2'firstGeneration
    :: forall fn a . ObjectiveFunction fn a
    => DominationCmp a
    -> MultiObjectiveProblem fn    -- ^ a list of @objective@ functions

    -> SelectionOp a
    -> CrossoverOp a
    -> MutationOp a
    -> StepGA Rand a
stepNSGA2'firstGeneration :: DominationCmp a
-> MultiObjectiveProblem fn
-> SelectionOp a
-> CrossoverOp a
-> MutationOp a
-> StepGA Rand a
stepNSGA2'firstGeneration DominationCmp a
dominates MultiObjectiveProblem fn
problems SelectionOp a
select CrossoverOp a
crossover MutationOp a
mutate = do
  let objective :: [Genome a] -> [(Genome a, Objective)]
objective = DominationCmp a
-> MultiObjectiveProblem fn
-> [Genome a]
-> [(Genome a, Objective)]
forall fn a.
ObjectiveFunction fn a =>
DominationCmp a
-> MultiObjectiveProblem fn
-> [Genome a]
-> [(Genome a, Objective)]
nondominatedRanking DominationCmp a
dominates MultiObjectiveProblem fn
problems
  ([Genome a] -> [(Genome a, Objective)])
-> SelectionOp a -> StepGA Rand a
forall objectivefn a (m :: * -> *).
(ObjectiveFunction objectivefn a, Monad m) =>
objectivefn -> (Population a -> m (Population a)) -> StepGA m a
makeStoppable [Genome a] -> [(Genome a, Objective)]
objective (SelectionOp a -> StepGA Rand a) -> SelectionOp a -> StepGA Rand a
forall a b. (a -> b) -> a -> b
$ \[(Genome a, Objective)]
phenotypes -> do
    let popsize :: Int
popsize = [(Genome a, Objective)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Genome a, Objective)]
phenotypes
    let genomes :: [Genome a]
genomes = ((Genome a, Objective) -> Genome a)
-> [(Genome a, Objective)] -> [Genome a]
forall a b. (a -> b) -> [a] -> [b]
map (Genome a, Objective) -> Genome a
forall gt a. GenomeState gt a => gt -> Genome a
takeGenome [(Genome a, Objective)]
phenotypes
    [Genome a]
selected <- ([(Genome a, Objective)] -> [Genome a])
-> RandT PureMT Identity [(Genome a, Objective)]
-> RandT PureMT Identity [Genome a]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (((Genome a, Objective) -> Genome a)
-> [(Genome a, Objective)] -> [Genome a]
forall a b. (a -> b) -> [a] -> [b]
map (Genome a, Objective) -> Genome a
forall gt a. GenomeState gt a => gt -> Genome a
takeGenome) (RandT PureMT Identity [(Genome a, Objective)]
 -> RandT PureMT Identity [Genome a])
-> RandT PureMT Identity [(Genome a, Objective)]
-> RandT PureMT Identity [Genome a]
forall a b. (a -> b) -> a -> b
$ (SelectionOp a
forall a. [a] -> Rand [a]
shuffle SelectionOp a -> SelectionOp a -> SelectionOp a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< SelectionOp a
select) [(Genome a, Objective)]
phenotypes
    [Genome a]
newgenomes <- (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
mutate) ([Genome a] -> RandT PureMT Identity [Genome a])
-> ([Genome a] -> RandT PureMT Identity [Genome a])
-> [Genome a]
-> RandT PureMT Identity [Genome a]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (([Genome a] -> CrossoverOp a -> RandT PureMT Identity [Genome a])
-> CrossoverOp a -> [Genome a] -> RandT PureMT Identity [Genome a]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Genome a] -> CrossoverOp a -> RandT PureMT Identity [Genome a]
forall a. [Genome a] -> CrossoverOp a -> Rand [Genome a]
doCrossovers CrossoverOp a
crossover) ([Genome a] -> RandT PureMT Identity [Genome a])
-> [Genome a] -> RandT PureMT Identity [Genome a]
forall a b. (a -> b) -> a -> b
$ [Genome a]
selected
    let pool :: [Genome a]
pool = [Genome a]
newgenomes [Genome a] -> [Genome a] -> [Genome a]
forall a. [a] -> [a] -> [a]
++ [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
$ DominationCmp a
-> MultiObjectiveProblem fn
-> Int
-> [Genome a]
-> [(Genome a, Objective)]
forall fn a.
ObjectiveFunction fn a =>
DominationCmp a
-> MultiObjectiveProblem fn -> Int -> [Genome a] -> [Phenotype a]
stepNSGA2'poolSelection DominationCmp a
dominates MultiObjectiveProblem fn
problems Int
popsize [Genome a]
pool


-- | Use normal selection, crossover, mutation to produce new

-- children.  Select from a common pool of parents and children the

-- best according to the least non-domination rank and crowding.

stepNSGA2'nextGeneration
     :: forall fn a . ObjectiveFunction fn a
     => DominationCmp a
     -> MultiObjectiveProblem fn   -- ^ a list of objective functions

     -> SelectionOp a
     -> CrossoverOp a
     -> MutationOp a
     -> StepGA Rand a
stepNSGA2'nextGeneration :: DominationCmp a
-> MultiObjectiveProblem fn
-> SelectionOp a
-> CrossoverOp a
-> MutationOp a
-> StepGA Rand a
stepNSGA2'nextGeneration DominationCmp a
dominates MultiObjectiveProblem fn
problems SelectionOp a
select CrossoverOp a
crossover MutationOp a
mutate = do
  -- nextGeneration is never called with raw genomes,

  -- => dummyObjective is never evaluated;

  -- nondominatedRanking is required to type-check

  let dummyObjective :: [Genome a] -> [(Genome a, Objective)]
dummyObjective = DominationCmp a
-> MultiObjectiveProblem fn
-> [Genome a]
-> [(Genome a, Objective)]
forall fn a.
ObjectiveFunction fn a =>
DominationCmp a
-> MultiObjectiveProblem fn
-> [Genome a]
-> [(Genome a, Objective)]
nondominatedRanking DominationCmp a
dominates MultiObjectiveProblem fn
problems
  ([Genome a] -> [(Genome a, Objective)])
-> SelectionOp a -> StepGA Rand a
forall objectivefn a (m :: * -> *).
(ObjectiveFunction objectivefn a, Monad m) =>
objectivefn -> (Population a -> m (Population a)) -> StepGA m a
makeStoppable [Genome a] -> [(Genome a, Objective)]
dummyObjective (SelectionOp a -> StepGA Rand a) -> SelectionOp a -> StepGA Rand a
forall a b. (a -> b) -> a -> b
$ \[(Genome a, Objective)]
rankedgenomes -> do
    let popsize :: Int
popsize = [(Genome a, Objective)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Genome a, Objective)]
rankedgenomes
    [Genome a]
selected <- ([(Genome a, Objective)] -> [Genome a])
-> RandT PureMT Identity [(Genome a, Objective)]
-> RandT PureMT Identity [Genome a]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (((Genome a, Objective) -> Genome a)
-> [(Genome a, Objective)] -> [Genome a]
forall a b. (a -> b) -> [a] -> [b]
map (Genome a, Objective) -> Genome a
forall gt a. GenomeState gt a => gt -> Genome a
takeGenome) (RandT PureMT Identity [(Genome a, Objective)]
 -> RandT PureMT Identity [Genome a])
-> RandT PureMT Identity [(Genome a, Objective)]
-> RandT PureMT Identity [Genome a]
forall a b. (a -> b) -> a -> b
$ SelectionOp a
select [(Genome a, Objective)]
rankedgenomes
    [Genome a]
newgenomes <- (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
mutate) ([Genome a] -> RandT PureMT Identity [Genome a])
-> ([Genome a] -> RandT PureMT Identity [Genome a])
-> [Genome a]
-> RandT PureMT Identity [Genome a]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ([Genome a] -> CrossoverOp a -> RandT PureMT Identity [Genome a])
-> CrossoverOp a -> [Genome a] -> RandT PureMT Identity [Genome a]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Genome a] -> CrossoverOp a -> RandT PureMT Identity [Genome a]
forall a. [Genome a] -> CrossoverOp a -> Rand [Genome a]
doCrossovers CrossoverOp a
crossover ([Genome a] -> RandT PureMT Identity [Genome a])
-> ([Genome a] -> RandT PureMT Identity [Genome a])
-> [Genome a]
-> RandT PureMT Identity [Genome a]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< [Genome a] -> RandT PureMT Identity [Genome a]
forall a. [a] -> Rand [a]
shuffle ([Genome a] -> RandT PureMT Identity [Genome a])
-> [Genome a] -> RandT PureMT Identity [Genome a]
forall a b. (a -> b) -> a -> b
$ [Genome a]
selected
    let pool :: [Genome a]
pool = (((Genome a, Objective) -> Genome a)
-> [(Genome a, Objective)] -> [Genome a]
forall a b. (a -> b) -> [a] -> [b]
map (Genome a, Objective) -> Genome a
forall gt a. GenomeState gt a => gt -> Genome a
takeGenome [(Genome a, Objective)]
rankedgenomes) [Genome a] -> [Genome a] -> [Genome a]
forall a. [a] -> [a] -> [a]
++ [Genome a]
newgenomes
    SelectionOp a
forall (m :: * -> *) a. Monad m => a -> m a
return SelectionOp a -> SelectionOp a
forall a b. (a -> b) -> a -> b
$ DominationCmp a
-> MultiObjectiveProblem fn
-> Int
-> [Genome a]
-> [(Genome a, Objective)]
forall fn a.
ObjectiveFunction fn a =>
DominationCmp a
-> MultiObjectiveProblem fn -> Int -> [Genome a] -> [Phenotype a]
stepNSGA2'poolSelection DominationCmp a
dominates MultiObjectiveProblem fn
problems Int
popsize [Genome a]
pool


-- | Take a pool of phenotypes of size 2N, ordered by the crowded

-- comparison operator, and select N best.

stepNSGA2'poolSelection
    :: forall fn a . ObjectiveFunction fn a
    => DominationCmp a
    -> MultiObjectiveProblem fn    -- ^ a list of @objective@ functions

    -> Int                         -- ^ @n@, the number of solutions to select

    -> [Genome a]                  -- ^ @pool@ of genomes to select from

    -> [Phenotype a]               -- ^ @n@ best phenotypes

stepNSGA2'poolSelection :: DominationCmp a
-> MultiObjectiveProblem fn -> Int -> [Genome a] -> [Phenotype a]
stepNSGA2'poolSelection DominationCmp a
dominates MultiObjectiveProblem fn
problems Int
n [Genome a]
pool =
    -- nsga2Ranking returns genomes properly sorted already

    let rankedgenomes :: [Phenotype a]
rankedgenomes = let grs :: [(MultiPhenotype a, Objective)]
grs = DominationCmp a
-> MultiObjectiveProblem fn
-> Int
-> [Genome a]
-> [(MultiPhenotype a, Objective)]
forall fn a.
ObjectiveFunction fn a =>
DominationCmp a
-> MultiObjectiveProblem fn
-> Int
-> [Genome a]
-> [(MultiPhenotype a, Objective)]
nsga2Ranking DominationCmp a
dominates MultiObjectiveProblem fn
problems Int
n [Genome a]
pool
                        in  ((MultiPhenotype a, Objective) -> Phenotype a)
-> [(MultiPhenotype a, Objective)] -> [Phenotype a]
forall a b. (a -> b) -> [a] -> [b]
map (\(MultiPhenotype a
mp,Objective
r) -> (MultiPhenotype a -> Genome a
forall gt a. GenomeState gt a => gt -> Genome a
takeGenome MultiPhenotype a
mp, Objective
r)) [(MultiPhenotype a, Objective)]
grs
        selected :: [Phenotype a]
selected = Int -> [Phenotype a] -> [Phenotype a]
forall a. Int -> [a] -> [a]
take Int
n [Phenotype a]
rankedgenomes  -- :: [Phenotype a]

    in  [Phenotype a]
selected