.gitignore

@@ -1,3 +1,2 @@
 /.ghc.environment.x86_64-linux-8.6.5
 dist-newstyle/
-.stack-work

haga.cabal

@@ -20,7 +20,7 @@ category:            Optimization
 build-type:          Simple
 
 library
-  build-depends:       base
+  build-depends:       base ^>=4.14.0.0
                      , cassava
                      , extra
                      , MonadRandom
@@ -31,22 +31,23 @@ library
                      , QuickCheck
                      , quickcheck-instances
                      , random
-                     , random-fu
+                     -- 0.3.0.0 introduces at least one truly breaking change.
+                     , random-fu <0.3.0.0
                      , random-shuffle
-                     , mwc-random
-                     , primitive
                      , text
                      , wl-pprint-text
   default-language:    Haskell2010
-  ghc-options:         -Wall -Wno-name-shadowing -Wno-orphans -threaded -rtsopts
+  ghc-options:         -Wall -Wno-name-shadowing -Wno-orphans
   hs-source-dirs:      src
   exposed-modules:     GA
                      , Seminar
                      , Pretty
                      , Szenario191
+                     , Szenario202
+                     , Analysis
 
 executable haga
-  build-depends:       base
+  build-depends:       base ^>=4.14.0.0
                      , cassava
                      , extra
                      , MonadRandom
@@ -57,23 +58,23 @@ executable haga
                      , QuickCheck
                      , quickcheck-instances
                      , random
-                     , random-fu
+                     -- 0.3.0.0 introduces at least one truly breaking change.
+                     , random-fu <0.3.0.0
                      , random-shuffle
-                     , mwc-random
-                     , primitive
                      , text
                      , wl-pprint-text
   default-language:    Haskell2010
-  ghc-options:         -Wall -Wno-name-shadowing -Wno-orphans -threaded -rtsopts
+  ghc-options:         -Wall -Wno-name-shadowing -Wno-orphans
   hs-source-dirs:      src
   main-is:             Main.hs
   other-modules:       GA
                      , Seminar
                      , Pretty
                      , Szenario191
+                     , Szenario202
 
 executable haga-test
-  build-depends:       base
+  build-depends:       base ^>=4.14.0.0
                      , cassava
                      , Cabal
                      , extra
@@ -85,14 +86,13 @@ executable haga-test
                      , QuickCheck
                      , quickcheck-instances
                      , random
-                     , random-fu
+                     -- 0.3.0.0 introduces at least one truly breaking change.
+                     , random-fu <0.3.0.0
                      , random-shuffle
-                     , mwc-random
-                     , primitive
                      , text
                      , wl-pprint-text
   default-language:    Haskell2010
-  ghc-options:         -Wall -Wno-name-shadowing -Wno-orphans -threaded -rtsopts
+  ghc-options:         -Wall -Wno-name-shadowing -Wno-orphans
   hs-source-dirs:      src
   main-is:             Test.hs
   other-modules:       GA

src/GA.hs

@@ -27,7 +27,6 @@ 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)
@@ -49,18 +48,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 :: i -> RVar i
+  new :: (MonadRandom m) => i -> m i
 
   -- |
   --  Generates a random population of the given size.
-  population :: N -> i -> RVar (Population i)
+  population :: (MonadRandom m) => N -> i -> m (Population i)
   population n i
     | n <= 0 = undefined
     | otherwise = NE.fromList <$> replicateM n (new i)
 
-  mutate :: i -> RVar i
+  mutate :: (MonadRandom m) => i -> m i
 
-  crossover1 :: i -> i -> RVar (Maybe (i, i))
+  crossover1 :: (MonadRandom m) => i -> i -> m (Maybe (i, i))
 
   -- |
   --  An individual's fitness. Higher values are considered “better”.
@@ -75,7 +74,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 :: N -> i -> i -> RVar (Maybe (i, i))
+  crossover :: (MonadRandom m) => N -> i -> i -> m (Maybe (i, i))
   crossover n i1 i2
     | n <= 0 = return $ Just (i1, i2)
     | otherwise = do
@@ -86,9 +85,9 @@ class Eq i => Individual i where
 -- Needed for QuickCheck tests, for now, a very simplistic implementation should
 -- suffice.
 instance Individual Integer where
-  new _ = uniform 0 (0 + 100000)
+  new _ = sample $ uniform 0 (0 + 100000)
 
-  mutate i = uniform (i - 10) (i + 10)
+  mutate i = sample $ uniform (i - 10) (i + 10)
 
   crossover1 i1 i2 = return $ Just (i1 - i2, i2 - i1)
 
@@ -101,11 +100,11 @@ type Population i = NonEmpty i
 -- |
 -- Produces offspring circularly from the given list of parents.
 children ::
-  (Individual i) =>
+  (Individual i, MonadRandom m) =>
   -- | The @nX@ of the @nX@-point crossover operator
   N ->
   NonEmpty i ->
