diff --git a/haga.cabal b/haga.cabal index b9fca91..196fc8a 100644 --- a/haga.cabal +++ b/haga.cabal @@ -20,7 +20,7 @@ category: Optimization build-type: Simple library - build-depends: base ^>=4.14.0.0 + build-depends: base , cassava , extra , MonadRandom @@ -31,23 +31,22 @@ library , QuickCheck , quickcheck-instances , random - -- 0.3.0.0 introduces at least one truly breaking change. - , random-fu <0.3.0.0 + , random-fu , random-shuffle + , mwc-random + , primitive , text , wl-pprint-text default-language: Haskell2010 - ghc-options: -Wall -Wno-name-shadowing -Wno-orphans + ghc-options: -Wall -Wno-name-shadowing -Wno-orphans -threaded -rtsopts hs-source-dirs: src exposed-modules: GA , Seminar , Pretty , Szenario191 - , Szenario202 - , Analysis executable haga - build-depends: base ^>=4.14.0.0 + build-depends: base , cassava , extra , MonadRandom @@ -58,23 +57,23 @@ executable haga , QuickCheck , quickcheck-instances , random - -- 0.3.0.0 introduces at least one truly breaking change. - , random-fu <0.3.0.0 + , random-fu , random-shuffle + , mwc-random + , primitive , text , wl-pprint-text default-language: Haskell2010 - ghc-options: -Wall -Wno-name-shadowing -Wno-orphans + ghc-options: -Wall -Wno-name-shadowing -Wno-orphans -threaded -rtsopts hs-source-dirs: src main-is: Main.hs other-modules: GA , Seminar , Pretty , Szenario191 - , Szenario202 executable haga-test - build-depends: base ^>=4.14.0.0 + build-depends: base , cassava , Cabal , extra @@ -86,13 +85,14 @@ executable haga-test , QuickCheck , quickcheck-instances , random - -- 0.3.0.0 introduces at least one truly breaking change. - , random-fu <0.3.0.0 + , random-fu , random-shuffle + , mwc-random + , primitive , text , wl-pprint-text default-language: Haskell2010 - ghc-options: -Wall -Wno-name-shadowing -Wno-orphans + ghc-options: -Wall -Wno-name-shadowing -Wno-orphans -threaded -rtsopts hs-source-dirs: src main-is: Test.hs other-modules: GA diff --git a/src/GA.hs b/src/GA.hs index ec56ca6..bb4acae 100644 --- a/src/GA.hs +++ b/src/GA.hs @@ -27,6 +27,7 @@ import Data.List.NonEmpty ((<|)) import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty.Extra as NE (appendl, sortOn) import Data.Random +import System.Random.MWC (create) import Pipes import Protolude import Test.QuickCheck hiding (sample, shuffle) @@ -48,18 +49,18 @@ class Eq i => Individual i where -- TODO This (and also, Seminar.I, which contains an ugly parameter @p@) has -- to be done nicer! - new :: (MonadRandom m) => i -> m i + new :: i -> RVar i -- | -- Generates a random population of the given size. - population :: (MonadRandom m) => N -> i -> m (Population i) + population :: N -> i -> RVar (Population i) population n i | n <= 0 = undefined | otherwise = NE.fromList <$> replicateM n (new i) - mutate :: (MonadRandom m) => i -> m i + mutate :: i -> RVar i - crossover1 :: (MonadRandom m) => i -> i -> m (Maybe (i, i)) + crossover1 :: i -> i -> RVar (Maybe (i, i)) -- | -- An individual's fitness. Higher values are considered “better”. @@ -74,7 +75,7 @@ class Eq i => Individual i where -- 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 -> i -> i -> RVar (Maybe (i, i)) crossover n i1 i2 | n <= 0 = return $ Just (i1, i2) | otherwise = do @@ -85,9 +86,9 @@ class Eq i => Individual i where -- Needed for QuickCheck tests, for now, a very simplistic implementation should -- suffice. instance Individual Integer where - new _ = sample $ uniform 0 (0 + 100000) + new _ = uniform 0 (0 + 100000) - mutate i = sample $ uniform (i - 10) (i + 10) + mutate i = uniform (i - 10) (i + 10) crossover1 i1 i2 = return $ Just (i1 - i2, i2 - i1) @@ -100,11 +101,11 @@ type Population i = NonEmpty i -- | -- Produces offspring circularly from the given list of parents. children :: - (Individual i, MonadRandom m) => + (Individual i) => -- | The @nX@ of the @nX@-point crossover operator N -> NonEmpty i -> - m (NonEmpty i) + RVar (NonEmpty i) children _ (i :| []) = (:| []) <$> mutate i children nX (i1 :| [i2]) = children2 nX i1 i2 children nX (i1 :| i2 : is') = @@ -116,10 +117,11 @@ prop_children_asManyAsParents nX is = again $ monadicIO $ do - is' <- lift $ children nX is + 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, MonadRandom m) => N -> i -> i -> m (NonEmpty i) +children2 :: (Individual i) => N -> i -> i -> RVar (NonEmpty i) children2 nX i1 i2 = do -- TODO Add crossover probability? (i3, i4) <- fromMaybe (i1, i2) <$> crossover nX i1 i2 @@ -191,9 +193,9 @@ bests = flip bestsBy fitness -- elitist, even if the percentage is 0 or low enough for rounding to result in 0 -- elitists). stepSteady :: - (Individual i, MonadRandom m, Monad m) => + (Individual i) => -- | Mechanism for selecting parents - Selection m i -> + Selection RVar i -> -- | Number of parents @nParents@ for creating @nParents@ children N -> -- | How many crossover points (the @nX@ in @nX@-point crossover) @@ -201,7 +203,7 @@ stepSteady :: -- | Elitism ratio @pElite@ R -> Population i -> - m (Population i) + RVar (Population i) stepSteady select nParents nX pElite pop = do -- TODO Consider keeping the fitness evaluations already done for pop (so we -- only reevaluate iChildren) @@ -233,7 +235,8 @@ prop_stepSteady_constantPopSize pop = ) $ \(nParents, nX) -> monadicIO $ do let pElite = 0.1 - pop' <- lift $ stepSteady (tournament 4) nParents nX pElite pop + 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 -- | @@ -243,29 +246,34 @@ prop_stepSteady_constantPopSize pop = -- Uses the pipes library to, in each step, 'Pipes.yield' the currently best known -- solution. run :: - (Individual i, Monad m, MonadRandom m) => + (Individual i) => -- | Mechanism for selecting parents - Selection m i -> + Selection RVar 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 -> + RVar (Population i) -> Termination i -> - Producer (Int, R) m (Population i) -run select nParents nX pElite pop term = step' 0 pop - where - step' t pop - | term pop t = return pop - | otherwise = do - pop' <- lift $ stepSteady select nParents nX pElite pop - (iBests, _) <- lift $ bests 1 pop' - fs <- lift . sequence $ fitness <$> iBests - let fBest = NE.head fs - Pipes.yield (t, fBest) - step' (t + 1) pop' + Producer (Int, R) IO (Population i) +run select nParents nX pElite pop term = do + mwc <- lift create + let x = \currPop generation -> do + currPop' <- lift $ sampleFrom mwc $ currPop + if term currPop' generation + then return currPop' + else do + let nextPop = stepSteady select nParents nX pElite currPop' + nextPop' <- lift $ sampleFrom mwc $ nextPop + (iBests, _) <- lift $ bests 1 nextPop' + fs <- lift . sequence $ fitness <$> iBests + let fBest = NE.head fs + Pipes.yield (generation, fBest) + x nextPop (generation + 1) + x pop 0 + -- * Selection mechanisms @@ -279,9 +287,9 @@ type Selection m i = N -> Population i -> m (NonEmpty i) -- 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 + (Individual i) => + (Population i -> RVar i) -> + Selection RVar i -- TODO Ensure that the same individual is not selected multiple times -- (require Selections to partition) chain select1 n pop @@ -292,7 +300,7 @@ chain select1 n pop -- 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 :: (Individual i) => N -> Selection RVar i tournament nTrnmnt = chain (tournament1 nTrnmnt) prop_tournament_selectsN :: Individual a => Int -> Int -> NonEmpty a -> Property @@ -302,17 +310,18 @@ prop_tournament_selectsN nTrnmnt n pop = && 0 < n ==> monadicIO $ do - pop' <- lift $ tournament 2 n pop + 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. tournament1 :: - (Individual i, MonadRandom m) => + (Individual i) => -- | Tournament size N -> Population i -> - m i + RVar i tournament1 nTrnmnt pop -- TODO Use Positive for this constraint | nTrnmnt <= 0 = undefined @@ -324,22 +333,21 @@ tournament1 nTrnmnt pop -- 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) + RVar (NonEmpty i) withoutReplacement 0 _ = undefined withoutReplacement n pop | n >= length pop = return pop - | otherwise = - fmap NE.fromList . sample . 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 - pop' <- lift $ withoutReplacement n pop - assert $ length pop' == n + 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 @@ -357,21 +365,15 @@ steps tEnd _ t = t >= tEnd -- | -- Shuffles a non-empty list. -shuffle' :: (MonadRandom m) => NonEmpty a -> m (NonEmpty a) +shuffle' :: NonEmpty a -> RVar (NonEmpty a) shuffle' xs@(_ :| []) = return xs -shuffle' xs = do - i <- sample . uniform 0 $ NE.length xs - 1 - -- slightly unsafe (!!) used here so deletion is faster - let x = xs NE.!! i - xs' <- sample . shuffle $ deleteI i xs - return $ x :| xs' - where - deleteI i xs = fst (NE.splitAt i xs) ++ snd (NE.splitAt (i + 1) xs) +shuffle' xs = fmap (NE.fromList) (shuffle (toList xs)) prop_shuffle_length :: NonEmpty a -> Property -prop_shuffle_length xs = monadicIO $ do - xs' <- lift $ shuffle' xs - assert $ length xs' == length xs +prop_shuffle_length xs = monadicIO(do + mwc <- Test.QuickCheck.Monadic.run create + xs' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (shuffle' xs) + assert $ length xs' == length xs) return [] diff --git a/src/Main.hs b/src/Main.hs index a19e894..eb6fd48 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -5,10 +5,10 @@ import Options.Applicative import Pipes import Pretty -import Protolude hiding (for, option) +import Protolude hiding (for) import System.IO -- import Szenario212Pun -import Szenario222 +import Szenario191 data Options = Options { iterations :: N, @@ -48,15 +48,14 @@ main :: IO () main = execParser optionsWithHelp >>= \opts -> do hSetBuffering stdout NoBuffering - pop <- population (populationSize opts) (I prios []) + let 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))) logCsv) (res, _) <- bests 5 pop' sequence_ $ format <$> res where format s = do f <- liftIO $ fitness s putErrText $ show f <> "\n" <> pretty s - log = putText . csv + logCsv = putText . csv csv (t, f) = show t <> " " <> show f diff --git a/src/Seminar.hs b/src/Seminar.hs index 5ed3bcf..897c748 100644 --- a/src/Seminar.hs +++ b/src/Seminar.hs @@ -123,7 +123,7 @@ prioOf' p (Just s) (Just t) = prioOf p s t instance Individual I where new (I p _) = - sample $ I p . zip students' <$> shuffle topics' + I p . zip students' <$> shuffle topics' where topics' = (Just <$> topics p) ++ tPadding tPadding = replicate (length (students p) - length (topics p)) Nothing @@ -135,8 +135,8 @@ instance Individual I where fromIntegral . uncurry (prioOf' p) <$> a mutate (I p a) = do - x <- sample $ Uniform 0 (length a - 1) - y <- sample $ Uniform 0 (length a - 1) + x <- uniform 0 (length a - 1) + y <- uniform 0 (length a - 1) return . I p $ switch x y a -- \| @@ -147,7 +147,7 @@ instance Individual I where -- crossover1 (I p a1) (I _ a2) = do let l = fromIntegral $ min (length a1) (length a2) :: Double - x <- sample $ Uniform 0 l + x <- uniform 0 l let a1' = zipWith3 (f x) a1 a2 [0 ..] let a2' = zipWith3 (f x) a2 a1 [0 ..] if valid p a1' && valid p a2'