2019-10-17 17:25:25 +02:00
|
|
|
{-# LANGUAGE DeriveFoldable #-}
|
2019-10-17 18:23:19 +02:00
|
|
|
{-# LANGUAGE DeriveFunctor #-}
|
2019-10-17 17:25:25 +02:00
|
|
|
{-# LANGUAGE DeriveTraversable #-}
|
|
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
2019-10-18 09:10:11 +02:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
2019-10-18 09:57:43 +02:00
|
|
|
{-# LANGUAGE TupleSections #-}
|
2019-10-17 17:25:25 +02:00
|
|
|
|
|
|
|
module GA where
|
|
|
|
|
|
|
|
import Control.Arrow hiding (first)
|
|
|
|
import qualified Data.List as L
|
|
|
|
import Data.List.NonEmpty ((<|))
|
|
|
|
import qualified Data.List.NonEmpty as NE
|
|
|
|
import Data.Random
|
|
|
|
import Data.Random.Distribution.Categorical
|
|
|
|
import Data.Random.Sample
|
2019-10-18 09:57:43 +02:00
|
|
|
import Pipes
|
2019-10-17 18:23:19 +02:00
|
|
|
import Pretty
|
|
|
|
import Protolude
|
2019-10-17 17:25:25 +02:00
|
|
|
import Test.QuickCheck hiding (sample, shuffle)
|
|
|
|
import Test.QuickCheck.Instances
|
|
|
|
|
2019-10-22 06:53:53 +02:00
|
|
|
-- TODO using sample here was a quick hack
|
|
|
|
{-|
|
|
|
|
Shuffles a non-empty list.
|
|
|
|
-}
|
|
|
|
shuffle' :: (MonadRandom m) => NonEmpty a -> m (NonEmpty a)
|
|
|
|
shuffle' xs = do
|
|
|
|
i <- sample . uniform 0 $ NE.length xs - 1
|
|
|
|
let x = xs NE.!! i
|
|
|
|
xs' <- sample . shuffle $ deleteI i xs
|
|
|
|
return $ x :| xs'
|
|
|
|
where
|
|
|
|
deleteI i xs = fst (NE.splitAt (i - 1) xs) ++ snd (NE.splitAt i xs)
|
|
|
|
|
2019-10-22 07:10:28 +02:00
|
|
|
-- TODO enforce this being > 0
|
2019-10-17 17:25:25 +02:00
|
|
|
type N = Int
|
|
|
|
|
2019-10-17 18:23:19 +02:00
|
|
|
type R = Double
|
2019-10-17 17:25:25 +02:00
|
|
|
|
2019-10-22 07:10:28 +02:00
|
|
|
-- TODO an alternative could be
|
2019-10-17 18:23:19 +02:00
|
|
|
-- data I a
|
|
|
|
-- = I
|
|
|
|
-- { mutate :: m (I a),
|
|
|
|
-- crossover1 :: (MonadRandom m) => I a -> m (Maybe (I a, I a))
|
|
|
|
-- }
|
2019-10-17 17:25:25 +02:00
|
|
|
class Eq i => Individual i where
|
2019-10-17 18:23:19 +02:00
|
|
|
|
2019-10-17 17:25:25 +02:00
|
|
|
{-|
|
|
|
|
Generates a completely random individual given an existing individual.
|
2019-10-17 18:23:19 +02:00
|
|
|
|
2019-10-17 17:25:25 +02:00
|
|
|
We have to add @i@ here as a parameter in order to be able to inject stuff.
|
2019-10-17 18:23:19 +02:00
|
|
|
|
2019-10-17 17:25:25 +02:00
|
|
|
TODO This (and also, Seminar.I, which contains an ugly parameter @p@) has to
|
|
|
|
be done nicer!
|
|
|
|
-}
|
|
|
|
new :: (MonadRandom m) => i -> m i
|
2019-10-17 18:23:19 +02:00
|
|
|
|
2019-10-17 17:25:25 +02:00
|
|
|
{-|
|
|
|
|
Generates a random population of the given size.
|
|
|
|
-}
|
|
|
|
population :: (MonadRandom m) => N -> i -> m (Population i)
|
|
|
|
population 0 _ = undefined
|
|
|
|
population n i = Pop . NE.fromList <$> replicateM n (new i)
|
2019-10-17 18:23:19 +02:00
|
|
|
|
2019-10-17 17:25:25 +02:00
|
|
|
mutate :: (MonadRandom m) => i -> m i
|
2019-10-17 18:23:19 +02:00
|
|
|
|
2019-10-17 17:25:25 +02:00
|
|
|
crossover1 :: (MonadRandom m) => i -> i -> m (Maybe (i, i))
|
2019-10-17 18:23:19 +02:00
|
|
|
|
2019-10-17 17:25:25 +02:00
|
|
|
-- TODO Perhaps rather add a 'features' function (and parametrize select1 etc. with fitness function)?
|
|
|
|
fitness :: (Monad m) => i -> m R
|
2019-10-17 18:23:19 +02:00
|
|
|
|
2019-10-17 17:25:25 +02:00
|
|
|
{-|
|
|
|
|
Performs an n-point crossover.
|
2019-10-17 18:23:19 +02:00
|
|
|
|
2019-10-17 17:25:25 +02:00
|
|
|
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) => Int -> i -> i -> m (Maybe (i, i))
|
|
|
|
crossover n i1 i2
|
2019-10-17 18:23:19 +02:00
|
|
|
| n <= 0 = return $ Just (i1, i2)
|
2019-10-17 17:25:25 +02:00
|
|
|
| otherwise = do
|
2019-10-17 18:23:19 +02:00
|
|
|
isM <- crossover1 i1 i2
|
|
|
|
maybe (return Nothing) (uncurry (crossover (n - 1))) isM
|
2019-10-17 17:25:25 +02:00
|
|
|
|
2019-10-17 18:23:19 +02:00
|
|
|
-- TODO Perhaps use Data.Vector.Sized for the population?
|
2019-10-17 17:25:25 +02:00
|
|
|
{-|
|
|
|
|
It would be nice to model populations as GADTs but then no functor instance were
|
|
|
|
possible:
|
|
|
|
> data Population a where
|
|
|
|
> Pop :: Individual a => NonEmpty a -> Population a
|
|
|
|
-}
|
2019-10-17 18:23:19 +02:00
|
|
|
newtype Population a = Pop {unPop :: NonEmpty a}
|
2019-10-17 17:25:25 +02:00
|
|
|
deriving (Foldable, Functor, Semigroup, Show, Traversable)
|
|
|
|
|
|
|
|
instance (Arbitrary i) => Arbitrary (Population i) where
|
|
|
|
arbitrary = Pop <$> arbitrary
|
|
|
|
|
|
|
|
{-|
|
|
|
|
Selects one individual from the population using proportionate selection.
|
|
|
|
-}
|
|
|
|
proportionate1 :: (Individual i, MonadRandom m) => Population i -> m i
|
|
|
|
proportionate1 pop =
|
2019-10-17 18:23:19 +02:00
|
|
|
sequence ((\i -> (,i) <$> fitness i) <$> pop)
|
|
|
|
>>= sample . fromWeightedList . NE.toList . unPop
|
2019-10-17 17:25:25 +02:00
|
|
|
|
|
|
|
{-|
|
|
|
|
Selects @n@ individuals from the population using proportionate selection.
|
|
|
|
-}
|
|
|
|
proportionate
|
|
|
|
:: (Individual i, MonadRandom m)
|
2019-10-17 18:23:19 +02:00
|
|
|
=> N
|
|
|
|
-> Population i
|
|
|
|
-> m (NonEmpty i)
|
2019-10-17 17:25:25 +02:00
|
|
|
proportionate n pop
|
|
|
|
| n > 1 = (<|) <$> proportionate1 pop <*> proportionate (n - 1) pop
|
|
|
|
| otherwise = (:|) <$> proportionate1 pop <*> return []
|
|
|
|
|
|
|
|
{-|
|
|
|
|
Produce offspring circularly.
|
|
|
|
-}
|
|
|
|
children :: (Individual i, MonadRandom m) => 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')
|
|
|
|
|
|
|
|
children2 :: (Individual i, MonadRandom m) => N -> i -> i -> m (NonEmpty i)
|
|
|
|
children2 nX i1 i2 = do
|
|
|
|
-- TODO Add crossover probability?
|
|
|
|
(i3, i4) <- fromMaybe (i1, i2) <$> crossover nX i1 i2
|
|
|
|
i5 <- mutate i3
|
|
|
|
i6 <- mutate i4
|
|
|
|
return $ i5 :| [i6]
|
|
|
|
|
2019-10-22 06:53:53 +02:00
|
|
|
-- TODO there should be some shuffle here
|
2019-10-17 17:25:25 +02:00
|
|
|
{-|
|
2019-10-17 18:23:19 +02:00
|
|
|
The @k@ best individuals in the population when comparing using the supplied
|
|
|
|
function.
|
2019-10-17 17:25:25 +02:00
|
|
|
-}
|
2019-10-18 09:57:43 +02:00
|
|
|
bestsBy :: (Individual i, Monad m) => N -> (i -> m R) -> Population i -> m [i]
|
|
|
|
bestsBy k f =
|
2019-10-17 18:23:19 +02:00
|
|
|
fmap (NE.take k . fmap fst . NE.sortBy (comparing (Down . snd)))
|
|
|
|
. traverse (\i -> (i,) <$> f i)
|
|
|
|
. unPop
|
2019-10-17 17:25:25 +02:00
|
|
|
|
2019-10-17 18:23:19 +02:00
|
|
|
{-|
|
|
|
|
The @k@ worst individuals in the population.
|
|
|
|
-}
|
2019-10-17 17:25:25 +02:00
|
|
|
worst :: (Individual i, Monad m) => N -> Population i -> m [i]
|
2019-10-22 07:08:37 +02:00
|
|
|
worst = flip bestsBy (fmap negate . fitness)
|
2019-10-17 17:25:25 +02:00
|
|
|
|
2019-10-17 18:23:19 +02:00
|
|
|
{-|
|
|
|
|
The @k@ best individuals in the population.
|
|
|
|
-}
|
2019-10-17 17:25:25 +02:00
|
|
|
bests :: (Individual i, Monad m) => N -> Population i -> m [i]
|
2019-10-18 09:57:43 +02:00
|
|
|
bests = flip bestsBy fitness
|
2019-10-17 17:25:25 +02:00
|
|
|
|
2019-10-22 06:53:53 +02:00
|
|
|
-- TODO add top x percent selection (select n guys, sort by fitness first)
|
|
|
|
|
2019-10-18 09:57:43 +02:00
|
|
|
step
|
|
|
|
:: (Individual i, MonadRandom m, Monad m)
|
|
|
|
=> N
|
|
|
|
-> N
|
|
|
|
-> Population i
|
|
|
|
-> m (Population i)
|
|
|
|
step nParents nX pop = do
|
2019-10-18 13:43:18 +02:00
|
|
|
iBests <- bests 1 pop
|
2019-10-18 09:57:43 +02:00
|
|
|
is <- proportionate nParents pop
|
|
|
|
i :| is' <- children nX is
|
|
|
|
iWorsts <- worst nParents pop
|
2019-10-18 13:43:18 +02:00
|
|
|
let popClean = foldr L.delete (NE.toList . unPop $ pop) $ iBests <> iWorsts
|
|
|
|
-- TODO why does this not work? (we should use it!)
|
|
|
|
-- Pop <$> (shuffle' . NE.nub $ i :| is' <> popClean <> iBests)
|
|
|
|
return . Pop . NE.nub $ i :| is' <> popClean <> iBests
|
2019-10-18 09:57:43 +02:00
|
|
|
|
2019-10-17 18:23:19 +02:00
|
|
|
{-|
|
|
|
|
Runs the GA, using in each iteration
|
|
|
|
- @nParents@ parents for creating @nParents@ children and
|
|
|
|
- @nX@-point crossover.
|
2019-10-17 17:25:25 +02:00
|
|
|
|
2019-10-17 18:23:19 +02:00
|
|
|
It terminates after the termination criterion is fulfilled.
|
|
|
|
-}
|
2019-10-18 09:57:43 +02:00
|
|
|
run
|
|
|
|
:: (Individual i, Monad m, MonadRandom m)
|
2019-10-17 18:23:19 +02:00
|
|
|
=> N
|
|
|
|
-> N
|
|
|
|
-> Population i
|
|
|
|
-> Termination i
|
2019-10-18 09:57:43 +02:00
|
|
|
-> Producer (Int, Maybe R) m (Population i)
|
|
|
|
run nParents nX pop term = step' 0 pop
|
2019-10-17 17:25:25 +02:00
|
|
|
where
|
2019-10-18 09:57:43 +02:00
|
|
|
step' t pop
|
|
|
|
| term pop t = return pop
|
|
|
|
| otherwise = do
|
|
|
|
pop' <- lift $ step nParents nX pop
|
|
|
|
iBests <- lift $ bests 1 pop'
|
|
|
|
case headMay iBests of
|
|
|
|
Just iBest -> do
|
|
|
|
f <- fitness iBest
|
|
|
|
yield (t, Just f)
|
|
|
|
Nothing ->
|
|
|
|
yield (t, Nothing)
|
|
|
|
step' (t + 1) pop'
|
2019-10-17 17:25:25 +02:00
|
|
|
|
|
|
|
-- * Termination criteria
|
|
|
|
|
|
|
|
{-|
|
|
|
|
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.
|
|
|
|
-}
|
|
|
|
steps :: N -> Termination i
|
|
|
|
steps tEnd _ t = t >= tEnd
|