Cleanup existing GA code

This commit is contained in:
David Pätzel 2019-10-17 18:23:19 +02:00
parent 296b2e218c
commit 49b105f42a

115
src/GA.hs
View File

@ -1,17 +1,18 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
module GA where module GA where
-- NEXT commit everything
import Protolude -- TODO add factory floor optimizer:
-- [2019-07-15] GA that optimizes factory floor
-- - data: graph of workstations with edge weights being the number of walks between them
-- - desired: optimal configuration that reduces crossings
-- - space: 15 workstations that can be positioned in a 20 x 20 space
import Control.Arrow hiding (first) import Control.Arrow hiding (first)
import qualified Data.List as L import qualified Data.List as L
import Data.List.NonEmpty ((<|)) import Data.List.NonEmpty ((<|))
@ -19,78 +20,85 @@ import qualified Data.List.NonEmpty as NE
import Data.Random import Data.Random
import Data.Random.Distribution.Categorical import Data.Random.Distribution.Categorical
import Data.Random.Sample import Data.Random.Sample
import Pretty
import Protolude
import Test.QuickCheck hiding (sample, shuffle) import Test.QuickCheck hiding (sample, shuffle)
import Test.QuickCheck.Instances import Test.QuickCheck.Instances
import Test.QuickCheck.Monadic import Test.QuickCheck.Monadic
import Pretty
-- TODO Enforce this being > 0 -- TODO Enforce this being > 0
type N = Int type N = Int
type R = Float
type R = Double
-- alternative could be
-- data I a
-- = I
-- { mutate :: m (I a),
-- crossover1 :: (MonadRandom m) => I a -> m (Maybe (I a, I a))
-- }
class Eq i => Individual i where class Eq i => Individual i where
{-| {-|
Generates a completely random individual given an existing individual. 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. 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 TODO This (and also, Seminar.I, which contains an ugly parameter @p@) has to
be done nicer! be done nicer!
-} -}
new :: (MonadRandom m) => i -> m i 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 :: (MonadRandom m) => N -> i -> m (Population i)
population 0 _ = undefined population 0 _ = undefined
population n i = Pop . NE.fromList <$> replicateM n (new i) population n i = Pop . NE.fromList <$> replicateM n (new i)
mutate :: (MonadRandom m) => i -> m i mutate :: (MonadRandom m) => i -> m i
crossover1 :: (MonadRandom m) => i -> i -> m (Maybe (i, i)) crossover1 :: (MonadRandom m) => i -> i -> m (Maybe (i, i))
-- TODO Perhaps rather add a 'features' function (and parametrize select1 etc. with fitness function)? -- TODO Perhaps rather add a 'features' function (and parametrize select1 etc. with fitness function)?
fitness :: (Monad m) => i -> m R fitness :: (Monad m) => i -> m R
{-| {-|
Performs an n-point crossover. Performs an n-point crossover.
Given the function for single-point crossover, 'crossover1', this function can Given the function for single-point crossover, 'crossover1', this function can
be derived through recursion and a monad combinator (which is also the default be derived through recursion and a monad combinator (which is also the default
implementation). implementation).
-} -}
crossover :: (MonadRandom m) => Int -> i -> i -> m (Maybe (i, i)) crossover :: (MonadRandom m) => Int -> i -> i -> m (Maybe (i, i))
crossover n i1 i2 crossover n i1 i2
| n <= 0 = return $ Just (i1, i2) | n <= 0 = return $ Just (i1, i2)
| otherwise = do | otherwise = do
isM <- crossover1 i1 i2 isM <- crossover1 i1 i2
maybe (return Nothing) (uncurry (crossover (n - 1))) isM maybe (return Nothing) (uncurry (crossover (n - 1))) isM
-- TODO Perhaps use Data.Vector.Sized for the population?
-- TODO Do i want to model the population using Data.Vector.Sized?
{-| {-|
It would be nice to model populations as GADTs but then no functor instance were It would be nice to model populations as GADTs but then no functor instance were
possible: possible:
> data Population a where > data Population a where
> Pop :: Individual a => NonEmpty a -> Population a > Pop :: Individual a => NonEmpty a -> Population a
-} -}
newtype Population a = Pop { unPop :: NonEmpty a } newtype Population a = Pop {unPop :: NonEmpty a}
deriving (Foldable, Functor, Semigroup, Show, Traversable) deriving (Foldable, Functor, Semigroup, Show, Traversable)
instance (Arbitrary i) => Arbitrary (Population i) where instance (Arbitrary i) => Arbitrary (Population i) where
arbitrary = Pop <$> arbitrary arbitrary = Pop <$> arbitrary
{-| {-|
Selects one individual from the population using proportionate selection. Selects one individual from the population using proportionate selection.
-} -}
proportionate1 :: (Individual i, MonadRandom m) => Population i -> m i proportionate1 :: (Individual i, MonadRandom m) => Population i -> m i
proportionate1 pop = proportionate1 pop =
sequence ((\ i -> (, i) <$> fitness i) <$> pop) >>= sequence ((\i -> (,i) <$> fitness i) <$> pop)
sample . fromWeightedList . NE.toList . unPop >>= sample . fromWeightedList . NE.toList . unPop
-- TODO Perhaps use stochastic acceptance for performance?
-- TODO Perhaps use stochastic acceptance for performance?
{-| {-|
Selects @n@ individuals from the population using proportionate selection. Selects @n@ individuals from the population using proportionate selection.
@ -98,12 +106,13 @@ Selects @n@ individuals from the population using proportionate selection.
-- TODO Perhaps use Data.Vector.Sized for the result? -- TODO Perhaps use Data.Vector.Sized for the result?
proportionate proportionate
:: (Individual i, MonadRandom m) :: (Individual i, MonadRandom m)
=> N -> Population i -> m (NonEmpty i) => N
-> Population i
-> m (NonEmpty i)
proportionate n pop proportionate n pop
| n > 1 = (<|) <$> proportionate1 pop <*> proportionate (n - 1) pop | n > 1 = (<|) <$> proportionate1 pop <*> proportionate (n - 1) pop
| otherwise = (:|) <$> proportionate1 pop <*> return [] | otherwise = (:|) <$> proportionate1 pop <*> return []
{-| {-|
Produce offspring circularly. Produce offspring circularly.
-} -}
@ -113,7 +122,6 @@ children nX (i1 :| [i2]) = children2 nX i1 i2
children nX (i1 :| i2 : is') = children nX (i1 :| i2 : is') =
(<>) <$> children2 nX i1 i2 <*> children nX (NE.fromList is') (<>) <$> children2 nX i1 i2 <*> children nX (NE.fromList is')
children2 :: (Individual i, MonadRandom m) => N -> i -> i -> m (NonEmpty i) children2 :: (Individual i, MonadRandom m) => N -> i -> i -> m (NonEmpty i)
children2 nX i1 i2 = do children2 nX i1 i2 = do
-- TODO Add crossover probability? -- TODO Add crossover probability?
@ -122,43 +130,63 @@ children2 nX i1 i2 = do
i6 <- mutate i4 i6 <- mutate i4
return $ i5 :| [i6] return $ i5 :| [i6]
{-| {-|
The @k@ worst individuals in the population. The @k@ best individuals in the population when comparing using the supplied
function.
-} -}
bestBy :: (Individual i, Monad m) => N -> (i -> m R) -> Population i -> m [i] bestBy :: (Individual i, Monad m) => N -> (i -> m R) -> Population i -> m [i]
bestBy k f = bestBy k f =
fmap (NE.take k . fmap fst . NE.sortBy (comparing (Down . snd))) . fmap (NE.take k . fmap fst . NE.sortBy (comparing (Down . snd)))
traverse (\ i -> (i, ) <$> f i) . unPop . traverse (\i -> (i,) <$> f i)
. unPop
-- TODO no trivial instance for worst -- TODO no trivial instance for worst
-- prop_worstLength :: Int -> Population Int -> Property -- prop_worstLength :: Int -> Population Int -> Property
-- prop_worstLength k pop = monadicIO $ (k ==) . length <$> worst k pop -- prop_worstLength k pop = monadicIO $ (k ==) . length <$> worst k pop
{-|
The @k@ worst individuals in the population.
-}
worst :: (Individual i, Monad m) => N -> Population i -> m [i] worst :: (Individual i, Monad m) => N -> Population i -> m [i]
worst = flip bestBy (fmap (1 /) . fitness) worst = flip bestBy (fmap (1 /) . fitness)
{-|
The @k@ best individuals in the population.
-}
bests :: (Individual i, Monad m) => N -> Population i -> m [i] bests :: (Individual i, Monad m) => N -> Population i -> m [i]
bests = flip bestBy fitness bests = flip bestBy fitness
{-|
Runs the GA and prints the @nResult@ best individuals.
-}
ga' nParents nX pop term nResult = do ga' nParents nX pop term nResult = do
pop <- ga nParents nX pop term pop <- ga nParents nX pop term
res <- bests nResult pop res <- bests nResult pop
sequence $ putText . pretty <$> res sequence $ putText . pretty <$> res
{-|
Runs the GA, using in each iteration
- @nParents@ parents for creating @nParents@ children and
- @nX@-point crossover.
It terminates after the termination criterion is fulfilled.
-}
ga ga
:: (Individual i, MonadRandom m, Monad m) :: (Individual i, MonadRandom m, Monad m)
=> N -> N -> Population i -> Termination i -> m (Population i) => N
-> N
-> Population i
-> Termination i
-> m (Population i)
ga nParents nX pop term = ga' nParents nX pop term 0 ga nParents nX pop term = ga' nParents nX pop term 0
where where
ga' ga'
:: (Individual i, MonadRandom m, Monad m) :: (Individual i, MonadRandom m, Monad m)
=> N -> N -> Population i -> Termination i -> N -> m (Population i) => N
-> N
-> Population i
-> Termination i
-> N
-> m (Population i)
ga' nParents nX pop term t = do ga' nParents nX pop term t = do
-- trace (show t <> ": " <> show (length pop)) $ return () -- trace (show t <> ": " <> show (length pop)) $ return ()
is <- proportionate nParents pop is <- proportionate nParents pop
@ -172,22 +200,17 @@ ga nParents nX pop term = ga' nParents nX pop term 0
-- replace fitness proportionally -- replace fitness proportionally
-- let pop' = Pop <$> proportionate (length pop) (pop <> Pop is') -- let pop' = Pop <$> proportionate (length pop) (pop <> Pop is')
if term pop' t if term pop' t
then then return pop'
return pop' else ga' nParents nX pop' term (t + 1)
else
ga' nParents nX pop' term (t + 1)
-- * Termination criteria -- * Termination criteria
{-| {-|
Termination decisions may take into account the current population and the Termination decisions may take into account the current population and the
current iteration number. current iteration number.
-} -}
type Termination i = Population i -> N -> Bool type Termination i = Population i -> N -> Bool
{-| {-|
Termination after a number of steps. Termination after a number of steps.
-} -}