1
\$\begingroup\$

This algorithm sorts a list of Individuals, each with two fitness values, into what's called non-dominated fronts. A non-dominated front is a set of individuals where none of the individuals dominate each other. An individual is said to dominate another if is equal or lower (<=) for all fitness values and lower (<) in at least one fitness value. And so [1,1] dominates both [1,2] and [2,1], but neither of the last two dominate each other. The rank of an individual indicates which front it is a member of. [1,1] would have rank 0; [1,2] and [2,1] would both have rank 1.

Non-dominant sorting is a small piece in bigger puzzles such as multi-objective optimization with genetic algorithms. If you are interested in how the algorithm works you can check out Jensen 2003, but I'm completely new to Haskell so I'm sure there's a lot to pick on without understanding squat about the actual algorithm. Here it goes:

RankSort.hs

module RankSort (
) where

import qualified Data.Vector as V

import           Genome
import           SortUtils

go :: String
go = let vind = Prelude.map toInd [(4,4),(2,3),(4,3),(1,1),(1,3),(2,1),(3,1),(1,1)]
         pool = V.fromList vind
         cmp x y = indCmpFit x y 0
         pool_s = poolSort pool cmp
         fronts = V.fromList [V.fromList []]
     in show $ rankSort pool_s fronts

rankSort :: Pool -> Fronts -> Fronts
rankSort pool fronts
  | V.length fronts == 1 && V.length (fronts V.! 0) == 0 = rankSort new_pool start_front -- start case
  | V.length pool == 1 = new_fronts --end case: sort the last remaining individual and return the sorted fronts
  | otherwise = rankSort new_pool new_fronts
  where
    new_pool = V.tail pool
    start_front = V.fromList [V.fromList [(pool V.! 0){ rank = 0 }]] -- first ind. always has rank 0
    upd_ind = rankIndex (V.head pool) fronts
    rank' = rank upd_ind
    upd_front = V.snoc (fronts V.! rank') upd_ind -- add individual to already existing front
    new_fronts = if rank' == V.length fronts
      then V.snoc fronts (V.fromList [upd_ind]) -- add a new front with ind as member
      else V.update fronts (V.fromList [(rank', upd_front)]) -- add individual to existing front


-- Take an individual and find the index of the front where it is not dominated by any members. This index is the rank.
rankIndex :: Ind -> Fronts -> Ind
rankIndex ind fronts
  | ind `domByFront` V.last fronts = ind { rank = V.length fronts }
  | otherwise = ind { rank = binSearch ind fronts 0 (V.length fronts - 1) }


-- Find the index of the front where the individual can be inserted without being dominated
-- Note that each individual in fronts[k] dominates at least one member of fronts[k+1].
-- Therefore the correct insertion point for an individual is k if
-- (ind `domByFront` fronts[k-1][-1]) and not (ind `domByFront` fronts[k][-1])
binSearch :: Ind -> Fronts -> Int -> Int -> Int
binSearch ind_a fronts low high
  | low == high = low
  | ind_b `dominates` ind_a = binSearch ind_a fronts (mid+1) high
  | otherwise = binSearch ind_a fronts low mid
  where
    mid = (low+high) `div` 2
    ind_b = V.last (fronts V.! mid)

-- Returns true of individual x dominates individual y; false if y dominates x or neither dominate each other
-- An individual x dominates an individual y if it is no worse in all objectives and strictly better in at least one.
-- For our problem, better means less.
dominates :: Ind -> Ind -> Bool
ind_a `dominates` ind_b = strictly_better && no_worse
  where
    strictly_better = V.or (V.zipWith (<) x y)
    no_worse = V.and (V.zipWith (<=) x y)
    x = fitnesses ind_a
    y = fitnesses ind_b

-- Returns whether or not an individual is dominated by any members of the front
domByFront :: Ind -> Pool -> Bool
ind `domByFront` front = V.any dom front
  where
    dom x = x `dominates` ind

Genome.hs

module Genome (
  Ind(fitnesses, genome, rank, cdist), Pool, Fronts,
  toInd, setRankP, setRankI, setCdistP, setCdistI, getFit
) where

import qualified Data.Vector                  as V
import           Data.Vector.Algorithms.Intro as VA
import qualified Data.Vector.Mutable          as VM

data Ind = Ind { fitnesses :: V.Vector Float
               , genome    :: String
               , rank      :: Int
               , cdist     :: Float -- Crowding distance
               }
type Pool = V.Vector Ind
type Fronts = V.Vector Pool

instance Show Ind where
   show Ind{ fitnesses = f, rank = r } = show f ++ "r" ++ show r

toInd :: (Float, Float) -> Ind
toInd (f1, f2) = Ind (V.fromList [f1, f2]) "" (-1) (-1)

setRankP :: Pool -> Int -> Int -> Pool
setRankP pool idx rank' = V.update pool (V.fromList [(idx, updInd)])
  where updInd = (pool V.! idx) { rank = rank' }

setRankI :: Ind -> Int -> Ind
setRankI ind rank' = ind { rank = rank' }

setCdistP :: Pool -> Int -> Float -> Pool
setCdistP pool idx cdist' = V.update pool (V.fromList [(idx, updInd)])
  where updInd = (pool V.! idx) { cdist = cdist' }

setCdistI :: Ind -> Float -> Ind
setCdistI ind cdist' = ind { cdist = cdist' }

getFit :: Pool -> Int -> Int -> Float
getFit pool indIdx fitIdx = fitnesses (pool V.! indIdx) V.! fitIdx

SortUtils.hs

module SortUtils (
  indCmpFit, poolSort
) where

import           Control.Monad.ST
import qualified Data.Vector                  as V
import           Data.Vector.Algorithms.Intro as VA

import           Genome

poolSort :: Pool-> (Ind -> Ind -> Ordering) -> Pool
poolSort pool cmp = runST (do
    v <- V.unsafeThaw pool
    VA.sortBy cmp v
    V.unsafeFreeze v)


-- Comparator to sort a list of individuals by increasing order of fitIdx
-- and for individuals with equal fitIdx, with increasing order of fitIdx+1
indCmpFit :: Ind -> Ind -> Int -> Ordering
indCmpFit x y fitIdx
  | a0 < b0 = LT
  | a0 > b0 = GT
  -- Can assume (fst x) == (fst y) beneath
  | a1 < b1 = LT
  | a1 > b1 = GT
  | a1 == b1 = EQ
  where
    f1 = if fitIdx == 0 then 0 else 1
    f2 = if fitIdx == 0 then 1 else 0
    a0 = fitnesses x V.! f1
    a1 = fitnesses x V.! f2
    b0 = fitnesses y V.! f1
    b1 = fitnesses y V.! f2
\$\endgroup\$
2
\$\begingroup\$

Here's a first tweak: Tighten recursion so there's fewer lines to read that contain recursion.

go :: String
go = let vind = Prelude.map toInd [(4,4),(2,3),(4,3),(1,1),(1,3),(2,1),(3,1),(1,1)]
         pool = V.fromList vind
         cmp x y = indCmpFit x y 0
         pool_s = poolSort pool cmp
     in show $ rankSort pool_s

rankSort :: Pool -> Fronts
rankSort = foldl new_fronts start_front where
  start_front = V.fromList [V.fromList [(pool V.! 0){ rank = 0 }]] -- first ind. always has rank 0
  new_fronts :: Fronts -> Ind -> Fronts
  new_fronts fronts ind = if rank' == V.length fronts
    then V.snoc fronts (V.fromList [upd_ind]) -- add a new front with ind as member
    else V.update fronts (V.fromList [(rank', upd_front)]) -- add individual to existing front
    where
      upd_ind = rankIndex ind fronts
      rank' = rank upd_ind
      upd_front = V.snoc (fronts V.! rank') upd_ind -- add individual to already existing front

Edit: Second: Shuffle arguments around so eta reduction is feasible. Also inline most stuff that's only used once.

indCmpFit :: Int -> Ind -> Ind -> Ordering
indCmpFit fitIdx x y

go :: String
go = let vind = Prelude.map toInd [(4,4),(2,3),(4,3),(1,1),(1,3),(2,1),(3,1),(1,1)]
     in show $ rankSort $ poolSort (V.fromList vind) (indCmpFit 0)
\$\endgroup\$
  • \$\begingroup\$ Should I inline stuff that's used many times, but only through recursion? I'm thinking about x and y in RankSort.dominates \$\endgroup\$ – tsorn May 10 '16 at 18:22
  • \$\begingroup\$ There's something off with the first tweak: "Expected type: Fronts, Actual type: (V.Vector Fronts -> Fronts)". I'm not too familiar with folds to figure out what's what just yet. Maybe the syntax for V.foldl is different. \$\endgroup\$ – tsorn May 10 '16 at 19:03
  • \$\begingroup\$ Ah, new_fronts is flipped. If the order in which the pool is passed to rankSort is irrelevant, replace foldl by foldr, otherwise swap around the arguments as I just edited in. \$\endgroup\$ – Gurkenglas May 10 '16 at 19:19
  • \$\begingroup\$ Yep, that works! The start_front needs to be empty otherwise the first individual will be added twice. \$\endgroup\$ – tsorn May 10 '16 at 19:40

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.