# Haskell Non-Dominated sorting

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  ## 1 Answer 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)

• Should I inline stuff that's used many times, but only through recursion? I'm thinking about x and y in RankSort.dominates – tsorn May 10 '16 at 18:22
• 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. – tsorn May 10 '16 at 19:03
• 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. – Gurkenglas May 10 '16 at 19:19
• Yep, that works! The start_front needs to be empty otherwise the first individual will be added twice. – tsorn May 10 '16 at 19:40