{- |

Selection operators for genetic algorithms.

-}

module Moo.GeneticAlgorithm.Selection
  (
    rouletteSelect
  , stochasticUniversalSampling
  , tournamentSelect
  -- ** Scaling and niching

  , withPopulationTransform
  , withScale
  , rankScale
  , withFitnessSharing
  -- ** Sorting

  , 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)
import qualified Data.Vector as V



-- | Apply given scaling or other transform to population before selection.

withPopulationTransform :: (Population a -> Population a) -> SelectionOp a -> SelectionOp a
withPopulationTransform :: (Population a -> Population a) -> SelectionOp a -> SelectionOp a
withPopulationTransform Population a -> Population a
transform SelectionOp a
select = \Population a
pop -> SelectionOp a
select (Population a -> Population a
transform Population a
pop)


-- | Transform objective function values before seletion.

withScale :: (Objective -> Objective) -> SelectionOp a -> SelectionOp a
withScale :: (Objective -> Objective) -> SelectionOp a -> SelectionOp a
withScale Objective -> Objective
f SelectionOp a
select =
    let scale :: [(d, Objective)] -> [(d, Objective)]
scale = ((d, Objective) -> (d, Objective))
-> [(d, Objective)] -> [(d, Objective)]
forall a b. (a -> b) -> [a] -> [b]
map ((Objective -> Objective) -> (d, Objective) -> (d, Objective)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Objective -> Objective
f)
    in  (Population a -> Population a) -> SelectionOp a -> SelectionOp a
forall a.
(Population a -> Population a) -> SelectionOp a -> SelectionOp a
withPopulationTransform Population a -> Population a
forall d. [(d, Objective)] -> [(d, Objective)]
scale SelectionOp a
select

-- | Replace objective function values in the population with their

-- ranks.  For a population of size @n@, a genome with the best value

-- of objective function has rank @n' <= n@, and a genome with the

-- worst value of objective function gets rank @1@.

--

-- 'rankScale' may be useful to avoid domination of few super-genomes

-- in 'rouletteSelect' or to apply 'rouletteSelect' when an objective

-- function is not necessarily positive.

rankScale :: ProblemType -> Population a -> Population a
rankScale :: ProblemType -> Population a -> Population a
rankScale ProblemType
problem Population a
pop =
    let sorted :: Population a
sorted = ProblemType -> Population a -> Population a
forall a. ProblemType -> Population a -> Population a
bestFirst (ProblemType -> ProblemType
opposite ProblemType
problem) Population a
pop  -- worst first

        worst :: Objective
worst = Phenotype a -> Objective
forall a. Phenotype a -> Objective
takeObjectiveValue (Phenotype a -> Objective)
-> (Population a -> Phenotype a) -> Population a -> Objective
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Population a -> Phenotype a
forall a. [a] -> a
head (Population a -> Objective) -> Population a -> Objective
forall a b. (a -> b) -> a -> b
$ Population a
sorted
    in  Objective -> Objective -> Population a -> Population a
forall t a a. (Eq t, Num a) => a -> t -> [(a, t)] -> [(a, a)]
ranks Objective
1 Objective
worst Population a
sorted
    where
      ranks :: a -> t -> [(a, t)] -> [(a, a)]
ranks a
_ t
_ [] = []
      ranks a
rank t
worst ((a
genome,t
objective):[(a, t)]
rest)
          | t
