content: {-# LANGUAGE RankNTypes #-}
  {- | Performance metrics for multiobjective problems.
  
  -}
  
  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]
  
  
  -- | Calculate the hypervolume indicator using WFG algorithm.
  --
  -- Reference:
  -- While, L., Bradstreet, L., & Barone, L. (2012). A fast way of
  -- calculating exact hypervolumes. Evolutionary Computation, IEEE
  -- Transactions on, 16(1), 86-95.
  --
  hypervolume :: forall fn a . ObjectiveFunction fn a
              => MultiObjectiveProblem fn   -- ^ multiobjective problem @mop@
              -> [Objective]                -- ^ reference point (the worst point)
              -> [MultiPhenotype a]         -- ^ a set of solutions to evaluate
              -> Double                     -- ^ hypervolume
  hypervolume mop refPoint solutions =
      let ptypes = map fst mop :: [ProblemType]
          points = map takeObjectiveValues solutions
      in  wfgHypervolume_sort 0 ptypes refPoint points
  
  
  -- | Basic (non-optimized) WFG algorithm to calculate hypervolume.
  --
  -- Reference: While et al. (2012).
  wfgHypervolume :: [ProblemType]  -- ^ problem types
                 -> Point          -- ^ reference point (the @worst@ point)
                 -> [Point]        -- ^ a set of points
                 -> Double
  wfgHypervolume ptypes worst pts =
      let ptsAndTails = zip pts (drop 1 (tails pts)) :: [(Point, [Point])]
          exclusiveHvs = map
                         (\(pt, rest) -> exclusiveHypervolume ptypes worst pt rest)
                         ptsAndTails
      in  sum exclusiveHvs
  
  
  -- | WFG algorithm to calculate hypervolume with sorting optimization.
  wfgHypervolume_sort :: Int            -- ^ index of the objective to sort
                      -> [ProblemType]  -- ^ problem types
                      -> Point          -- ^ reference point (the @worst@ point)
                      -> [Point]        -- ^ a set of points
                      -> Double
  wfgHypervolume_sort k ptypes worst pts
      | null ptypes || length ptypes <= k || k < 0 =
          wfgHypervolume_sort 0 ptypes worst pts  -- bad input, sort the first objective
      | otherwise =
          let ptype = ptypes !! k
              pts' = sortBy (flip compare `on` get ptype k) pts
          in  wfgHypervolume ptypes worst pts'
      where
        get :: ProblemType -> Int -> [Double] -> Double
        get Minimizing k objvals
            | length objvals > k = objvals !! k
            | otherwise          = inf
        get Maximizing k objvals
            | length objvals > k = objvals !! k
            | otherwise          = - inf
        inf :: Double
        inf = 1/0
  
  
  -- | Construct a limited set (a step of the WFG algorithm).
  --
  -- @
  --     limitSet(S, p) = { limit(x, p) | x \in S }
  --     where limit(<s1, ..., sn>, <p1, ..., pn>) = < worse(s1,p1), ..., worse(sn, pn)>.
  -- @
  limitSet :: [ProblemType] -- ^ problem types
           -> Point         -- ^ reference point
           -> [Point]       -- ^ original set
           -> [Point]       -- ^ limited set
  limitSet ptypes refPoint =
      map (zipWith3 worst ptypes refPoint)
    where
      worst :: ProblemType -> Double -> Double -> Double
      worst Minimizing x y | x > y     = x
                           | otherwise = y
      worst Maximizing x y | x < y     = x
                           | otherwise = y
  
  
  -- | Construct a non-dominated subset (a step of the WFG algorithm).
  nondominatedSet :: [ProblemType]  -- ^ problem types
                  -> [Point]        -- ^ original set
                  -> [Point]        -- ^ a non-dominated subset
  nondominatedSet ptypes points =
      let dominates = domination ptypes
          dummySolutions = map (\objvals -> ([], objvals)) points :: [MultiPhenotype Double]
          fronts = nondominatedSort dominates dummySolutions :: [[MultiPhenotype Double]]
      in  case fronts of
            (nds:_) -> map takeObjectiveValues nds
            _       -> []
  
  
  -- | Calculate inclusive hypervolume of a point @p@ (the size of the
  -- part of the objective space dominated by @p@ alone).
  inclusiveHypervolume :: [ProblemType]  -- ^ problem types
                       -> Point          -- ^ reference point (the @worst@ point)
                       -> Point          -- ^ a point @p@ to evaluate
                       -> Double         -- ^ inclusive hypervolume
  inclusiveHypervolume ptypes worst p =
      product $ zipWith3 hyperside ptypes worst p
   where
      hyperside :: ProblemType -> Double -> Double -> Double
      hyperside Minimizing upper x = pos $ upper - x
      hyperside Maximizing lower x = pos $ x - lower
      -- Positive part: to truncate the hypervolume if an unsuitable
      -- reference point is given (not the worst one possible)
      pos :: Double -> Double
      pos x = 0.5 * (x + abs x)
  
  
  -- | Calculate exclusive hypervolume of a point @p@ relative to the
  -- @underlying@ set (the size of the part of the objective space that
  -- is dominated by @p@, but is not dominated by any member of the
  -- @underlying@ set).
  exclusiveHypervolume :: [ProblemType]  -- ^ problem types
                       -> Point          -- ^ reference point (the @worst@ point)
                       -> Point          -- ^ a point @p@ to evaluate
                       -> [Point]        -- ^ an @underlying@ set of points
                       -> Double         -- ^ exclusive hypervolume
  exclusiveHypervolume ptypes worst p underlying =
      let inclusiveHv = inclusiveHypervolume ptypes worst p
          nds = nondominatedSet ptypes $ limitSet ptypes p underlying
          underlyingHv = wfgHypervolume ptypes worst nds
      in  inclusiveHv - underlyingHv
  