Parametrize selection, add tournament, remove erroneous proportionate
This commit is contained in:
parent
509e7d0361
commit
e346270907
129
src/GA.hs
129
src/GA.hs
|
@ -109,26 +109,6 @@ Populations are just basic non-empty lists.
|
||||||
-}
|
-}
|
||||||
type Population i = NonEmpty i
|
type Population i = NonEmpty i
|
||||||
|
|
||||||
{-|
|
|
||||||
Selects one individual from the population using proportionate selection.
|
|
||||||
-}
|
|
||||||
proportionate1 :: (Individual i, MonadRandom m) => Population i -> m i
|
|
||||||
proportionate1 pop =
|
|
||||||
sequence ((\i -> (,i) <$> fitness i) <$> pop)
|
|
||||||
>>= sample . fromWeightedList . NE.toList
|
|
||||||
|
|
||||||
{-|
|
|
||||||
Selects @n@ individuals from the population using proportionate selection.
|
|
||||||
-}
|
|
||||||
proportionate
|
|
||||||
:: (Individual i, MonadRandom m)
|
|
||||||
=> N
|
|
||||||
-> Population i
|
|
||||||
-> m (NonEmpty i)
|
|
||||||
proportionate n pop
|
|
||||||
| n > 1 = (<|) <$> proportionate1 pop <*> proportionate (n - 1) pop
|
|
||||||
| otherwise = (:|) <$> proportionate1 pop <*> return []
|
|
||||||
|
|
||||||
{-|
|
{-|
|
||||||
Produces offspring circularly from the given list of parents.
|
Produces offspring circularly from the given list of parents.
|
||||||
-}
|
-}
|
||||||
|
@ -216,18 +196,24 @@ bests = flip bestsBy fitness
|
||||||
|
|
||||||
-- TODO add top x percent parent selection (select n guys, sort by fitness first)
|
-- TODO add top x percent parent selection (select n guys, sort by fitness first)
|
||||||
{-|
|
{-|
|
||||||
Performs one iteration of the genetic algorithm.
|
Performs one iteration of a steady state genetic algorithm that in each
|
||||||
|
iteration that creates @k@ offspring simply deletes the worst @k@ individuals
|
||||||
|
while making sure that the given percentage of elitists survive (at least 1
|
||||||
|
elitist, even if the percentage is 0 or low enough for rounding to result in 0
|
||||||
|
elitists).
|
||||||
-}
|
-}
|
||||||
step
|
stepSteady
|
||||||
:: (Individual i, MonadRandom m, Monad m)
|
:: (Individual i, MonadRandom m, Monad m)
|
||||||
=> N -- ^ number of parents @nParents@ for creating @nParents@ children
|
=> Selection m i -- ^ Mechanism for selecting parents
|
||||||
-> N -- ^ how many crossover points (the @nX@ in @nX@-point crossover)
|
-> N -- ^ Number of parents @nParents@ for creating @nParents@ children
|
||||||
-> R -- ^ elitism ratio @pElite@
|
-> N -- ^ How many crossover points (the @nX@ in @nX@-point crossover)
|
||||||
|
-> R -- ^ Elitism ratio @pElite@
|
||||||
-> Population i
|
-> Population i
|
||||||
-> m (Population i)
|
-> m (Population i)
|
||||||
-- TODO parametrize selection: 'proportionate' and 'worst'
|
stepSteady select nParents nX pElite pop = do
|
||||||
step nParents nX pElite pop = do
|
-- TODO Consider keeping the fitness evaluations already done for pop (so we
|
||||||
iParents <- proportionate nParents pop
|
-- only reevaluate iChildren)
|
||||||
|
iParents <- select nParents pop
|
||||||
iChildren <- NE.filter (`notElem` pop) <$> children nX iParents
|
iChildren <- NE.filter (`notElem` pop) <$> children nX iParents
|
||||||
let pop' = pop `NE.appendl` iChildren
|
let pop' = pop `NE.appendl` iChildren
|
||||||
(elitists, rest) <- bests nBest pop'
|
(elitists, rest) <- bests nBest pop'
|
||||||
|
@ -264,24 +250,101 @@ solution.
|
||||||
-}
|
-}
|
||||||
run
|
run
|
||||||
:: (Individual i, Monad m, MonadRandom m)
|
:: (Individual i, Monad m, MonadRandom m)
|
||||||
=> N -- ^ number of parents @nParents@ for creating @nParents@ children
|
=> Selection m i -- ^ Mechanism for selecting parents
|
||||||
-> N -- ^ how many crossover points (the @nX@ in @nX@-point crossover)
|
-> N -- ^ Number of parents @nParents@ for creating @nParents@ children
|
||||||
-> R -- ^ elitism ratio @pElite@
|
-> N -- ^ How many crossover points (the @nX@ in @nX@-point crossover)
|
||||||
|
-> R -- ^ Elitism ratio @pElite@
|
||||||
-> Population i
|
-> Population i
|
||||||
-> Termination i
|
-> Termination i
|
||||||
-> Producer (Int, R) m (Population i)
|
-> Producer (Int, R) m (Population i)
|
||||||
run nParents nX pElite pop term = step' 0 pop
|
run select nParents nX pElite pop term = step' 0 pop
|
||||||
where
|
where
|
||||||
step' t pop
|
step' t pop
|
||||||
| term pop t = return pop
|
| term pop t = return pop
|
||||||
| otherwise = do
|
| otherwise = do
|
||||||
pop' <- lift $ step nParents nX pElite pop
|
pop' <- lift $ stepSteady select nParents nX pElite pop
|
||||||
(iBests, _) <- lift $ bests 1 pop'
|
(iBests, _) <- lift $ bests 1 pop'
|
||||||
fs <- lift . sequence $ fitness <$> iBests
|
fs <- lift . sequence $ fitness <$> iBests
|
||||||
let fBest = NE.head fs
|
let fBest = NE.head fs
|
||||||
yield (t, fBest)
|
yield (t, fBest)
|
||||||
step' (t + 1) pop'
|
step' (t + 1) pop'
|
||||||
|
|
||||||
|
-- * Selection mechanisms
|
||||||
|
|
||||||
|
{-|
|
||||||
|
A function generating a monadic action which selects a given number of
|
||||||
|
individuals from the given population.
|
||||||
|
-}
|
||||||
|
type Selection m i = N -> Population i -> m (NonEmpty i)
|
||||||
|
|
||||||
|
{-|
|
||||||
|
Selects @n@ individuals from the population the given mechanism by repeatedly
|
||||||
|
selecting a single individual using the given selection mechanism (with
|
||||||
|
replacement, so the same individual can be selected multiple times).
|
||||||
|
-}
|
||||||
|
chain
|
||||||
|
:: (Individual i, MonadRandom m)
|
||||||
|
=> (Population i -> m i)
|
||||||
|
-> Selection m i
|
||||||
|
-- TODO Ensure that the same individual is not selected multiple times
|
||||||
|
-- (require Selections to partition)
|
||||||
|
chain select1 n pop
|
||||||
|
| n > 1 = (<|) <$> select1 pop <*> chain select1 (n - 1) pop
|
||||||
|
| otherwise = (:|) <$> select1 pop <*> return []
|
||||||
|
|
||||||
|
{-|
|
||||||
|
Selects @n@ individuals from the population by repeatedly selecting a single
|
||||||
|
indidual using a tournament of the given size (the same individual can be
|
||||||
|
selected multiple times, see 'chain').
|
||||||
|
-}
|
||||||
|
tournament :: (Individual i, MonadRandom m) => N -> Selection m i
|
||||||
|
tournament nTrnmnt = chain (tournament1 nTrnmnt)
|
||||||
|
|
||||||
|
prop_tournament_selectsN nTrnmnt n pop =
|
||||||
|
0 < nTrnmnt && nTrnmnt < length pop
|
||||||
|
&& 0 < n ==> monadicIO
|
||||||
|
$ do
|
||||||
|
pop' <- lift $ tournament 2 n pop
|
||||||
|
assert $ length pop' == n
|
||||||
|
|
||||||
|
{-|
|
||||||
|
Selects one individual from the population using tournament selection.
|
||||||
|
-}
|
||||||
|
tournament1
|
||||||
|
:: (Individual i, MonadRandom m)
|
||||||
|
=> N
|
||||||
|
-- ^ Tournament size
|
||||||
|
-> Population i
|
||||||
|
-> m i
|
||||||
|
tournament1 nTrnmnt pop
|
||||||
|
-- TODO Use Positive for this constraint
|
||||||
|
| nTrnmnt <= 0 = undefined
|
||||||
|
| otherwise = trnmnt >>= fmap (NE.head . fst) . bests 1
|
||||||
|
where
|
||||||
|
trnmnt = withoutReplacement nTrnmnt pop
|
||||||
|
size = length pop
|
||||||
|
|
||||||
|
{-|
|
||||||
|
Selects @n@ individuals uniformly at random from the population (without
|
||||||
|
replacement, so if @n >= length pop@, simply returns @pop@).
|
||||||
|
-}
|
||||||
|
withoutReplacement
|
||||||
|
:: (MonadRandom m)
|
||||||
|
=> N
|
||||||
|
-- ^ How many individuals to select
|
||||||
|
-> Population i
|
||||||
|
-> m (NonEmpty i)
|
||||||
|
withoutReplacement 0 _ = undefined
|
||||||
|
withoutReplacement n pop
|
||||||
|
| n >= length pop = return pop
|
||||||
|
| otherwise =
|
||||||
|
fmap NE.fromList . sample . shuffleNofM n (length pop) $ NE.toList pop
|
||||||
|
|
||||||
|
prop_withoutReplacement_selectsN n pop =
|
||||||
|
0 < n && n <= length pop ==> monadicIO $ do
|
||||||
|
pop' <- lift $ withoutReplacement n pop
|
||||||
|
assert $ length pop' == n
|
||||||
|
|
||||||
-- * Termination criteria
|
-- * Termination criteria
|
||||||
|
|
||||||
{-|
|
{-|
|
||||||
|
|
Loading…
Reference in New Issue
Block a user