worst t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
objective  = (a
genome,a
rank)   (a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
: a -> t -> [(a, t)] -> [(a, a)]
ranks a
rank t
worst [(a, t)]
rest
          | Bool
otherwise           = (a
genome,a
ranka -> a -> a
forall a. Num a => a -> a -> a
+a
1) (a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
: a -> t -> [(a, t)] -> [(a, a)]
ranks (a
ranka -> a -> a
forall a. Num a => a -> a -> a
+a
1) t
objective [(a, t)]
rest
      opposite :: ProblemType -> ProblemType
opposite ProblemType
Minimizing = ProblemType
Maximizing
      opposite ProblemType
Maximizing = ProblemType
Minimizing


-- | A popular niching method proposed by D. Goldberg and

-- J. Richardson in 1987. The shared fitness of the individual is inversely

-- protoptional to its niche count.

-- The method expects the objective function to be non-negative.

--

-- An extension for minimization problems is implemented by

-- making the fitnes proportional to its niche count (rather than

-- inversely proportional).

--

-- Reference: Chen, J. H., Goldberg, D. E., Ho, S. Y., & Sastry,

-- K. (2002, July). Fitness inheritance in multiobjective

-- optimization. In Proceedings of the Genetic and Evolutionary

-- Computation Conference (pp. 319-326). Morgan Kaufmann Publishers

-- Inc..

withFitnessSharing ::
    (Phenotype a -> Phenotype a -> Double)  -- ^ distance function

    -> Double  -- ^ niche radius

    -> Double  -- ^ niche compression exponent @alpha@ (usually 1)

    -> ProblemType   -- ^ type of the optimization problem

    -> (SelectionOp a -> SelectionOp a)
withFitnessSharing :: (Phenotype a -> Phenotype a -> Objective)
-> Objective
-> Objective
-> ProblemType
-> SelectionOp a
-> SelectionOp a
withFitnessSharing Phenotype a -> Phenotype a -> Objective
dist Objective
r Objective
alpha ProblemType
ptype =
    (Population a -> Population a) -> SelectionOp a -> SelectionOp a
forall a.
(Population a -> Population a) -> SelectionOp a -> SelectionOp a
withPopulationTransform ((Phenotype a -> Phenotype a -> Objective)
-> Objective
-> Objective
-> ProblemType
-> Population a
-> Population a
forall a.
(Phenotype a -> Phenotype a -> Objective)
-> Objective
-> Objective
-> ProblemType
-> Population a
-> Population a
fitnessSharing Phenotype a -> Phenotype a -> Objective
dist Objective
r Objective
alpha ProblemType
ptype)


-- |Objective-proportionate (roulette wheel) selection: select @n@

-- random items with each item's chance of being selected is

-- proportional to its objective function (fitness).

-- Objective function should be non-negative.

rouletteSelect :: Int -> SelectionOp a
rouletteSelect :: Int -> SelectionOp a
rouletteSelect Int
n Population a
xs = Int
-> RandT PureMT Identity (Phenotype a)
-> RandT PureMT Identity (Population a)
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n RandT PureMT Identity (Phenotype a)
roulette1
  where
  fs :: [Objective]
fs = (Phenotype a -> Objective) -> Population a -> [Objective]
forall a b. (a -> b) -> [a] -> [b]
map Phenotype a -> Objective
forall a. Phenotype a -> Objective
takeObjectiveValue Population a
xs
  xs' :: [(Phenotype a, Objective)]
xs' = Population a -> [Objective] -> [(Phenotype a, Objective)]
forall a b. [a] -> [b] -> [(a, b)]
zip Population a
xs ((Objective -> Objective -> Objective) -> [Objective] -> [Objective]
forall a. (a -> a -> a) -> [a] -> [a]
scanl1 Objective -> Objective -> Objective
forall a. Num a => a -> a -> a
(+) [Objective]
fs)
  sumScores :: Objective
sumScores = ((Phenotype a, Objective) -> Objective
forall a b. (a, b) -> b
snd ((Phenotype a, Objective) -> Objective)
-> ([(Phenotype a, Objective)] -> (Phenotype a, Objective))
-> [(Phenotype a, Objective)]
-> Objective
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Phenotype a, Objective)] -> (Phenotype a, Objective)
forall a. [a] -> a
last) [(Phenotype a, Objective)]
xs'
  roulette1 :: RandT PureMT Identity (Phenotype a)
roulette1 = do
    Objective
