Merge pull request #60 from thalerjonathan/develop

Contributing 'occasionally' and MonadRandom stuff to Dunai & BearRiver.

Refs #40 .

dunai.cabal

@@ -58,6 +58,7 @@ library
                      Control.Monad.Trans.MSF.Except
                      Control.Monad.Trans.MSF.GenLift
                      Control.Monad.Trans.MSF.Maybe
+                     Control.Monad.Trans.MSF.Random
                      Control.Monad.Trans.MSF.Reader
                      Control.Monad.Trans.MSF.State
                      Control.Monad.Trans.MSF.Writer
@@ -83,7 +84,8 @@ library
 
   build-depends:     base >=4.6 && < 5,
                      transformers,
-                     transformers-base
+                     transformers-base,
+                     MonadRandom
   hs-source-dirs:    src
   default-language:  Haskell2010
   ghc-options:       -Wall -fno-warn-unused-do-bind

examples/bearriver/bearriver.cabal

@@ -23,7 +23,7 @@ library
                        FRP.Yampa.AffineSpace,
                        FRP.BearRiver
 
-  build-depends:       base >=4.7 && <5, transformers >=0.3, mtl, dunai
+  build-depends:       base >=4.7 && <5, transformers >=0.3, mtl, dunai, MonadRandom
   hs-source-dirs:      src/
   default-language:    Haskell2010
 

examples/bearriver/src/FRP/BearRiver.hs

@@ -16,8 +16,10 @@ import           Control.Arrow                as X
 import qualified Control.Category             as Category
 import           Control.Monad                (mapM)
 --import           Control.Monad.Reader
+import           Control.Monad.Random
 import           Control.Monad.Trans.Maybe
 import           Control.Monad.Trans.MSF
+import           Control.Monad.Trans.MSF.Random
 import           Data.Traversable             as T
 import           Data.Functor.Identity
 import           Data.Maybe
@@ -153,6 +155,21 @@ after q x = feedback q go
                   ct = if t' < 0 then constant (NoEvent, t') else go
               return ((e, t'), ct)
 
+occasionally :: MonadRandom m 
+             => Time -- ^ The time /q/ after which the event should be produced on average
+             -> b    -- ^ Value to produce at time of event
+             -> SF m a (Event b)
+occasionally tAvg b
+  | tAvg <= 0 = error "dunai: Non-positive average interval in occasionally."
+  | otherwise = proc _ -> do
+      r   <- getRandomRS (0, 1) -< ()
+      dt  <- timeDelta          -< ()
+      let p = 1 - exp (-(dt / tAvg))
+      returnA -< if r < p then Event b else NoEvent
+ where
+  timeDelta :: Monad m => SF m a DTime
+  timeDelta = arrM_ ask
+
 (-->) :: Monad m => b -> SF m a b -> SF m a b
 b0 --> sf = MSF $ \a -> do
   (_, ct) <- unMSF sf a

src/Control/Monad/Trans/MSF.hs

@@ -6,6 +6,7 @@ module Control.Monad.Trans.MSF
     ( module Control.Monad.Trans.MSF.GenLift
     , module Control.Monad.Trans.MSF.Except
     , module Control.Monad.Trans.MSF.Maybe
+    , module Control.Monad.Trans.MSF.Random
     , module Control.Monad.Trans.MSF.Reader
     , module Control.Monad.Trans.MSF.State
     , module Control.Monad.Trans.MSF.Writer
@@ -15,6 +16,7 @@ module Control.Monad.Trans.MSF
 import Control.Monad.Trans.MSF.GenLift
 import Control.Monad.Trans.MSF.Except
 import Control.Monad.Trans.MSF.Maybe
+import Control.Monad.Trans.MSF.Random
 import Control.Monad.Trans.MSF.Reader
 import Control.Monad.Trans.MSF.State
 import Control.Monad.Trans.MSF.Writer

src/Control/Monad/Trans/MSF/Random.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE Arrows              #-}
+module Control.Monad.Trans.MSF.Random 
+  (
+    runRandS
+  , evalRandS
+
+  , getRandomS
+  , getRandomsS
+  , getRandomRS
+  , getRandomRS_
+  , getRandomsRS
+  , getRandomsRS_
+  ) where
+
+-- External
+import Control.Monad.Random
+
+-- Internal
+import Data.MonadicStreamFunction
+
+-- | Updates the generator every step
+runRandS :: (RandomGen g, Monad m) 
+         => MSF (RandT g m) a b 
+         -> g 
+         -> MSF m a (g, b)
+runRandS msf g = MSF $ \a -> do
+  ((b, msf'), g') <- runRandT (unMSF msf a) g
+  return ((g', b), runRandS msf' g')
+
+-- | Updates the generator every step but discharges the generator 
+evalRandS  :: (RandomGen g, Monad m) => MSF (RandT g m) a b -> g -> MSF m a b
+evalRandS msf g = runRandS msf g >>> arr snd
+
+getRandomS :: (MonadRandom m, Random b) => MSF m a b
+getRandomS = arrM_ getRandom
+
+getRandomsS :: (MonadRandom m, Random b) => MSF m a [b]
+getRandomsS = arrM_ getRandoms 
+
+getRandomRS :: (MonadRandom m, Random b) => (b, b) -> MSF m a b
+getRandomRS range = arrM_ $ getRandomR range
+
+getRandomRS_ :: (MonadRandom m, Random b) => MSF m (b, b) b
+getRandomRS_  = arrM getRandomR
+
+getRandomsRS :: (MonadRandom m, Random b) => (b, b) -> MSF m a [b]
+getRandomsRS range = arrM_ $ getRandomRs range 
+
+getRandomsRS_ :: (MonadRandom m, Random b) => MSF m (b, b) [b]
+getRandomsRS_ = arrM getRandomRs