Hans/haga
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

🎨 Reformat modules with new ormolu defaults

Browse Source
This commit is contained in:
David Pätzel 2023-04-26 15:46:30 +02:00
parent 5c448dce09
commit da5fc31ab8
3 changed files with 206 additions and 212 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

326
src/GA.hs
View File

@ -2,25 +2,24 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-|
Module : GA
Description : Abstract genetic algorithm
Copyright : David Pätzel, 2019
License : GPL-3
Maintainer : David Pätzel <david.paetzel@posteo.de>
Stability : experimental
Simplistic abstract definition of a genetic algorithm.
In order to use it for a certain problem, basically, you have to make your
solution type an instance of 'Individual' and then simply call the 'run'
function.
-}
-- |
-- Module : GA
-- Description : Abstract genetic algorithm
-- Copyright : David Pätzel, 2019
-- License : GPL-3
-- Maintainer : David Pätzel <david.paetzel@posteo.de>
-- Stability : experimental
--
-- Simplistic abstract definition of a genetic algorithm.
--
-- In order to use it for a certain problem, basically, you have to make your
-- solution type an instance of 'Individual' and then simply call the 'run'
-- function.
module GA where
import Control.Arrow hiding (first, second)
@ -42,19 +41,17 @@ type N = Int
type R = Double
class Eq i => Individual i where
-- |
-- Generates a completely random individual given an existing individual.
--
-- We have to add @i@ here as a parameter in order to be able to inject stuff.
{-|
Generates a completely random individual given an existing individual.
We have to add @i@ here as a parameter in order to be able to inject stuff.
-}
-- TODO This (and also, Seminar.I, which contains an ugly parameter @p@) has
-- to be done nicer!
new :: (MonadRandom m) => i -> m i
{-|
Generates a random population of the given size.
-}
-- |
-- Generates a random population of the given size.
population :: (MonadRandom m) => N -> i -> m (Population i)
population n i
| n <= 0 = undefined
@ -64,21 +61,19 @@ class Eq i => Individual i where
crossover1 :: (MonadRandom m) => i -> i -> m (Maybe (i, i))
{-|
An individual's fitness. Higher values are considered “better”.
We explicitely allow fitness values to be have any sign (see, for example,
'proportionate1').
-}
-- |
-- An individual's fitness. Higher values are considered “better”.
--
-- We explicitely allow fitness values to be have any sign (see, for example,
-- 'proportionate1').
fitness :: (Monad m) => i -> m R
{-|
Performs an n-point crossover.
Given the function for single-point crossover, 'crossover1', this function can
be derived through recursion and a monad combinator (which is also the default
implementation).
-}
-- |
-- Performs an n-point crossover.
--
-- Given the function for single-point crossover, 'crossover1', this function can
-- be derived through recursion and a monad combinator (which is also the default
-- implementation).
crossover :: (MonadRandom m) => N -> i -> i -> m (Maybe (i, i))
crossover n i1 i2
| n <= 0 = return $ Just (i1, i2)
@ -86,12 +81,10 @@ class Eq i => Individual i where
isM <- crossover1 i1 i2
maybe (return Nothing) (uncurry (crossover (n - 1))) isM
{-|
Needed for QuickCheck tests, for now, a very simplistic implementation should
suffice.
-}
-- |
-- Needed for QuickCheck tests, for now, a very simplistic implementation should
-- suffice.
instance Individual Integer where
new _ = sample $ uniform 0 (0 + 100000)
mutate i = sample $ uniform (i - 10) (i + 10)
@ -100,30 +93,29 @@ instance Individual Integer where
fitness = return . fromIntegral . negate
{-|
Populations are just basic non-empty lists.
-}
-- |
-- Populations are just basic non-empty lists.
type Population i = NonEmpty i
{-|
Produces offspring circularly from the given list of parents.
-}
children
:: (Individual i, MonadRandom m)
=> N -- ^ The @nX@ of the @nX@-point crossover operator
-> NonEmpty i
-> m (NonEmpty i)
-- |
-- Produces offspring circularly from the given list of parents.
children ::
(Individual i, MonadRandom m) =>
-- | The @nX@ of the @nX@-point crossover operator
N ->
NonEmpty i ->
m (NonEmpty i)
children _ (i :| []) = (:| []) <$> mutate i
children nX (i1 :| [i2]) = children2 nX i1 i2
children nX (i1 :| i2 : is') =
(<>) <$> children2 nX i1 i2 <*> children nX (NE.fromList is')
prop_children_asManyAsParents
:: (Individual a, Show a) => N -> NonEmpty a -> Property
prop_children_asManyAsParents ::
(Individual a, Show a) => N -> NonEmpty a -> Property
prop_children_asManyAsParents nX is =
again
$ monadicIO
$ do
again $
monadicIO $
do
is' <- lift $ children nX is
return $ counterexample (show is') $ length is' == length is
@ -135,18 +127,17 @@ children2 nX i1 i2 = do
i6 <- mutate i4
return $ i5 :| [i6]
{-|
The best according to a function; returns up to @k@ results and the remaining
population.
If @k <= 0@, this returns the best one anyway (as if @k == 1@).
-}
bestsBy
:: (Individual i, Monad m)
=> N
-> (i -> m R)
-> Population i
-> m (NonEmpty i, [i])
-- |
-- The best according to a function; returns up to @k@ results and the remaining
-- population.
--
-- If @k <= 0@, this returns the best one anyway (as if @k == 1@).
bestsBy ::
(Individual i, Monad m) =>
N ->
(i -> m R) ->
Population i ->
m (NonEmpty i, [i])
bestsBy k f pop@(i :| pop')
| k <= 0 = bestsBy 1 f pop
| otherwise = foldM run (i :| [], []) pop'
@ -157,10 +148,9 @@ bestsBy k f pop@(i :| pop')
sorted =
fmap (fmap fst . NE.sortOn (Down . snd)) . traverse (\i -> (i,) <$> f i)
{-|
The @k@ best individuals in the population when comparing using the supplied
function.
-}
-- |
-- The @k@ best individuals in the population when comparing using the supplied
-- function.
bestsBy' :: (Individual i, Monad m) => N -> (i -> m R) -> Population i -> m [i]
bestsBy' k f =
fmap (NE.take k . fmap fst . NE.sortBy (comparing (Down . snd)))
@ -168,9 +158,9 @@ bestsBy' k f =
prop_bestsBy_isBestsBy' :: Individual a => Int -> Population a -> Property
prop_bestsBy_isBestsBy' k pop =
k > 0
==> monadicIO
$ do
k > 0 ==>
monadicIO $
do
a <- fst <$> bestsBy k fitness pop
b <- bestsBy' k fitness pop
assert $ NE.toList a == b
@ -179,37 +169,39 @@ prop_bestsBy_lengths :: Individual a => Int -> Population a -> Property
prop_bestsBy_lengths k pop =
k > 0 ==> monadicIO $ do
(bests, rest) <- bestsBy k fitness pop
assert
$ length bests == min k (length pop) && length bests + length rest == length pop
assert $
length bests == min k (length pop) && length bests + length rest == length pop
{-|
The @k@ worst individuals in the population (and the rest of the population).
-}
-- |
-- The @k@ worst individuals in the population (and the rest of the population).
worst :: (Individual i, Monad m) => N -> Population i -> m (NonEmpty i, [i])
worst = flip bestsBy (fmap negate . fitness)
{-|
The @k@ best individuals in the population (and the rest of the population).
-}
-- |
-- The @k@ best individuals in the population (and the rest of the population).
bests :: (Individual i, Monad m) => N -> Population i -> m (NonEmpty i, [i])
bests = flip bestsBy fitness
-- TODO add top x percent parent selection (select n guys, sort by fitness first)
{-|
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).
-}
stepSteady
:: (Individual i, MonadRandom m, Monad m)
=> Selection m i -- ^ Mechanism for selecting parents
-> N -- ^ Number of parents @nParents@ for creating @nParents@ children
-> N -- ^ How many crossover points (the @nX@ in @nX@-point crossover)
-> R -- ^ Elitism ratio @pElite@
-> Population i
-> m (Population i)
-- |
-- 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).
stepSteady ::
(Individual i, MonadRandom m, Monad m) =>
-- | Mechanism for selecting parents
Selection m i ->
-- | Number of parents @nParents@ for creating @nParents@ children
N ->
-- | How many crossover points (the @nX@ in @nX@-point crossover)
N ->
-- | Elitism ratio @pElite@
R ->
Population i ->
m (Population i)
stepSteady select nParents nX pElite pop = do
-- TODO Consider keeping the fitness evaluations already done for pop (so we
-- only reevaluate iChildren)
@ -226,12 +218,13 @@ stepSteady select nParents nX pElite pop = do
then return elitists
else
(elitists <>)
. fst <$> bests (length pop - length elitists) (i :| is)
. fst
<$> bests (length pop - length elitists) (i :| is)
where
nBest = floor . (pElite *) . fromIntegral $ NE.length pop
prop_stepSteady_constantPopSize
:: (Individual a, Show a) => NonEmpty a -> Property
prop_stepSteady_constantPopSize ::
(Individual a, Show a) => NonEmpty a -> Property
prop_stepSteady_constantPopSize pop =
forAll
( (,)
@ -243,22 +236,25 @@ prop_stepSteady_constantPopSize pop =
pop' <- lift $ stepSteady (tournament 4) nParents nX pElite pop
return . counterexample (show pop') $ length pop' == length pop
{-|
Given an initial population, runs the GA until the termination criterion is
fulfilled.
Uses the pipes library to, in each step, 'Pipes.yield' the currently best known
solution.
-}
run
:: (Individual i, Monad m, MonadRandom m)
=> Selection m i -- ^ Mechanism for selecting parents
-> N -- ^ Number of parents @nParents@ for creating @nParents@ children
-> N -- ^ How many crossover points (the @nX@ in @nX@-point crossover)
-> R -- ^ Elitism ratio @pElite@
-> Population i
-> Termination i
-> Producer (Int, R) m (Population i)
-- |
-- Given an initial population, runs the GA until the termination criterion is
-- fulfilled.
--
-- Uses the pipes library to, in each step, 'Pipes.yield' the currently best known
-- solution.
run ::
(Individual i, Monad m, MonadRandom m) =>
-- | Mechanism for selecting parents
Selection m i ->
-- | Number of parents @nParents@ for creating @nParents@ children
N ->
-- | How many crossover points (the @nX@ in @nX@-point crossover)
N ->
-- | Elitism ratio @pElite@
R ->
Population i ->
Termination i ->
Producer (Int, R) m (Population i)
run select nParents nX pElite pop term = step' 0 pop
where
step' t pop
@ -268,57 +264,55 @@ run select nParents nX pElite pop term = step' 0 pop
(iBests, _) <- lift $ bests 1 pop'
fs <- lift . sequence $ fitness <$> iBests
let fBest = NE.head fs
yield (t, fBest)
Pipes.yield (t, fBest)
step' (t + 1) pop'
-- * Selection mechanisms
{-|
A function generating a monadic action which selects a given number of
individuals from the given population.
-}
-- |
-- 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
-- |
-- 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').
-}
-- |
-- 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 :: Individual a => Int -> Int -> NonEmpty a -> Property
prop_tournament_selectsN nTrnmnt n pop =
0 < nTrnmnt && nTrnmnt < length pop
&& 0 < n ==> monadicIO
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
-- |
-- Selects one individual from the population using tournament selection.
tournament1 ::
(Individual i, MonadRandom m) =>
-- | Tournament size
N ->
Population i ->
m i
tournament1 nTrnmnt pop
-- TODO Use Positive for this constraint
| nTrnmnt <= 0 = undefined
@ -326,16 +320,15 @@ tournament1 nTrnmnt pop
where
trnmnt = withoutReplacement nTrnmnt 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)
-- |
-- Selects @n@ individuals uniformly at random from the population (without
-- replacement, so if @n >= length pop@, simply returns @pop@).
withoutReplacement ::
(MonadRandom m) =>
-- | How many individuals to select
N ->
Population i ->
m (NonEmpty i)
withoutReplacement 0 _ = undefined
withoutReplacement n pop
| n >= length pop = return pop
@ -350,23 +343,20 @@ prop_withoutReplacement_selectsN n pop =
-- * Termination criteria
{-|
Termination decisions may take into account the current population and the
current iteration number.
-}
-- |
-- Termination decisions may take into account the current population and the
-- current iteration number.
type Termination i = Population i -> N -> Bool
{-|
Termination after a number of steps.
-}
-- |
-- Termination after a number of steps.
steps :: N -> Termination i
steps tEnd _ t = t >= tEnd
-- * Helper functions
{-|
Shuffles a non-empty list.
-}
-- |
-- Shuffles a non-empty list.
shuffle' :: (MonadRandom m) => NonEmpty a -> m (NonEmpty a)
shuffle' xs@(_ :| []) = return xs
shuffle' xs = do

24
src/Main.hs
View File

@ -1,16 +1,16 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
import Options.Applicative
import Pipes
import Pretty
import Protolude hiding (for, option)
import System.IO
import Szenario191
-- import Szenario212Pun
import Szenario222
data Options
= Options
data Options = Options
{ iterations :: N,
populationSize :: N
}
@ -18,14 +18,16 @@ data Options
options :: Parser Options
options =
Options
<$> option auto
<$> option
auto
( long "iterations"
<> short 'i'
<> metavar "N"
<> value 1000
<> help "Number of iterations"
)
<*> option auto
<*> option
auto
( long "population-size"
<> short 'p'
<> metavar "N"
@ -35,19 +37,21 @@ options =
optionsWithHelp :: ParserInfo Options
optionsWithHelp =
info (helper <*> options)
info
(helper <*> options)
( fullDesc
<> progDesc "Run a GA"
<> header "haga - Haskell implementations of EAs"
)
main :: IO ()
main = execParser optionsWithHelp >>= \opts -> do
main =
execParser optionsWithHelp >>= \opts -> do
hSetBuffering stdout NoBuffering
pop <- population (populationSize opts) (I prios [])
pop' <-
runEffect
$ for (run (tournament 2) 2 1 (5 / 100) pop (steps $ iterations opts)) log
runEffect $
for (run (tournament 2) 2 1 (5 / 100) pop (steps $ iterations opts)) log
(res, _) <- bests 5 pop'
sequence_ $ format <$> res
where

2
src/Szenario191.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Szenario191
( module Seminar,