{-# LANGUAGE RankNTypes #-}
module Moo.GeneticAlgorithm.Multiobjective.Metrics where
import Data.List (tails, sortBy)
import Data.Function (on)
import Moo.GeneticAlgorithm.Types
import Moo.GeneticAlgorithm.Multiobjective.Types
import Moo.GeneticAlgorithm.Multiobjective.NSGA2
type Point = [Double]
hypervolume :: forall fn a . ObjectiveFunction fn a
=> MultiObjectiveProblem fn
-> [Objective]
-> [MultiPhenotype a]
-> Double
hypervolume :: MultiObjectiveProblem fn
-> [Objective] -> [MultiPhenotype a] -> Objective
hypervolume MultiObjectiveProblem fn
mop [Objective]
refPoint [MultiPhenotype a]
solutions =
let ptypes :: [ProblemType]
ptypes = ((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
mop :: [ProblemType]
points :: [[Objective]]
points = (MultiPhenotype a -> [Objective])
-> [MultiPhenotype a] -> [[Objective]]
forall a b. (a -> b) -> [a] -> [b]
map MultiPhenotype a -> [Objective]
forall a. MultiPhenotype a -> [Objective]
takeObjectiveValues [MultiPhenotype a]
solutions
in Int -> [ProblemType] -> [Objective] -> [[Objective]] -> Objective
wfgHypervolume_sort Int
0 [ProblemType]
ptypes [Objective]
refPoint [[Objective]]
points
wfgHypervolume :: [ProblemType]
-> Point
-> [Point]
-> Double
wfgHypervolume :: [ProblemType] -> [Objective] -> [[Objective]] -> Objective
wfgHypervolume [ProblemType]
ptypes [Objective]
worst [[Objective]]
pts =
let ptsAndTails :: [([Objective], [[Objective]])]
ptsAndTails = [[Objective]] -> [[[Objective]]] -> [([Objective], [[Objective]])]
forall a b. [a] -> [b] -> [(a, b)]
zip [[Objective]]
pts (Int -> [[[Objective]]] -> [[[Objective]]]
forall a. Int -> [a] -> [a]
drop Int
1 ([[Objective]] -> [[[Objective]]]
forall a. [a] -> [[a]]
tails [[Objective]]
pts)) :: [(Point, [Point])]
exclusiveHvs :: [Objective]
exclusiveHvs = (([Objective], [[Objective]]) -> Objective)
-> [([Objective], [[Objective]])] -> [Objective]
forall a b. (a -> b) -> [a] -> [b]
map
(\([Objective]
pt, [[Objective]]
rest) -> [ProblemType]
-> [Objective] -> [Objective] -> [[Objective]] -> Objective
exclusiveHypervolume [ProblemType]
ptypes [Objective]
worst [Objective]
pt [[Objective]]
rest)
[([Objective], [[Objective]])]
ptsAndTails
in [Objective] -> Objective
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Objective]
exclusiveHvs
wfgHypervolume_sort :: Int
-> [ProblemType]
-> Point
-> [Point]
-> Double
wfgHypervolume_sort :: Int -> [ProblemType] -> [Objective] -> [[Objective]] -> Objective
wfgHypervolume_sort Int
k [ProblemType]
ptypes [Objective]
worst [[Objective]]
pts
| [ProblemType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ProblemType]
ptypes Bool -> Bool -> Bool
|| [ProblemType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ProblemType]
ptypes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
k Bool -> Bool -> Bool
|| Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 =
Int -> [ProblemType] -> [Objective] -> [[Objective]] -> Objective
wfgHypervolume_sort Int
0 [ProblemType]
ptypes [Objective]
worst [[Objective]]
pts
| Bool
otherwise =
let ptype :: ProblemType
ptype = [ProblemType]
ptypes [ProblemType] -> Int -> ProblemType
forall a. [a] -> Int -> a
!! Int
k
pts' :: [[Objective]]
pts' = ([Objective] -> [Objective] -> Ordering)
-> [[Objective]] -> [[Objective]]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Objective -> Objective -> Ordering)
-> Objective -> Objective -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip 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` ProblemType -> Int -> [Objective] -> Objective
get ProblemType
ptype Int
k) [[Objective]]
pts
in [ProblemType] -> [Objective] -> [[Objective]] -> Objective
wfgHypervolume [ProblemType]
ptypes [Objective]
worst [[Objective]]
pts'
where
get :: ProblemType -> Int -> [Double] -> Double
get :: ProblemType -> Int -> [Objective] -> Objective
get ProblemType
Minimizing Int
k [Objective]
objvals
| [Objective] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Objective]
objvals Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
k = [Objective]
objvals [Objective] -> Int -> Objective
forall a. [a] -> Int -> a
!! Int
k
| Bool
otherwise = Objective
inf
get ProblemType
Maximizing Int
k [Objective]
objvals
| [Objective] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Objective]
objvals Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
k = [Objective]
objvals [Objective] -> Int -> Objective
forall a. [a] -> Int -> a
!! Int
k
| Bool
otherwise = - Objective
inf
inf :: Double
inf :: Objective
inf = Objective
1Objective -> Objective -> Objective
forall a. Fractional a => a -> a -> a
/Objective
0
limitSet :: [ProblemType]
-> Point
-> [Point]
-> [Point]
limitSet :: [ProblemType] -> [Objective] -> [[Objective]] -> [[Objective]]
limitSet [ProblemType]
ptypes [Objective]
refPoint =
([Objective] -> [Objective]) -> [[Objective]] -> [[Objective]]
forall a b. (a -> b) -> [a] -> [b]
map ((ProblemType -> Objective -> Objective -> Objective)
-> [ProblemType] -> [Objective] -> [Objective] -> [Objective]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 ProblemType -> Objective -> Objective -> Objective
worst [ProblemType]
ptypes [Objective]
refPoint)
where
worst :: ProblemType -> Double -> Double -> Double
worst :: ProblemType -> Objective -> Objective -> Objective
worst ProblemType
Minimizing Objective
x Objective
y | Objective
x Objective -> Objective -> Bool
forall a. Ord a => a -> a -> Bool
> Objective
y = Objective
x
| Bool
otherwise = Objective
y
worst ProblemType
Maximizing Objective
x Objective
y | Objective
x Objective -> Objective -> Bool
forall a. Ord a => a -> a -> Bool
< Objective
y = Objective
x
| Bool
otherwise = Objective
y
nondominatedSet :: [ProblemType]
-> [Point]
-> [Point]
nondominatedSet :: [ProblemType] -> [[Objective]] -> [[Objective]]
nondominatedSet [ProblemType]
ptypes [[Objective]]
points =
let dominates :: DominationCmp a
dominates = [ProblemType] -> DominationCmp a
forall a. [ProblemType] -> DominationCmp a
domination [ProblemType]
ptypes
dummySolutions :: [MultiPhenotype Objective]
dummySolutions = ([Objective] -> MultiPhenotype Objective)
-> [[Objective]] -> [MultiPhenotype Objective]
forall a b. (a -> b) -> [a] -> [b]
map (\[Objective]
objvals -> ([], [Objective]
objvals)) [[Objective]]
points :: [MultiPhenotype Double]
fronts :: [[MultiPhenotype Objective]]
fronts = DominationCmp Objective
-> [MultiPhenotype Objective] -> [[MultiPhenotype Objective]]
forall a.
DominationCmp a -> [MultiPhenotype a] -> [[MultiPhenotype a]]
nondominatedSort DominationCmp Objective
forall a. DominationCmp a
dominates [MultiPhenotype Objective]
dummySolutions :: [[MultiPhenotype Double]]
in case [[MultiPhenotype Objective]]
fronts of
([MultiPhenotype Objective]
nds:[[MultiPhenotype Objective]]
_) -> (MultiPhenotype Objective -> [Objective])
-> [MultiPhenotype Objective] -> [[Objective]]
forall a b. (a -> b) -> [a] -> [b]
map MultiPhenotype Objective -> [Objective]
forall a. MultiPhenotype a -> [Objective]
takeObjectiveValues [MultiPhenotype Objective]
nds
[[MultiPhenotype Objective]]
_ -> []
inclusiveHypervolume :: [ProblemType]
-> Point
-> Point
-> Double
inclusiveHypervolume :: [ProblemType] -> [Objective] -> [Objective] -> Objective
inclusiveHypervolume [ProblemType]
ptypes [Objective]
worst [Objective]
p =
[Objective] -> Objective
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product ([Objective] -> Objective) -> [Objective] -> Objective
forall a b. (a -> b) -> a -> b
$ (ProblemType -> Objective -> Objective -> Objective)
-> [ProblemType] -> [Objective] -> [Objective] -> [Objective]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 ProblemType -> Objective -> Objective -> Objective
hyperside [ProblemType]
ptypes [Objective]
worst [Objective]
p
where
hyperside :: ProblemType -> Double -> Double -> Double
hyperside :: ProblemType -> Objective -> Objective -> Objective
hyperside ProblemType
Minimizing Objective
upper Objective
x = Objective -> Objective
pos (Objective -> Objective) -> Objective -> Objective
forall a b. (a -> b) -> a -> b
$ Objective
upper Objective -> Objective -> Objective
forall a. Num a => a -> a -> a
- Objective
x
hyperside ProblemType
Maximizing Objective
lower Objective
x = Objective -> Objective
pos (Objective -> Objective) -> Objective -> Objective
forall a b. (a -> b) -> a -> b
$ Objective
x Objective -> Objective -> Objective
forall a. Num a => a -> a -> a
- Objective
lower
pos :: Double -> Double
pos :: Objective -> Objective
pos Objective
x = Objective
0.5 Objective -> Objective -> Objective
forall a. Num a => a -> a -> a
* (Objective
x Objective -> Objective -> Objective
forall a. Num a => a -> a -> a
+ Objective -> Objective
forall a. Num a => a -> a
abs Objective
x)
exclusiveHypervolume :: [ProblemType]
-> Point
-> Point
-> [Point]
-> Double
exclusiveHypervolume :: [ProblemType]
-> [Objective] -> [Objective] -> [[Objective]] -> Objective
exclusiveHypervolume [ProblemType]
ptypes [Objective]
worst [Objective]
p [[Objective]]
underlying =
let inclusiveHv :: Objective
inclusiveHv = [ProblemType] -> [Objective] -> [Objective] -> Objective
inclusiveHypervolume [ProblemType]
ptypes [Objective]
worst [Objective]
p
nds :: [[Objective]]
nds = [ProblemType] -> [[Objective]] -> [[Objective]]
nondominatedSet [ProblemType]
ptypes ([[Objective]] -> [[Objective]]) -> [[Objective]] -> [[Objective]]
forall a b. (a -> b) -> a -> b
$ [ProblemType] -> [Objective] -> [[Objective]] -> [[Objective]]
limitSet [ProblemType]
ptypes [Objective]
p [[Objective]]
underlying
underlyingHv :: Objective
underlyingHv = [ProblemType] -> [Objective] -> [[Objective]] -> Objective
wfgHypervolume [ProblemType]
ptypes [Objective]
worst [[Objective]]
nds
in Objective
inclusiveHv Objective -> Objective -> Objective
forall a. Num a => a -> a -> a
- Objective
underlyingHv