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
