{-# LANGUAGE Rank2Types, ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
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
type DominationCmp a = MultiPhenotype a -> MultiPhenotype a -> Bool
domination :: [ProblemType]
-> 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
constrainedDomination :: (Real b, Real c)
=> [Constraint a b]
-> ([Constraint a b] -> Genome a -> c)
-> [ProblemType]
-> 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
data RankedSolution a = RankedSolution {
RankedSolution a -> MultiPhenotype a
rs'phenotype :: MultiPhenotype a
, RankedSolution a -> Int
rs'nondominationRank :: Int
, RankedSolution a -> Objective
rs'localCrowdingDistnace :: Double
} 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)
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
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
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
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)
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
[(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
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
$
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
$
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)
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
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
addToFront :: a -> a (a, a) a -> a -> ST s ()
addToFront a
frontno a (a, a) a
fronts a
pi = do
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)
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
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)
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
[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
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)
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
$
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)
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
n :: Int
n = [[Objective]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Objective]]
pop
inf :: Objective
inf = Objective
1.0Objective -> Objective -> Objective
forall a. Fractional a => a -> a -> a
/Objective
0.0 :: Double
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)] ]
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
[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
let ixs :: [Int]
ixs = Int -> [[Objective]] -> [Int]
sortByObjective Int
objid [[Objective]]
pop
[(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
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
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
rankAllSolutions :: DominationCmp a -> [MultiPhenotype a] -> [[RankedSolution a]]
rankAllSolutions :: DominationCmp a -> [MultiPhenotype a] -> [[RankedSolution a]]
rankAllSolutions DominationCmp a
dominates [MultiPhenotype a]
genomes =
let
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
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
nondominatedRanking
:: forall fn a . ObjectiveFunction fn a
=> DominationCmp a
-> MultiObjectiveProblem fn
-> [Genome a]
-> [(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)
nsga2Ranking
:: forall fn a . ObjectiveFunction fn a
=> DominationCmp a
-> MultiObjectiveProblem fn
-> Int
-> [Genome a]
-> [(MultiPhenotype a, Double)]
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))
stepNSGA2
:: forall fn a . ObjectiveFunction fn a
=> MultiObjectiveProblem fn
-> 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]
_) ->
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
_) ->
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
stepNSGA2bt
:: forall fn a . ObjectiveFunction fn a
=> MultiObjectiveProblem fn
-> 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
stepConstrainedNSGA2
:: 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]
-> ([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
stepConstrainedNSGA2bt
:: forall fn a b c . (ObjectiveFunction fn a, Real b, Real c)
=> [Constraint a b]
-> ([Constraint a b] -> Genome a -> c)
-> MultiObjectiveProblem fn
-> 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
-> 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
stepNSGA2'nextGeneration
:: forall fn a . ObjectiveFunction fn a
=> DominationCmp a
-> MultiObjectiveProblem fn
-> 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
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
stepNSGA2'poolSelection
:: forall fn a . ObjectiveFunction fn a
=> DominationCmp a
-> MultiObjectiveProblem fn
-> Int
-> [Genome a]
-> [Phenotype a]
stepNSGA2'poolSelection :: DominationCmp a
-> MultiObjectiveProblem fn -> Int -> [Genome a] -> [Phenotype a]
stepNSGA2'poolSelection DominationCmp a
dominates MultiObjectiveProblem fn
problems Int
n [Genome a]
pool =
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
in [Phenotype a]
selected