Cleanup existing GA code
This commit is contained in:
parent
296b2e218c
commit
49b105f42a
109
src/GA.hs
109
src/GA.hs
|
@ -1,17 +1,18 @@
|
|||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
|
||||
module GA where
|
||||
|
||||
|
||||
import Protolude
|
||||
|
||||
|
||||
-- NEXT commit everything
|
||||
-- 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 qualified Data.List as L
|
||||
import Data.List.NonEmpty ((<|))
|
||||
|
@ -19,20 +20,25 @@ import qualified Data.List.NonEmpty as NE
|
|||
import Data.Random
|
||||
import Data.Random.Distribution.Categorical
|
||||
import Data.Random.Sample
|
||||
import Pretty
|
||||
import Protolude
|
||||
import Test.QuickCheck hiding (sample, shuffle)
|
||||
import Test.QuickCheck.Instances
|
||||
import Test.QuickCheck.Monadic
|
||||
|
||||
|
||||
import Pretty
|
||||
|
||||
|
||||
-- TODO Enforce this being > 0
|
||||
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
|
||||
|
||||
{-|
|
||||
Generates a completely random individual given an existing individual.
|
||||
|
||||
|
@ -42,16 +48,21 @@ class Eq i => Individual i where
|
|||
be done nicer!
|
||||
-}
|
||||
new :: (MonadRandom m) => i -> m i
|
||||
|
||||
{-|
|
||||
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)
|
||||
|
||||
mutate :: (MonadRandom m) => i -> m i
|
||||
|
||||
crossover1 :: (MonadRandom m) => i -> i -> m (Maybe (i, i))
|
||||
|
||||
-- TODO Perhaps rather add a 'features' function (and parametrize select1 etc. with fitness function)?
|
||||
fitness :: (Monad m) => i -> m R
|
||||
|
||||
{-|
|
||||
Performs an n-point crossover.
|
||||
|
||||
|
@ -61,36 +72,33 @@ class Eq i => Individual i where
|
|||
-}
|
||||
crossover :: (MonadRandom m) => Int -> i -> i -> m (Maybe (i, i))
|
||||
crossover n i1 i2
|
||||
| n <= 0 = return $ Just (i1, i2)
|
||||
| n <= 0 = return $ Just (i1, i2)
|
||||
| otherwise = do
|
||||
isM <- crossover1 i1 i2
|
||||
maybe (return Nothing) (uncurry (crossover (n - 1))) isM
|
||||
isM <- crossover1 i1 i2
|
||||
maybe (return Nothing) (uncurry (crossover (n - 1))) isM
|
||||
|
||||
|
||||
-- TODO Do i want to model the population using Data.Vector.Sized?
|
||||
-- TODO Perhaps use Data.Vector.Sized for the population?
|
||||
{-|
|
||||
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
|
||||
-}
|
||||
newtype Population a = Pop { unPop :: NonEmpty a }
|
||||
newtype Population a = Pop {unPop :: NonEmpty a}
|
||||
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 =
|
||||
sequence ((\ i -> (, i) <$> fitness i) <$> pop) >>=
|
||||
sample . fromWeightedList . NE.toList . unPop
|
||||
-- TODO Perhaps use stochastic acceptance for performance?
|
||||
sequence ((\i -> (,i) <$> fitness i) <$> pop)
|
||||
>>= sample . fromWeightedList . NE.toList . unPop
|
||||
|
||||
-- TODO Perhaps use stochastic acceptance for performance?
|
||||
|
||||
{-|
|
||||
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?
|
||||
proportionate
|
||||
:: (Individual i, MonadRandom m)
|
||||
=> N -> Population i -> m (NonEmpty i)
|
||||
=> N
|
||||
-> Population i
|
||||
-> m (NonEmpty i)
|
||||
proportionate n pop
|
||||
| n > 1 = (<|) <$> proportionate1 pop <*> proportionate (n - 1) pop
|
||||
| otherwise = (:|) <$> proportionate1 pop <*> return []
|
||||
|
||||
|
||||
{-|
|
||||
Produce offspring circularly.
|
||||
-}
|
||||
|
@ -113,7 +122,6 @@ 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?
|
||||
|
@ -122,43 +130,63 @@ children2 nX i1 i2 = do
|
|||
i6 <- mutate i4
|
||||
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 k f =
|
||||
fmap (NE.take k . fmap fst . NE.sortBy (comparing (Down . snd))) .
|
||||
traverse (\ i -> (i, ) <$> f i) . unPop
|
||||
|
||||
fmap (NE.take k . fmap fst . NE.sortBy (comparing (Down . snd)))
|
||||
. traverse (\i -> (i,) <$> f i)
|
||||
. unPop
|
||||
|
||||
-- TODO no trivial instance for worst
|
||||
-- prop_worstLength :: Int -> Population Int -> Property
|
||||
-- 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 = flip bestBy (fmap (1 /) . fitness)
|
||||
|
||||
|
||||
{-|
|
||||
The @k@ best individuals in the population.
|
||||
-}
|
||||
bests :: (Individual i, Monad m) => N -> Population i -> m [i]
|
||||
bests = flip bestBy fitness
|
||||
|
||||
|
||||
{-|
|
||||
Runs the GA and prints the @nResult@ best individuals.
|
||||
-}
|
||||
ga' nParents nX pop term nResult = do
|
||||
pop <- ga nParents nX pop term
|
||||
res <- bests nResult pop
|
||||
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
|
||||
:: (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
|
||||
where
|
||||
ga'
|
||||
:: (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
|
||||
-- trace (show t <> ": " <> show (length pop)) $ return ()
|
||||
is <- proportionate nParents pop
|
||||
|
@ -172,22 +200,17 @@ ga nParents nX pop term = ga' nParents nX pop term 0
|
|||
-- replace fitness proportionally
|
||||
-- let pop' = Pop <$> proportionate (length pop) (pop <> Pop is')
|
||||
if term pop' t
|
||||
then
|
||||
return pop'
|
||||
else
|
||||
ga' nParents nX pop' term (t + 1)
|
||||
|
||||
then return pop'
|
||||
else ga' nParents nX pop' term (t + 1)
|
||||
|
||||
-- * 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.
|
||||
-}
|
||||
|
|
Loading…
Reference in New Issue
Block a user