invent proper enviroment type for individual generation
This commit is contained in:
parent
62cf1acc6d
commit
0f428bea16
290
src/GA.hs
290
src/GA.hs
|
@ -1,12 +1,11 @@
|
||||||
{-# LANGUAGE DeriveFoldable #-}
|
|
||||||
{-# LANGUAGE DeriveFunctor #-}
|
|
||||||
{-# LANGUAGE DeriveTraversable #-}
|
{-# LANGUAGE DeriveTraversable #-}
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE TupleSections #-}
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
-- |
|
-- |
|
||||||
-- Module : GA
|
-- Module : GA
|
||||||
-- Description : Abstract genetic algorithm
|
-- Description : Abstract genetic algorithm
|
||||||
|
@ -25,11 +24,12 @@ module GA where
|
||||||
import Control.Arrow hiding (first, second)
|
import Control.Arrow hiding (first, second)
|
||||||
import Data.List.NonEmpty ((<|))
|
import Data.List.NonEmpty ((<|))
|
||||||
import qualified Data.List.NonEmpty as NE
|
import qualified Data.List.NonEmpty as NE
|
||||||
import qualified Data.List.NonEmpty.Extra as NE (appendl, sortOn)
|
import qualified Data.List.NonEmpty.Extra as NE (appendl)
|
||||||
import Data.Random
|
import Data.Random
|
||||||
import System.Random.MWC (create)
|
import System.Random.MWC (create)
|
||||||
import Pipes
|
import Pipes
|
||||||
import Protolude
|
import Protolude
|
||||||
|
import Pretty
|
||||||
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
|
||||||
|
@ -41,33 +41,28 @@ type N = Int
|
||||||
|
|
||||||
type R = Double
|
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.
|
|
||||||
|
|
||||||
-- TODO This (and also, Seminar.I, which contains an ugly parameter @p@) has
|
-- |
|
||||||
-- to be done nicer!
|
-- An Environment that Individuals of type i can be created from
|
||||||
new :: i -> RVar i
|
-- It stores all information required to create and change Individuals correctly
|
||||||
|
--
|
||||||
|
class (Eq e, Pretty e, Individual i) => Environment i e where
|
||||||
|
-- |
|
||||||
|
-- Generates a completely random individual.
|
||||||
|
--
|
||||||
|
new :: e -> RVar i
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
-- Generates a random population of the given size.
|
-- Generates a random population of the given size.
|
||||||
population :: N -> i -> RVar (Population i)
|
population :: e -> N -> RVar (Population i)
|
||||||
population n i
|
population env n
|
||||||
| n <= 0 = undefined
|
| n <= 0 = undefined
|
||||||
| otherwise = NE.fromList <$> replicateM n (new i)
|
| otherwise = NE.fromList <$> replicateM n (new env)
|
||||||
|
|
||||||
mutate :: i -> RVar i
|
mutate :: e -> i -> RVar i
|
||||||
|
|
||||||
crossover1 :: i -> i -> RVar (Maybe (i, i))
|
crossover1 :: e -> i -> i -> RVar (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').
|
|
||||||
fitness :: i -> R
|
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
-- Performs an n-point crossover.
|
-- Performs an n-point crossover.
|
||||||
|
@ -75,24 +70,28 @@ class Eq i => Individual i where
|
||||||
-- 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 :: N -> i -> i -> RVar (Maybe (i, i))
|
crossover :: e -> N -> i -> i -> RVar (Maybe (i, i))
|
||||||
crossover n i1 i2
|
crossover env 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 env i1 i2
|
||||||
maybe (return Nothing) (uncurry (crossover (n - 1))) isM
|
maybe (return Nothing) (uncurry (crossover env (n - 1))) isM
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
-- Needed for QuickCheck tests, for now, a very simplistic implementation should
|
-- An Evaluator that Individuals of type i can be evaluated by
|
||||||
-- suffice.
|
-- It stores all information required to evaluate an individuals fitness
|
||||||
instance Individual Integer where
|
--
|
||||||
new _ = uniform 0 (0 + 100000)
|
class (Eq e, Individual i) => Evaluator i e where
|
||||||
|
-- |
|
||||||
|
-- An individual's fitness. Higher values are considered “better”.
|
||||||
|
--
|
||||||
|
-- We explicitely allow fitness values to be have any sign (see, for example,
|
||||||
|
-- 'proportionate1').
|
||||||
|
fitness :: e -> i -> R
|
||||||
|
|
||||||
mutate i = uniform (i - 10) (i + 10)
|
class (Pretty i, Eq i) => Individual i
|
||||||
|
|
||||||
crossover1 i1 i2 = return $ Just (i1 - i2, i2 - i1)
|
|
||||||
|
|
||||||
fitness = fromIntegral . negate
|
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
-- Populations are just basic non-empty lists.
|
-- Populations are just basic non-empty lists.
|
||||||
|
@ -101,32 +100,24 @@ type Population i = NonEmpty i
|
||||||
-- |
|
-- |
|
||||||
-- Produces offspring circularly from the given list of parents.
|
-- Produces offspring circularly from the given list of parents.
|
||||||
children ::
|
children ::
|
||||||
(Individual i) =>
|
(Individual i, Environment i e) =>
|
||||||
|
e ->
|
||||||
-- | The @nX@ of the @nX@-point crossover operator
|
-- | The @nX@ of the @nX@-point crossover operator
|
||||||
N ->
|
N ->
|
||||||
NonEmpty i ->
|
NonEmpty i ->
|
||||||
RVar (NonEmpty i)
|
RVar (NonEmpty i)
|
||||||
children _ (i :| []) = (:| []) <$> mutate i
|
children e _ (i :| []) = (:| []) <$> mutate e i
|
||||||
children nX (i1 :| [i2]) = children2 nX i1 i2
|
children e nX (i1 :| [i2]) = children2 e nX i1 i2
|
||||||
children nX (i1 :| i2 : is') =
|
children e nX (i1 :| i2 : is') =
|
||||||
(<>) <$> children2 nX i1 i2 <*> children nX (NE.fromList is')
|
(<>) <$> children2 e nX i1 i2 <*> children e nX (NE.fromList is')
|
||||||
|
|
||||||
prop_children_asManyAsParents ::
|
|
||||||
(Individual a, Show a) => N -> NonEmpty a -> Property
|
|
||||||
prop_children_asManyAsParents nX is =
|
|
||||||
again $
|
|
||||||
monadicIO $
|
|
||||||
do
|
|
||||||
mwc <- Test.QuickCheck.Monadic.run create
|
|
||||||
is' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (children nX is)
|
|
||||||
return $ counterexample (show is') $ length is' == length is
|
|
||||||
|
|
||||||
children2 :: (Individual i) => N -> i -> i -> RVar (NonEmpty i)
|
children2 :: (Individual i, Environment i e) => e -> N -> i -> i -> RVar (NonEmpty i)
|
||||||
children2 nX i1 i2 = do
|
children2 e nX i1 i2 = do
|
||||||
-- TODO Add crossover probability?
|
-- TODO Add crossover probability?
|
||||||
(i3, i4) <- fromMaybe (i1, i2) <$> crossover nX i1 i2
|
(i3, i4) <- fromMaybe (i1, i2) <$> crossover e nX i1 i2
|
||||||
i5 <- mutate i3
|
i5 <- mutate e i3
|
||||||
i6 <- mutate i4
|
i6 <- mutate e i4
|
||||||
return $ i5 :| [i6]
|
return $ i5 :| [i6]
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
|
@ -153,31 +144,16 @@ bestsBy' k f pop
|
||||||
| k <= 0 = bestsBy' 1 f pop
|
| k <= 0 = bestsBy' 1 f pop
|
||||||
| otherwise = NE.take k $ map fst $ NE.sortBy (comparing (Down . snd)) $ map (\i -> (i, f i)) pop
|
| otherwise = NE.take k $ map fst $ NE.sortBy (comparing (Down . snd)) $ map (\i -> (i, f i)) pop
|
||||||
|
|
||||||
prop_bestsBy_isBestsBy' :: Individual a => Int -> Population a -> Property
|
|
||||||
prop_bestsBy_isBestsBy' k pop =
|
|
||||||
k > 0 ==>
|
|
||||||
monadicIO $
|
|
||||||
do
|
|
||||||
let a = fst $ bestsBy k fitness pop
|
|
||||||
let b = bestsBy' k fitness pop
|
|
||||||
assert $ NE.toList a == b
|
|
||||||
|
|
||||||
prop_bestsBy_lengths :: Individual a => Int -> Population a -> Property
|
|
||||||
prop_bestsBy_lengths k pop =
|
|
||||||
k > 0 ==> monadicIO $ do
|
|
||||||
let (bests, rest) = bestsBy k fitness 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) => N -> Population i -> (NonEmpty i, [i])
|
worst :: (Individual i, Evaluator i e) => e -> N -> Population i -> (NonEmpty i, [i])
|
||||||
worst k pop = bestsBy k (negate . fitness) pop
|
worst e k = bestsBy k (negate . fitness e)
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
-- 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) => N -> Population i -> (NonEmpty i, [i])
|
bests :: (Individual i, Evaluator i e) => e -> N -> Population i -> (NonEmpty i, [i])
|
||||||
bests k pop = bestsBy k fitness pop
|
bests e k = bestsBy k (fitness e)
|
||||||
|
|
||||||
-- 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)
|
||||||
|
|
||||||
|
@ -188,7 +164,9 @@ bests k pop = bestsBy k fitness pop
|
||||||
-- elitist, even if the percentage is 0 or low enough for rounding to result in 0
|
-- elitist, even if the percentage is 0 or low enough for rounding to result in 0
|
||||||
-- elitists).
|
-- elitists).
|
||||||
stepSteady ::
|
stepSteady ::
|
||||||
(Individual i) =>
|
(Individual i, Evaluator i eval, Environment i env ) =>
|
||||||
|
eval ->
|
||||||
|
env ->
|
||||||
-- | Mechanism for selecting parents
|
-- | Mechanism for selecting parents
|
||||||
Selection RVar i ->
|
Selection RVar i ->
|
||||||
-- | Number of parents @nParents@ for creating @nParents@ children
|
-- | Number of parents @nParents@ for creating @nParents@ children
|
||||||
|
@ -199,46 +177,34 @@ stepSteady ::
|
||||||
R ->
|
R ->
|
||||||
Population i ->
|
Population i ->
|
||||||
RVar (Population i)
|
RVar (Population i)
|
||||||
stepSteady select nParents nX pElite pop = do
|
stepSteady eval env select nParents nX pElite pop = do
|
||||||
-- TODO Consider keeping the fitness evaluations already done for pop (so we
|
-- TODO Consider keeping the fitness evaluations already done for pop (so we
|
||||||
-- only reevaluate iChildren)
|
-- only reevaluate iChildren)
|
||||||
iParents <- select nParents pop
|
iParents <- select nParents pop
|
||||||
iChildren <- NE.filter (`notElem` pop) <$> children nX iParents
|
iChildren <- NE.filter (`notElem` pop) <$> children env nX iParents
|
||||||
let pop' = pop `NE.appendl` iChildren
|
let pop' = pop `NE.appendl` iChildren
|
||||||
let eliteSize = floor . (pElite *) . fromIntegral $ NE.length pop
|
let eliteSize = floor . (pElite *) . fromIntegral $ NE.length pop
|
||||||
let (elitists, rest) = bests eliteSize pop'
|
let (elitists, rest) = bests eval eliteSize pop'
|
||||||
case rest of
|
case rest of
|
||||||
[] -> return elitists
|
[] -> return elitists
|
||||||
otherwise ->
|
_notEmpty ->
|
||||||
-- NOTE 'bests' always returns at least one individual, thus we need this
|
-- NOTE 'bests' always returns at least one individual, thus we need this
|
||||||
-- slightly ugly branching
|
-- slightly ugly branching
|
||||||
if length elitists == length pop
|
if length elitists == length pop
|
||||||
then return elitists
|
then return elitists
|
||||||
else
|
else
|
||||||
return $ elitists <> (fst $ bests (length pop - length elitists) (NE.fromList rest))
|
return $ elitists <> (fst $ bests eval (length pop - length elitists) (NE.fromList rest))
|
||||||
|
|
||||||
prop_stepSteady_constantPopSize ::
|
|
||||||
(Individual a, Show a) => NonEmpty a -> Property
|
|
||||||
prop_stepSteady_constantPopSize pop =
|
|
||||||
forAll
|
|
||||||
( (,)
|
|
||||||
<$> choose (1, length pop)
|
|
||||||
<*> choose (1, length pop)
|
|
||||||
)
|
|
||||||
$ \(nParents, nX) -> monadicIO $ do
|
|
||||||
let pElite = 0.1
|
|
||||||
mwc <- Test.QuickCheck.Monadic.run create
|
|
||||||
pop' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (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
|
-- Given an Enviroment and Evaluator, runs the GA until the termination criterion is
|
||||||
-- fulfilled.
|
-- fulfilled.
|
||||||
--
|
--
|
||||||
-- Uses the pipes library to, in each step, 'Pipes.yield' the currently best known
|
-- Uses the pipes library to, in each step, 'Pipes.yield' the currently best known
|
||||||
-- solution.
|
-- solution.
|
||||||
run ::
|
run ::
|
||||||
(Individual i) =>
|
(Individual i, Evaluator i eval, Environment i env ) =>
|
||||||
|
eval ->
|
||||||
|
env ->
|
||||||
-- | Mechanism for selecting parents
|
-- | Mechanism for selecting parents
|
||||||
Selection RVar i ->
|
Selection RVar i ->
|
||||||
-- | Number of parents @nParents@ for creating @nParents@ children
|
-- | Number of parents @nParents@ for creating @nParents@ children
|
||||||
|
@ -247,21 +213,22 @@ run ::
|
||||||
N ->
|
N ->
|
||||||
-- | Elitism ratio @pElite@
|
-- | Elitism ratio @pElite@
|
||||||
R ->
|
R ->
|
||||||
RVar (Population i) ->
|
-- | Population size
|
||||||
|
N ->
|
||||||
Termination i ->
|
Termination i ->
|
||||||
Producer (Int, R) IO (Population i)
|
Producer (Int, R) IO (Population i)
|
||||||
run select nParents nX pElite pop term = do
|
run eval env select nParents nX pElite nPop term = do
|
||||||
mwc <- lift create
|
mwc <- lift create
|
||||||
let x = \currPop generation -> do
|
let x = \currPop generation -> do
|
||||||
currPop' <- lift $ sampleFrom mwc $ currPop
|
currPop' <- lift $ sampleFrom mwc $ currPop
|
||||||
if term currPop' generation
|
if term currPop' generation
|
||||||
then return currPop'
|
then return currPop'
|
||||||
else do
|
else do
|
||||||
let nextPop = stepSteady select nParents nX pElite currPop'
|
let nextPop = stepSteady eval env select nParents nX pElite currPop'
|
||||||
let fBest = fitness $ NE.head $ fst $ bests 1 currPop'
|
let fBest = fitness eval $ NE.head $ fst $ bests eval 1 currPop'
|
||||||
Pipes.yield (generation, fBest)
|
Pipes.yield (generation, fBest)
|
||||||
x nextPop (generation + 1)
|
x nextPop (generation + 1)
|
||||||
x pop 0
|
x (population env nPop) 0
|
||||||
|
|
||||||
|
|
||||||
-- * Selection mechanisms
|
-- * Selection mechanisms
|
||||||
|
@ -289,34 +256,24 @@ chain select1 n pop
|
||||||
-- Selects @n@ individuals from the population by repeatedly selecting a single
|
-- Selects @n@ individuals from the population by repeatedly selecting a single
|
||||||
-- indidual using a tournament of the given size (the same individual can be
|
-- indidual using a tournament of the given size (the same individual can be
|
||||||
-- selected multiple times, see 'chain').
|
-- selected multiple times, see 'chain').
|
||||||
tournament :: (Individual i) => N -> Selection RVar i
|
tournament :: (Individual i, Evaluator i e) => e -> N -> Selection RVar i
|
||||||
tournament nTrnmnt = chain (tournament1 nTrnmnt)
|
tournament eval nTrnmnt = chain (tournament1 eval 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
|
|
||||||
$ do
|
|
||||||
mwc <- Test.QuickCheck.Monadic.run create
|
|
||||||
pop' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (tournament 2 n pop)
|
|
||||||
assert $ length pop' == n
|
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
-- Selects one individual from the population using tournament selection.
|
-- Selects one individual from the population using tournament selection.
|
||||||
tournament1 ::
|
tournament1 ::
|
||||||
(Individual i) =>
|
(Individual i, Evaluator i e) =>
|
||||||
|
e ->
|
||||||
-- | Tournament size
|
-- | Tournament size
|
||||||
N ->
|
N ->
|
||||||
Population i ->
|
Population i ->
|
||||||
RVar i
|
RVar i
|
||||||
tournament1 nTrnmnt pop
|
tournament1 eval nTrnmnt pop
|
||||||
-- TODO Use Positive for this constraint
|
-- TODO Use Positive for this constraint
|
||||||
| nTrnmnt <= 0 = undefined
|
| nTrnmnt <= 0 = undefined
|
||||||
| otherwise = do
|
| otherwise = do
|
||||||
paricipants <- withoutReplacement nTrnmnt pop
|
paricipants <- withoutReplacement nTrnmnt pop
|
||||||
return $ NE.head $ fst $ bests 1 paricipants
|
return $ NE.head $ fst $ bests eval 1 paricipants
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
-- Selects @n@ individuals uniformly at random from the population (without
|
-- Selects @n@ individuals uniformly at random from the population (without
|
||||||
|
@ -331,13 +288,6 @@ withoutReplacement n pop
|
||||||
| n >= length pop = return pop
|
| n >= length pop = return pop
|
||||||
| otherwise = fmap (NE.fromList) (shuffleNofM n (length pop) (NE.toList pop))
|
| otherwise = fmap (NE.fromList) (shuffleNofM n (length pop) (NE.toList pop))
|
||||||
|
|
||||||
prop_withoutReplacement_selectsN :: Int -> NonEmpty a -> Property
|
|
||||||
prop_withoutReplacement_selectsN n pop =
|
|
||||||
0 < n && n <= length pop ==> monadicIO (do
|
|
||||||
mwc <- Test.QuickCheck.Monadic.run create
|
|
||||||
pop' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (withoutReplacement n pop)
|
|
||||||
assert $ length pop' == n)
|
|
||||||
|
|
||||||
-- * Termination criteria
|
-- * Termination criteria
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
|
@ -358,13 +308,105 @@ shuffle' :: NonEmpty a -> RVar (NonEmpty a)
|
||||||
shuffle' xs@(_ :| []) = return xs
|
shuffle' xs@(_ :| []) = return xs
|
||||||
shuffle' xs = fmap (NE.fromList) (shuffle (toList xs))
|
shuffle' xs = fmap (NE.fromList) (shuffle (toList xs))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
instance Pretty Integer where
|
||||||
|
pretty i = "Found int: " <> show i
|
||||||
|
|
||||||
|
instance Individual Integer
|
||||||
|
|
||||||
|
newtype IntTestEnviroment = IntTestEnviroment ((Integer,Integer),Integer) deriving (Eq) -- IntTestEnviroment ((0,100000),10)
|
||||||
|
|
||||||
|
instance Pretty IntTestEnviroment where
|
||||||
|
-- instance Pretty (Maybe Student) where
|
||||||
|
pretty (IntTestEnviroment ((i,j),k)) = "IntTestEnviroment of Individuals between " <> (show i) <> " and " <> (show j) <> " variance when mutating is " <> (show k)
|
||||||
|
|
||||||
|
|
||||||
|
instance Environment Integer IntTestEnviroment where
|
||||||
|
|
||||||
|
new (IntTestEnviroment ((from,to),_)) = uniform from to
|
||||||
|
|
||||||
|
mutate (IntTestEnviroment ((from,to),wiggle)) i = uniform (max from (i - wiggle)) (min to (i + wiggle))
|
||||||
|
|
||||||
|
crossover1 _ i1 i2 = do
|
||||||
|
i1' <- uniform i1 i2
|
||||||
|
i2' <- uniform i1 i2
|
||||||
|
return $ Just (i1',i2')
|
||||||
|
|
||||||
|
data NoData = NoData deriving (Eq)
|
||||||
|
|
||||||
|
instance Evaluator Integer NoData where
|
||||||
|
|
||||||
|
fitness _ = fromIntegral . negate
|
||||||
|
|
||||||
|
prop_children_asManyAsParents ::
|
||||||
|
N -> NonEmpty Integer -> Property
|
||||||
|
prop_children_asManyAsParents nX is =
|
||||||
|
again $
|
||||||
|
monadicIO $
|
||||||
|
do
|
||||||
|
let e = IntTestEnviroment ((0,100000),10)
|
||||||
|
mwc <- Test.QuickCheck.Monadic.run create
|
||||||
|
is' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (children e nX is)
|
||||||
|
return $ counterexample (show is') $ length is' == length is
|
||||||
|
|
||||||
|
|
||||||
|
prop_bestsBy_isBestsBy' :: Int -> Population Integer -> Property
|
||||||
|
prop_bestsBy_isBestsBy' k pop =
|
||||||
|
k > 0 ==>
|
||||||
|
monadicIO $
|
||||||
|
do
|
||||||
|
let a = fst $ bestsBy k (fitness NoData) pop
|
||||||
|
let b = bestsBy' k (fitness NoData) pop
|
||||||
|
assert $ NE.toList a == b
|
||||||
|
|
||||||
|
prop_bestsBy_lengths :: Int -> Population Integer -> Property
|
||||||
|
prop_bestsBy_lengths k pop =
|
||||||
|
k > 0 ==> monadicIO $ do
|
||||||
|
let (bests, rest) = bestsBy k (fitness NoData) pop
|
||||||
|
assert $
|
||||||
|
length bests == min k (length pop) && length bests + length rest == length pop
|
||||||
|
prop_stepSteady_constantPopSize ::
|
||||||
|
NonEmpty Integer -> Property
|
||||||
|
prop_stepSteady_constantPopSize pop =
|
||||||
|
forAll
|
||||||
|
( (,)
|
||||||
|
<$> choose (1, length pop)
|
||||||
|
<*> choose (1, length pop)
|
||||||
|
)
|
||||||
|
$ \(nParents, nX) -> monadicIO $ do
|
||||||
|
let pElite = 0.1
|
||||||
|
let eval = NoData
|
||||||
|
let env = IntTestEnviroment ((0,100000),10)
|
||||||
|
mwc <- Test.QuickCheck.Monadic.run create
|
||||||
|
pop' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (stepSteady eval env (tournament eval 4) nParents nX pElite pop)
|
||||||
|
return . counterexample (show pop') $ length pop' == length pop
|
||||||
|
|
||||||
|
prop_tournament_selectsN :: Int -> Int -> NonEmpty Integer -> Property
|
||||||
|
prop_tournament_selectsN nTrnmnt n pop =
|
||||||
|
0 < nTrnmnt
|
||||||
|
&& nTrnmnt < length pop
|
||||||
|
&& 0 < n
|
||||||
|
==> monadicIO
|
||||||
|
$ do
|
||||||
|
mwc <- Test.QuickCheck.Monadic.run create
|
||||||
|
pop' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (tournament NoData 2 n pop)
|
||||||
|
assert $ length pop' == n
|
||||||
|
|
||||||
|
prop_withoutReplacement_selectsN :: Int -> NonEmpty a -> Property
|
||||||
|
prop_withoutReplacement_selectsN n pop =
|
||||||
|
0 < n && n <= length pop ==> monadicIO (do
|
||||||
|
mwc <- Test.QuickCheck.Monadic.run create
|
||||||
|
pop' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (withoutReplacement n pop)
|
||||||
|
assert $ length pop' == n)
|
||||||
|
|
||||||
prop_shuffle_length :: NonEmpty a -> Property
|
prop_shuffle_length :: NonEmpty a -> Property
|
||||||
prop_shuffle_length xs = monadicIO(do
|
prop_shuffle_length xs = monadicIO(do
|
||||||
mwc <- Test.QuickCheck.Monadic.run create
|
mwc <- Test.QuickCheck.Monadic.run create
|
||||||
xs' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (shuffle' xs)
|
xs' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (shuffle' xs)
|
||||||
assert $ length xs' == length xs)
|
assert $ length xs' == length xs)
|
||||||
|
|
||||||
return []
|
|
||||||
|
|
||||||
runTests :: IO Bool
|
runTests :: IO Bool
|
||||||
runTests = $quickCheckAll
|
runTests = $quickCheckAll
|
||||||
|
|
||||||
|
return []
|
||||||
|
|
11
src/Main.hs
11
src/Main.hs
|
@ -48,14 +48,15 @@ main :: IO ()
|
||||||
main =
|
main =
|
||||||
execParser optionsWithHelp >>= \opts -> do
|
execParser optionsWithHelp >>= \opts -> do
|
||||||
hSetBuffering stdout NoBuffering
|
hSetBuffering stdout NoBuffering
|
||||||
let pop = population (populationSize opts) (I prios [])
|
let env = AssignmentEnviroment (students prios, topics prios)
|
||||||
|
let run' = run prios env (tournament prios 2) 2 1 (5 / 100) (populationSize opts) (steps (iterations opts)) :: Producer (Int, R) IO (Population Assignment)
|
||||||
pop' <-
|
pop' <-
|
||||||
runEffect (for (run (tournament 2) 2 1 (5 / 100) pop (steps (iterations opts))) logCsv)
|
runEffect (for run' logCsv)
|
||||||
let (res, _) = bests 5 pop'
|
let (res, _) = bests prios 5 pop'
|
||||||
sequence_ $ format <$> res
|
mapM_ format res
|
||||||
where
|
where
|
||||||
format s = do
|
format s = do
|
||||||
let f = fitness s
|
let f = fitness prios s
|
||||||
putErrText $ show f <> "\n" <> pretty s
|
putErrText $ show f <> "\n" <> pretty s
|
||||||
logCsv = putText . csv
|
logCsv = putText . csv
|
||||||
csv (t, f) = show t <> " " <> show f
|
csv (t, f) = show t <> " " <> show f
|
||||||
|
|
106
src/Seminar.hs
106
src/Seminar.hs
|
@ -2,6 +2,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
|
||||||
module Seminar where
|
module Seminar where
|
||||||
|
|
||||||
|
@ -96,47 +97,29 @@ prop_prioOf_singletonNotFound =
|
||||||
lowestPriority :: Priorities -> Int
|
lowestPriority :: Priorities -> Int
|
||||||
lowestPriority = fromMaybe 0 . maximumMay . fmap snd . join . fmap snd . unP
|
lowestPriority = fromMaybe 0 . maximumMay . fmap snd . join . fmap snd . unP
|
||||||
|
|
||||||
type Assignment = [(Maybe Student, Maybe Topic)]
|
type Assignment = [(Maybe Student, Maybe Topic)]
|
||||||
|
|
||||||
data I = I Priorities Assignment
|
instance Individual Assignment
|
||||||
deriving (Eq, Show)
|
|
||||||
|
|
||||||
instance Pretty I where
|
newtype AssignmentEnviroment = AssignmentEnviroment ([Student],[Topic]) deriving Eq
|
||||||
pretty (I p a) =
|
|
||||||
T.unlines (gene <$> a)
|
|
||||||
where
|
|
||||||
gene :: (Maybe Student, Maybe Topic) -> Text
|
|
||||||
gene (s, t) =
|
|
||||||
pretty s <> ": " <> pretty t <> prio s t
|
|
||||||
prio :: Maybe Student -> Maybe Topic -> Text
|
|
||||||
prio s t = " (" <> show (prioOf' p s t) <> ")"
|
|
||||||
|
|
||||||
-- |
|
instance Pretty AssignmentEnviroment where
|
||||||
-- The priority value given by a student to a topic including the case of her not
|
pretty (AssignmentEnviroment (persons,assignables)) = "Persons: " <> show persons <> " Assignables: " <> show assignables
|
||||||
-- receiving a topic.
|
|
||||||
prioOf' :: Priorities -> Maybe Student -> Maybe Topic -> Int
|
|
||||||
-- TODO Maybe make this neutral?
|
|
||||||
prioOf' p Nothing Nothing = lowestPriority p + 2
|
|
||||||
prioOf' p (Just s) Nothing = lowestPriority p + 2
|
|
||||||
prioOf' p Nothing (Just t) = lowestPriority p + 2
|
|
||||||
prioOf' p (Just s) (Just t) = prioOf p s t
|
|
||||||
|
|
||||||
instance Individual I where
|
instance Environment Assignment AssignmentEnviroment where
|
||||||
new (I p _) =
|
new (AssignmentEnviroment (persons,assignables)) = do
|
||||||
I p . zip students' <$> shuffle topics'
|
let aPadding = replicate (length persons - length assignables) Nothing
|
||||||
where
|
let paddedAssignables = (Just <$> assignables) ++ aPadding
|
||||||
topics' = (Just <$> topics p) ++ tPadding
|
let pPadding = replicate (length assignables - length persons) Nothing
|
||||||
tPadding = replicate (length (students p) - length (topics p)) Nothing
|
let paddedPersons = (Just <$> persons) ++ pPadding
|
||||||
students' = (Just <$> students p) ++ sPadding
|
|
||||||
sPadding = replicate (length (topics p) - length (students p)) Nothing
|
|
||||||
|
|
||||||
fitness (I p a) =
|
mixedAssignables <- shuffle paddedAssignables
|
||||||
negate . sum $ fromIntegral . uncurry (prioOf' p) <$> a
|
return $ zip paddedPersons mixedAssignables
|
||||||
|
|
||||||
mutate (I p a) = do
|
mutate _ assignment = do
|
||||||
x <- uniform 0 (length a - 1)
|
x <- uniform 0 (length assignment - 1)
|
||||||
y <- uniform 0 (length a - 1)
|
y <- uniform 0 (length assignment - 1)
|
||||||
return . I p $ switch x y a
|
return $ switch x y assignment
|
||||||
|
|
||||||
-- \|
|
-- \|
|
||||||
-- Borrowed from TSP: Crossover cuts the parents in two and swaps them (if this
|
-- Borrowed from TSP: Crossover cuts the parents in two and swaps them (if this
|
||||||
|
@ -144,31 +127,50 @@ instance Individual I where
|
||||||
--
|
--
|
||||||
-- TODO Assumes that both individuals are based on the same priorities.
|
-- TODO Assumes that both individuals are based on the same priorities.
|
||||||
--
|
--
|
||||||
crossover1 (I p a1) (I _ a2) = do
|
crossover1 e assignment1 assignment2 = do
|
||||||
let l = fromIntegral $ min (length a1) (length a2) :: Double
|
let l = fromIntegral $ min (length assignment1) (length assignment2) :: Double
|
||||||
x <- uniform 0 l
|
x <- uniform 0 l
|
||||||
let a1' = zipWith3 (f x) a1 a2 [0 ..]
|
let assignment1' = zipWith3 (f x) assignment1 assignment2 [0 ..]
|
||||||
let a2' = zipWith3 (f x) a2 a1 [0 ..]
|
let assignment2' = zipWith3 (f x) assignment2 assignment1 [0 ..]
|
||||||
if valid p a1' && valid p a2'
|
if valid e assignment1' && valid e assignment2'
|
||||||
then return . Just $ (I p a1', I p a2')
|
then return . Just $ ( assignment1', assignment2')
|
||||||
else return Nothing
|
else return Nothing
|
||||||
where
|
where
|
||||||
f x v1 v2 i = if i <= x then v1 else v2
|
f x v1 v2 i = if i <= x then v1 else v2
|
||||||
|
|
||||||
|
|
||||||
|
instance Pretty Assignment where
|
||||||
|
pretty (a) =
|
||||||
|
T.unlines (gene <$> a)
|
||||||
|
where
|
||||||
|
gene :: (Maybe Student, Maybe Topic) -> Text
|
||||||
|
gene (s, t) =
|
||||||
|
pretty s <> ": " <> pretty t
|
||||||
|
|
||||||
|
-- |
|
||||||
|
-- The priority value given by a student to a topic including the case of her not
|
||||||
|
-- receiving a topic.
|
||||||
|
prioOf' :: Priorities -> Maybe Student -> Maybe Topic -> Int
|
||||||
|
-- TODO Maybe make this neutral?
|
||||||
|
prioOf' p Nothing Nothing = lowestPriority p + 2
|
||||||
|
prioOf' p (Just _) Nothing = lowestPriority p + 2
|
||||||
|
prioOf' p Nothing (Just _) = lowestPriority p + 2
|
||||||
|
prioOf' p (Just s) (Just t) = prioOf p s t
|
||||||
|
|
||||||
|
instance Evaluator Assignment Priorities where
|
||||||
|
fitness prio assment =
|
||||||
|
negate . sum $ fromIntegral . uncurry (prioOf' prio) <$> assment
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
-- Swaps topics at positions 'i'' and 'j'' in the given assignment.
|
-- Swaps topics at positions 'i'' and 'j'' in the given assignment.
|
||||||
switch :: Int -> Int -> Assignment -> Assignment
|
switch :: Int -> Int -> Assignment -> Assignment
|
||||||
switch i' j' xs
|
switch i' j' xs
|
||||||
| i' == j' = xs
|
| i' == j' = xs
|
||||||
| 0 <= i' && i' < length xs && 0 <= j' && j' < length xs =
|
| 0 <= i' && i' < length xs && 0 <= j' && j' < length xs =
|
||||||
let i = min i' j'
|
zipWith (\ind y ->
|
||||||
j = max i' j'
|
if ind == i' then (fst y, snd (xs !! j'))
|
||||||
ei = xs !! i
|
else if ind == j' then (fst y, snd (xs !! i'))
|
||||||
ej = xs !! j
|
else y) [0..] xs
|
||||||
left = take i xs
|
|
||||||
middle = take (j - i - 1) $ drop (i + 1) xs
|
|
||||||
right = drop (j + 1) xs
|
|
||||||
in left ++ [(fst ei, snd ej)] ++ middle ++ [(fst ej, snd ei)] ++ right
|
|
||||||
| otherwise = xs
|
| otherwise = xs
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
|
@ -177,10 +179,10 @@ switch i' j' xs
|
||||||
-- less topics than students).
|
-- less topics than students).
|
||||||
--
|
--
|
||||||
-- Assumes that the priorities are well-formed.
|
-- Assumes that the priorities are well-formed.
|
||||||
valid :: Priorities -> Assignment -> Bool
|
valid :: AssignmentEnviroment -> Assignment -> Bool
|
||||||
valid p a =
|
valid (AssignmentEnviroment (persons,assignables)) a =
|
||||||
-- all students must be part of the solution
|
-- all students must be part of the solution
|
||||||
sort (students p) == (catMaybes $ sort studentsAssigned)
|
sort (persons) == (catMaybes $ sort studentsAssigned)
|
||||||
-- each actual topic (i.e. not “no topic”) is assigned at most once
|
-- each actual topic (i.e. not “no topic”) is assigned at most once
|
||||||
&& nubOrd (delete Nothing topicsAssigned) == delete Nothing topicsAssigned
|
&& nubOrd (delete Nothing topicsAssigned) == delete Nothing topicsAssigned
|
||||||
where
|
where
|
||||||
|
|
Loading…
Reference in New Issue
Block a user