-  RVar (NonEmpty i)
+  m (NonEmpty i)
 children _ (i :| []) = (:| []) <$> mutate i
 children nX (i1 :| [i2]) = children2 nX i1 i2
 children nX (i1 :| i2 : is') =
@@ -117,11 +116,10 @@ prop_children_asManyAsParents nX is =
   again $
     monadicIO $
       do
-        mwc <- Test.QuickCheck.Monadic.run create
+        is' <- lift $ children nX is
-        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, 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
@@ -193,9 +191,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) =>
+  (Individual i, MonadRandom m, Monad m) =>
   -- | Mechanism for selecting parents
-  Selection RVar i ->
+  Selection m i ->
   -- | Number of parents @nParents@ for creating @nParents@ children
   N ->
   -- | How many crossover points (the @nX@ in @nX@-point crossover)
@@ -203,7 +201,7 @@ stepSteady ::
   -- | Elitism ratio @pElite@
   R ->
   Population i ->
-  RVar (Population i)
+  m (Population i)
 stepSteady select nParents nX pElite pop = do
   -- TODO Consider keeping the fitness evaluations already done for pop (so we
   -- only reevaluate iChildren)
@@ -235,8 +233,7 @@ prop_stepSteady_constantPopSize pop =
     )
     $ \(nParents, nX) -> monadicIO $ do
       let pElite = 0.1
-      mwc <- Test.QuickCheck.Monadic.run create
+      pop' <- lift $ stepSteady (tournament 4) nParents nX pElite pop
-      pop' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (stepSteady (tournament 4) nParents nX pElite pop)
       return . counterexample (show pop') $ length pop' == length pop
 
 -- |
@@ -246,34 +243,29 @@ prop_stepSteady_constantPopSize pop =
 -- Uses the pipes library to, in each step, 'Pipes.yield' the currently best known
 -- solution.
 run ::
-  (Individual i) =>
+  (Individual i, Monad m, MonadRandom m) =>
   -- | Mechanism for selecting parents
-  Selection RVar i ->
+  Selection m 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 ->
-  RVar (Population i) ->
+  Population i ->
   Termination i ->
-  Producer (Int, R) IO (Population i)
+  Producer (Int, R) m (Population i)
-run select nParents nX pElite pop term = do
+run select nParents nX pElite pop term = step' 0 pop
-        mwc <- lift create
+  where
-        let x = \currPop generation -> do
+    step' t pop
-              currPop' <- lift $ sampleFrom mwc $ currPop
+      | term pop t = return pop
-              if term currPop' generation
+      | otherwise = do
-                then return currPop'
+          pop' <- lift $ stepSteady select nParents nX pElite pop
-                else do
+          (iBests, _) <- lift $ bests 1 pop'
-                  let nextPop = stepSteady select nParents nX pElite currPop'
+          fs <- lift . sequence $ fitness <$> iBests
-                  nextPop' <- lift $ sampleFrom mwc $ nextPop
+          let fBest = NE.head fs
-                  (iBests, _) <- lift $ bests 1 nextPop'
+          Pipes.yield (t, fBest)
-                  fs <- lift . sequence $ fitness <$> iBests
+          step' (t + 1) pop'
-                  let fBest = NE.head fs
-                  Pipes.yield (generation, fBest)
-                  x nextPop (generation + 1)
-        x pop 0
-
 
 -- * Selection mechanisms
 
@@ -287,9 +279,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) =>
+  (Individual i, MonadRandom m) =>
-  (Population i -> RVar i) ->
+  (Population i -> m i) ->
-  Selection RVar i
+  Selection m i
 -- TODO Ensure that the same individual is not selected multiple times
 -- (require Selections to partition)
 chain select1 n pop
@@ -300,7 +292,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) => N -> Selection RVar i
+tournament :: (Individual i, MonadRandom m) => N -> Selection m i
 tournament nTrnmnt = chain (tournament1 nTrnmnt)
 
 prop_tournament_selectsN :: Individual a => Int -> Int -> NonEmpty a -> Property
@@ -310,18 +302,17 @@ prop_tournament_selectsN nTrnmnt n pop =
     && 0 < n
     ==> monadicIO
     $ do
-      mwc <- Test.QuickCheck.Monadic.run create
+      pop' <- lift $ tournament 2 n pop
-      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) =>
+  (Individual i, MonadRandom m) =>
   -- | Tournament size
   N ->
   Population i ->
-  RVar i
+  m i
 tournament1 nTrnmnt pop
   -- TODO Use Positive for this constraint
   | nTrnmnt <= 0 = undefined
@@ -333,21 +324,22 @@ 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 ->
-  RVar (NonEmpty i)
+  m (NonEmpty i)
 withoutReplacement 0 _ = undefined
 withoutReplacement n pop
   | n >= length pop = return pop
-  | otherwise = fmap (NE.fromList) (shuffleNofM n (length pop) (NE.toList pop))
+  | otherwise =
+      fmap NE.fromList . sample . 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
+  0 < n && n <= length pop ==> monadicIO $ do
-    mwc <- Test.QuickCheck.Monadic.run create
+    pop' <- lift $ withoutReplacement n pop
-    pop' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (withoutReplacement n pop)
+    assert $ length pop' == n
-    assert $ length pop' == n)
 
 -- * Termination criteria
 
