update to RVar

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
-                     , 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
+  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
-                     , 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
+  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
-                     , 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
+  ghc-options:         -Wall -Wno-name-shadowing -Wno-orphans -threaded -rtsopts
   hs-source-dirs:      src
   main-is:             Test.hs
   other-modules:       GA

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)
+  Producer (Int, R) IO (Population i)
-run select nParents nX pElite pop term = step' 0 pop
+run select nParents nX pElite pop term = do
-  where
+        mwc <- lift create
-    step' t pop
+        let x = \currPop generation -> do
-      | term pop t = return pop
+              currPop' <- lift $ sampleFrom mwc $ currPop
-      | otherwise = do
+              if term currPop' generation
-          pop' <- lift $ stepSteady select nParents nX pElite pop
+                then return currPop'
-          (iBests, _) <- lift $ bests 1 pop'
+                else do
-          fs <- lift . sequence $ fitness <$> iBests
+                  let nextPop = stepSteady select nParents nX pElite currPop'
-          let fBest = NE.head fs
+                  nextPop' <- lift $ sampleFrom mwc $ nextPop
-          Pipes.yield (t, fBest)
+                  (iBests, _) <- lift $ bests 1 nextPop'
-          step' (t + 1) pop'
+                  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) =>
+  (Individual i) =>
-  (Population i -> m i) ->
+  (Population i -> RVar i) ->
-  Selection m 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 =
+  | otherwise = fmap (NE.fromList) (shuffleNofM n (length pop) (NE.toList pop))
-      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
-    pop' <- lift $ withoutReplacement n pop
+    mwc <- Test.QuickCheck.Monadic.run create
-    assert $ length pop' == n
+    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
+shuffle' xs = fmap (NE.fromList) (shuffle (toList xs))
-  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
-  xs' <- lift $ shuffle' xs
+  mwc <- Test.QuickCheck.Monadic.run create
-  assert $ length xs' == length xs
+  xs' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (shuffle' 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, 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 $
+      runEffect (for (run (tournament 2) 2 1 (5 / 100) pop (steps (iterations opts))) logCsv)
-        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
-    log = putText . csv
+    logCsv = 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 _) =
-    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)
+    x <- uniform 0 (length a - 1)
-    y <- sample $ 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'