module Moo.GeneticAlgorithm.Selection
(
rouletteSelect
, stochasticUniversalSampling
, tournamentSelect
, withPopulationTransform
, withScale
, rankScale
, withFitnessSharing
, bestFirst
) where
import Moo.GeneticAlgorithm.Types
import Moo.GeneticAlgorithm.Random
import Moo.GeneticAlgorithm.Niching (fitnessSharing)
import Control.Monad (liftM, replicateM)
import Control.Arrow (second)
import Data.List (sortBy)
import Data.Function (on)
withPopulationTransform :: (Population a -> Population a) -> SelectionOp a -> SelectionOp a
withPopulationTransform transform select = \pop -> select (transform pop)
withScale :: (Objective -> Objective) -> SelectionOp a -> SelectionOp a
withScale f select =
let scale = map (second f)
in withPopulationTransform scale select
rankScale :: ProblemType -> Population a -> Population a
rankScale problem pop =
let sorted = bestFirst (opposite problem) pop
worst = takeObjectiveValue . head $ sorted
in ranks 1 worst sorted
where
ranks _ _ [] = []
ranks rank worst ((genome,objective):rest)
| worst == objective = (genome,rank) : ranks rank worst rest
| otherwise = (genome,rank+1) : ranks (rank+1) objective rest
opposite Minimizing = Maximizing
opposite Maximizing = Minimizing
withFitnessSharing ::
(Phenotype a -> Phenotype a -> Double)
-> Double
-> Double
-> ProblemType
-> (SelectionOp a -> SelectionOp a)
withFitnessSharing dist r alpha ptype =
withPopulationTransform (fitnessSharing dist r alpha ptype)
rouletteSelect :: Int -> SelectionOp a
rouletteSelect n xs = replicateM n roulette1
where
fs = map takeObjectiveValue xs
xs' = zip xs (scanl1 (+) fs)
sumScores = (snd . last) xs'
roulette1 = do
rand <- (sumScores*) `liftM` getDouble
return $ (fst . head . dropWhile ((rand >) . snd)) xs'
tournamentSelect :: ProblemType
-> Int
-> Int
-> SelectionOp a
tournamentSelect problem size n xs = replicateM n tournament1
where
tournament1 = do
contestants <- randomSample size xs
let winner = head $ bestFirst problem contestants
return winner
stochasticUniversalSampling :: Int
-> SelectionOp a
stochasticUniversalSampling n phenotypes = do
let total = sum . map takeObjectiveValue $ phenotypes
let step = total / (fromIntegral n)
start <- getRandomR (0, step)
let stops = [start + (fromIntegral i)*step | i <- [0..(n1)]]
let cumsums = scanl1 (+) (map takeObjectiveValue phenotypes)
let ranges = zip (0:cumsums) cumsums
return $ selectAtStops [] phenotypes stops ranges
where
selectAtStops selected _ [] _ = selected
selectAtStops selected [] _ _ = selected
selectAtStops selected phenotypes@(x:xs) stops@(s:ss) ranges@((l,r):lrs)
| (l <= s && s < r) = selectAtStops (x:selected) phenotypes ss ranges
| s >= r = selectAtStops selected xs stops lrs
| s < l = error "stochasticUniformSampling: stop < leftSum"
selectAtStops _ _ _ _ = error "stochasticUniversalSampling: unbalanced ranges?"
sortByFitnessDesc :: Population a -> Population a
sortByFitnessDesc = sortBy (flip compare `on` snd)
sortByCostAsc :: Population a -> Population a
sortByCostAsc = sortBy (compare `on` snd)
bestFirst :: ProblemType -> Population a -> Population a
bestFirst Maximizing = sortByFitnessDesc
bestFirst Minimizing = sortByCostAsc