@@ -365,15 +357,21 @@ steps tEnd _ t = t >= tEnd
 
 -- |
 -- Shuffles a non-empty list.
-shuffle' :: NonEmpty a -> RVar (NonEmpty a)
+shuffle' :: (MonadRandom m) => NonEmpty a -> m (NonEmpty a)
 shuffle' xs@(_ :| []) = return xs
-shuffle' xs = fmap (NE.fromList) (shuffle (toList 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)
 
 prop_shuffle_length :: NonEmpty a -> Property
-prop_shuffle_length xs = monadicIO(do
+prop_shuffle_length xs = monadicIO $ do
-  mwc <- Test.QuickCheck.Monadic.run create
+  xs' <- lift $ shuffle' xs
-  xs' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (shuffle' xs)
+  assert $ length xs' == length xs
-  assert $ length xs' == length xs)
 
 return []
 

src/Main.hs

@@ -5,10 +5,10 @@
 import Options.Applicative
 import Pipes
 import Pretty
-import Protolude hiding (for)
+import Protolude hiding (for, option)
 import System.IO
 -- import Szenario212Pun
-import Szenario191
+import Szenario222
 
 data Options = Options
   { iterations :: N,
@@ -48,14 +48,15 @@ main :: IO ()
 main =
   execParser optionsWithHelp >>= \opts -> do
     hSetBuffering stdout NoBuffering
-    let pop = population (populationSize opts) (I prios [])
+    pop <- population (populationSize opts) (I prios [])
     pop' <-
-      runEffect (for (run (tournament 2) 2 1 (5 / 100) pop (steps (iterations opts))) logCsv)
+      runEffect $
+        for (run (tournament 2) 2 1 (5 / 100) pop (steps $ iterations opts)) log
     (res, _) <- bests 5 pop'
     sequence_ $ format <$> res
   where
     format s = do
       f <- liftIO $ fitness s
       putErrText $ show f <> "\n" <> pretty s
-    logCsv = putText . csv
+    log = putText . csv
     csv (t, f) = show t <> " " <> show f

src/Seminar.hs

@@ -123,7 +123,7 @@ prioOf' p (Just s) (Just t) = prioOf p s t
 
 instance Individual I where
   new (I p _) =
-    I p . zip students' <$> shuffle topics'
+    sample $ 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 <- uniform 0 (length a - 1)
+    x <- sample $ Uniform 0 (length a - 1)
-    y <- uniform 0 (length a - 1)
+    y <- sample $ 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 <- uniform 0 l
+    x <- sample $ 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'

stack.yaml

@@ -1,66 +0,0 @@
-# This file was automatically generated by 'stack init'
-#
-# Some commonly used options have been documented as comments in this file.
-# For advanced use and comprehensive documentation of the format, please see:
-# https://docs.haskellstack.org/en/stable/yaml_configuration/
-
-# Resolver to choose a 'specific' stackage snapshot or a compiler version.
-# A snapshot resolver dictates the compiler version and the set of packages
-# to be used for project dependencies. For example:
-#
-# resolver: lts-21.13
-# resolver: nightly-2023-09-24
-# resolver: ghc-9.6.2
-#
-# The location of a snapshot can be provided as a file or url. Stack assumes
-# a snapshot provided as a file might change, whereas a url resource does not.
-#
-# resolver: ./custom-snapshot.yaml
-# resolver: https://example.com/snapshots/2023-01-01.yaml
-resolver: lts-21.25
-
-# User packages to be built.
-# Various formats can be used as shown in the example below.
-#
-# packages:
-# - some-directory
-# - https://example.com/foo/bar/baz-0.0.2.tar.gz
-#   subdirs:
-#   - auto-update
-#   - wai
-packages:
-- .
-# Dependency packages to be pulled from upstream that are not in the resolver.
-# These entries can reference officially published versions as well as
-# forks / in-progress versions pinned to a git hash. For example:
-#
-# extra-deps:
-# - acme-missiles-0.3
-# - git: https://github.com/commercialhaskell/stack.git
-#   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
-#
-# extra-deps: []
-
-# Override default flag values for local packages and extra-deps
-# flags: {}
-
-# Extra package databases containing global packages
-# extra-package-dbs: []
-
-# Control whether we use the GHC we find on the path
-# system-ghc: true
-#
-# Require a specific version of Stack, using version ranges
-# require-stack-version: -any # Default
-# require-stack-version: ">=2.13"
-#
-# Override the architecture used by Stack, especially useful on Windows
-# arch: i386
-# arch: x86_64
-#
-# Extra directories used by Stack for building
-# extra-include-dirs: [/path/to/dir]
-# extra-lib-dirs: [/path/to/dir]
-#
-# Allow a newer minor version of GHC than the snapshot specifies
-# compiler-check: newer-minor

stack.yaml.lock

@@ -1,12 +0,0 @@
-# This file was autogenerated by Stack.
-# You should not edit this file by hand.
-# For more information, please see the documentation at:
-#   https://docs.haskellstack.org/en/stable/lock_files
-
-packages: []
-snapshots:
-- completed:
-    sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd
-    size: 640086
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml
-  original: lts-21.25