rand <- (Objective
sumScoresObjective -> Objective -> Objective
forall a. Num a => a -> a -> a
*) (Objective -> Objective)
-> RandT PureMT Identity Objective
-> RandT PureMT Identity Objective
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` RandT PureMT Identity Objective
getDouble
    Phenotype a -> RandT PureMT Identity (Phenotype a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phenotype a -> RandT PureMT Identity (Phenotype a))
-> Phenotype a -> RandT PureMT Identity (Phenotype a)
forall a b. (a -> b) -> a -> b
$ ((Phenotype a, Objective) -> Phenotype a
forall a b. (a, b) -> a
fst ((Phenotype a, Objective) -> Phenotype a)
-> ([(Phenotype a, Objective)] -> (Phenotype a, Objective))
-> [(Phenotype a, Objective)]
-> Phenotype a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Phenotype a, Objective)] -> (Phenotype a, Objective)
forall a. [a] -> a
head ([(Phenotype a, Objective)] -> (Phenotype a, Objective))
-> ([(Phenotype a, Objective)] -> [(Phenotype a, Objective)])
-> [(Phenotype a, Objective)]
-> (Phenotype a, Objective)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Phenotype a, Objective) -> Bool)
-> [(Phenotype a, Objective)] -> [(Phenotype a, Objective)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Objective
rand Objective -> Objective -> Bool
forall a. Ord a => a -> a -> Bool
>) (Objective -> Bool)
-> ((Phenotype a, Objective) -> Objective)
-> (Phenotype a, Objective)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Phenotype a, Objective) -> Objective
forall a b. (a, b) -> b
snd)) [(Phenotype a, Objective)]
xs'

-- |Performs tournament selection among @size@ individuals and

-- returns the winner. Repeat @n@ times.

tournamentSelect :: ProblemType  -- ^ type of the optimization problem

                 -> Int -- ^ size of the tournament group

                 -> Int -- ^ how many tournaments to run

                 -> SelectionOp a
tournamentSelect :: ProblemType -> Int -> Int -> SelectionOp a
tournamentSelect ProblemType
problem Int
size Int
n Population a
xs = do
    let popvec :: Vector (Phenotype a)
popvec = Population a -> Vector (Phenotype a)
forall a. [a] -> Vector a
V.fromList Population a
xs
    let popsize :: Int
popsize = Vector (Phenotype a) -> Int
forall a. Vector a -> Int
V.length Vector (Phenotype a)
popvec
    [[Int]]
groups <- Int -> RandT PureMT Identity [Int] -> RandT PureMT Identity [[Int]]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (RandT PureMT Identity [Int] -> RandT PureMT Identity [[Int]])
-> RandT PureMT Identity [Int] -> RandT PureMT Identity [[Int]]
forall a b. (a -> b) -> a -> b
$ Int -> Int -> RandT PureMT Identity [Int]
randomSampleIndices Int
size Int
popsize
    SelectionOp a
forall (m :: * -> *) a. Monad m => a -> m a
return SelectionOp a -> SelectionOp a
forall a b. (a -> b) -> a -> b
$ ([Int] -> Phenotype a) -> [[Int]] -> Population a
forall a b. (a -> b) -> [a] -> [b]
map (ProblemType -> Vector (Phenotype a) -> [Int] -> Phenotype a
forall a.
ProblemType -> Vector (Phenotype a) -> [Int] -> Phenotype a
tournament1 ProblemType
problem Vector (Phenotype a)
popvec) [[Int]]
groups
  where
    tournament1 :: ProblemType -> Vector (Phenotype a) -> [Int] -> Phenotype a
tournament1 ProblemType
problem Vector (Phenotype a)
popvec [Int]
group =
      let contestants :: [Phenotype a]
contestants = (Int -> Phenotype a) -> [Int] -> [Phenotype a]
forall a b. (a -> b) -> [a] -> [b]
map (Vector (Phenotype a)
popvec Vector (Phenotype a) -> Int -> Phenotype a
forall a. Vector a -> Int -> a
V.!) [Int]
group
          best :: Phenotype a
best = [Phenotype a] -> Phenotype a
forall a. [a] -> a
head ([Phenotype a] -> Phenotype a) -> [Phenotype a] -> Phenotype a
forall a b. (a -> b) -> a -> b
$ ProblemType -> [Phenotype a] -> [Phenotype a]
forall a. ProblemType -> Population a -> Population a
bestFirst ProblemType
problem [Phenotype a]
contestants
      in  Phenotype a
best

-- | Stochastic universal sampling (SUS) is a selection technique

-- similar to roulette wheel selection. It gives weaker members a fair

-- chance to be selected, which is proportinal to their

-- fitness. Objective function should be non-negative.

stochasticUniversalSampling :: Int  -- ^ how many genomes to select

                            -> SelectionOp a
stochasticUniversalSampling :: Int -> SelectionOp a
stochasticUniversalSampling Int
n Population a
phenotypes = do
    let total :: Objective
total = [Objective] -> Objective
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Objective] -> Objective)
-> (Population a -> [Objective]) -> Population a -> Objective
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Phenotype a -> Objective) -> Population a -> [Objective]
forall a b. (a -> b) -> [a] -> [b]
map Phenotype a -> Objective
forall a. Phenotype a -> Objective
takeObjectiveValue (Population a -> Objective) -> Population a -> Objective
forall a b. (a -> b) -> a -> b
$ Population a
phenotypes
    let step :: Objective
step = Objective
total Objective -> Objective -> Objective
forall a. Fractional a => a -> a -> a
/ (Int -> Objective
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
    Objective
start <- (Objective, Objective) -> RandT PureMT Identity Objective
forall a. Random a => (a, a) -> Rand a
getRandomR (Objective
0, Objective
step)
    let stops :: [Objective]
stops = [Objective
start Objective -> Objective -> Objective
forall a. Num a => a -> a -> a
+ (Int -> Objective
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)Objective -> Objective -> Objective
forall a. Num a => a -> a -> a
*Objective
step | Int
i <- [Int
0..(Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)]]
    let cumsums :: [Objective]
cumsums = (Objective -> Objective -> Objective) -> [Objective] -> [Objective]
forall a. (a -> a -> a) -> [a] -> [a]
scanl1 Objective -> Objective -> Objective
forall a. Num a => a -> a -> a
(+) ((Phenotype a -> Objective) -> Population a -> [Objective]
forall a b. (a -> b) -> [a] -> [b]
map Phenotype a -> Objective
forall a. Phenotype a -> Objective
takeObjectiveValue Population a
phenotypes)
    let ranges :: [(Objective, Objective)]
ranges = [Objective] -> [Objective] -> [(Objective, Objective)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Objective
0Objective -> [Objective] -> [Objective]
forall a. a -> [a] -> [a]
:[Objective]
cumsums) [Objective]
cumsums
    -- for every stop select a phenotype with left cumsum <= stop < right cumsum

    SelectionOp a
forall (m :: * -> *) a. Monad m => a -> m a
return SelectionOp a -> SelectionOp a
forall a b. (a -> b) -> a -> b
$ Population a
-> Population a
-> [Objective]
-> [(Objective, Objective)]
-> Population a
forall a a. Ord a => [a] -> [a] -> [a] -> [(a, a)] -> [a]
selectAtStops [] Population a
phenotypes [Objective]
stops [(Objective, Objective)]
ranges
  where
    selectAtStops :: [a] -> [a] -> [a] -> [(a, a)] -> [a]
selectAtStops [a]
selected [a]
_ [] [(a, a)]
_ = [a]
selected  -- no more stop points

    selectAtStops [a]
selected [] [a]
_ [(a, a)]
_ = [a]
selected  -- no more phenotypes

    selectAtStops [a]
selected phenotypes :: [a]
phenotypes@(a
x:[a]
xs) stops :: [a]
stops@(a
s:[a]
ss) ranges :: [(a, a)]
ranges@((a
l,a
r):[(a, a)]
lrs)
       | (a
l a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
s Bool -> Bool -> Bool
&& a
s a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
r) = [a] -> [a] -> [a] -> [(a, a)] -> [a]
selectAtStops (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
selected) [a]
phenotypes [a]
ss [(a, a)]
ranges  -- select a phenotype

       | a
s a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
r = [a] -> [a] -> [a] -> [(a, a)] -> [a]
selectAtStops [a]
selected [a]
xs [a]
stops [(a, a)]
lrs  -- skip a phenotype AND the range

       | a
s a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
l  = [Char] -> [a]
forall a. HasCallStack => [Char] -> a
error [Char]
"stochasticUniformSampling: stop < leftSum"  -- should never happen

    selectAtStops [a]
_ [a]
_ [a]
_ [(a, a)]
_ = [Char] -> [a]
forall a. HasCallStack => [Char] -> a
error [Char]
"stochasticUniversalSampling: unbalanced ranges?"  -- should never happen


-- | Sort population by decreasing objective function (also known as

-- fitness for maximization problems). The genomes with the highest

-- fitness are put in the head of the list.

sortByFitnessDesc :: Population a -> Population a
sortByFitnessDesc :: Population a -> Population a
sortByFitnessDesc = ((Genome a, Objective) -> (Genome a, Objective) -> Ordering)
-> Population a -> Population a
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Objective -> Objective -> Ordering)
-> Objective -> Objective -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip Objective -> Objective -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Objective -> Objective -> Ordering)
-> ((Genome a, Objective) -> Objective)
-> (Genome a, Objective)
-> (Genome a, Objective)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Genome a, Objective) -> Objective
forall a b. (a, b) -> b
snd)

-- | Sort population by increasing objective function (also known as

-- cost for minimization problems). The genomes with the smallest

-- cost are put in the head of the list.

sortByCostAsc :: Population a -> Population a
sortByCostAsc :: Population a -> Population a
sortByCostAsc = ((Genome a, Objective) -> (Genome a, Objective) -> Ordering)
-> Population a -> Population a
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Objective -> Objective -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Objective -> Objective -> Ordering)
-> ((Genome a, Objective) -> Objective)
-> (Genome a, Objective)
-> (Genome a, Objective)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Genome a, Objective) -> Objective
forall a b. (a, b) -> b
snd)

-- | Reorders a list of individual solutions,

-- by putting the best in the head of the list.

bestFirst :: ProblemType -> Population a -> Population a
bestFirst :: ProblemType -> Population a -> Population a
bestFirst ProblemType
Maximizing = Population a -> Population a
forall a. Population a -> Population a
sortByFitnessDesc
bestFirst ProblemType
Minimizing = Population a -> Population a
forall a. Population a -> Population a
sortByCostAsc