diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +0.2.0.5 +------- + + +* **Control.Auto.Process.Random**: Added combinators and sealers dealing + for working with an underlying `Rand` or `RandT` monad. +* Because of this, committed to adding `MonadRandom` as a dependency. + 0.2.0.4 ------- diff --git a/auto.cabal b/auto.cabal --- a/auto.cabal +++ b/auto.cabal @@ -1,5 +1,5 @@ name: auto -version: 0.2.0.4 +version: 0.2.0.5 synopsis: Denotative, locally stateful programming DSL & platform description: (Up to date documentation is maintained at ) @@ -34,8 +34,9 @@ repository on github for plenty of real-world and toy examples to learn from! . - Support available on freenode's #haskell, and also on - the github's issue tracker. + Support available on freenode's #haskell-auto, + #haskell-game, and also on the github issue + tracker for the source repository. . Import "Control.Auto" to begin! @@ -84,6 +85,7 @@ , random >= 1.1 && < 2.0 , semigroups >= 0.16.2.2 && < 0.17 , transformers >= 0.4.2.0 && < 0.5 + , MonadRandom >= 0.3.0.1 && < 0.4 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/src/Control/Auto/Collection.hs b/src/Control/Auto/Collection.hs --- a/src/Control/Auto/Collection.hs +++ b/src/Control/Auto/Collection.hs @@ -317,8 +317,10 @@ -- using this can inspire more disciplined usage. Also works as a drop-in -- replacement for 'dynZipF'. dynZipF_ :: Monad m - => (k -> Interval m a b) - -> a + => (k -> Interval m a b) -- ^ function to generate a new + -- 'Interval' for each coming @k@ + -- in the blip stream. + -> a -- ^ "default" input to feed in -> Auto m ([a], Blip [k]) [b] dynZipF_ f x0 = go [] where @@ -433,8 +435,10 @@ -- using this can inspire more disciplined usage. Also works as a drop-in -- replacement for 'dynMapF'. dynMapF_ :: Monad m - => (k -> Interval m a b) - -> a + => (k -> Interval m a b) -- ^ function to generate a new + -- 'Interval' for each coming @k@ + -- in the blip stream. + -> a -- ^ "default" input to feed in -> Auto m (IntMap a, Blip [k]) (IntMap b) dynMapF_ f x0 = go 0 IM.empty IM.empty where diff --git a/src/Control/Auto/Effects.hs b/src/Control/Auto/Effects.hs --- a/src/Control/Auto/Effects.hs +++ b/src/Control/Auto/Effects.hs @@ -242,7 +242,9 @@ -- @foo@ be written using 'State', and being able to use it in a program -- with no global state? -- --- Using 'sealState'! +-- Using 'sealState'! Write the part of your program that would like +-- shared global state with 'State'...and compose it with the rest as if it +-- doesn't, locking it away! -- -- @ -- sealState :: Auto (State s) a b -> s -> Auto' a b @@ -263,13 +265,9 @@ -- stream is the result of running the stream through @f@, first with an -- initial state of @s0@, and afterwards with each next updated state. -- --- This can be extended to sealing 'RandT' from the /MonadRandom/ package --- as well, as long as you 'hoistA' first with @'StateT' . 'runRandT'@. --- --- sealState :: (Monad m, Serialize s) - => Auto (StateT s m) a b - -> s + => Auto (StateT s m) a b -- ^ 'Auto' run over 'State' + -> s -- ^ initial state -> Auto m a b sealState a s0 = mkAutoM (sealState <$> resumeAuto a <*> get) (saveAuto a *> put s0) @@ -279,8 +277,8 @@ -- | The non-resuming/non-serializing version of 'sealState'. sealState_ :: Monad m - => Auto (StateT s m) a b - -> s + => Auto (StateT s m) a b -- ^ 'Auto' run over 'State' + -> s -- ^ initial state -> Auto m a b sealState_ a s0 = mkAutoM (sealState_ <$> resumeAuto a <*> pure s0) (saveAuto a) @@ -288,12 +286,12 @@ ((y, a'), s1) <- runStateT (stepAuto a x) s0 return (y, sealState_ a' s1) --- | Turns an @a -> 'StateT' s m b@ arrow into an @'Auto' m a b@, when --- given an initial state. Will continually "run the function", using the --- state returned from the last run. +-- | Turns an @a -> 'StateT' s m b@ Kleisli arrow into an @'Auto' m a b@, +-- when given an initial state. Will continually "run the function", using +-- the state returned from the last run. fromState :: (Serialize s, Monad m) - => (a -> StateT s m b) - -> s + => (a -> StateT s m b) -- ^ 'State' arrow + -> s -- ^ initial state -> Auto m a b fromState st = mkStateM (runStateT . st) @@ -301,15 +299,15 @@ -- serialized/resumed, so every time the 'Auto' is resumed, it starts over -- with the given initial state. fromState_ :: Monad m - => (a -> StateT s m b) - -> s + => (a -> StateT s m b) -- ^ 'State' arrow + -> s -- ^ initial state -> Auto m a b fromState_ st = mkStateM_ (runStateT . st) -- | "Unrolls" the underlying @'WriterT' w m@ 'Monad', so that an 'Auto' -- that takes in a stream of @a@ and outputs a stream of @b@ will now --- output a stream @(b, w)@, where @w@ is the accumulated log of the --- underlying 'Writer' at every step. +-- output a stream @(b, w)@, where @w@ is the "new log" of the underlying +-- 'Writer' at every step. -- -- @ -- foo :: Auto (Writer (Sum Int)) Int Int @@ -328,7 +326,17 @@ -- a list of outputs and a "final accumulator state" of 10, for stepping it -- ten times. -- --- We can write and compose own 'Auto's under 'Writer', using the +-- However, if we use 'runWriterA' before streaming it, we get: +-- +-- >>> let fooW = runWriterA foo +-- >>> streamAuto' fooW [1..10] +-- [ (1 , Sum 2), (3 , Sum 2), (6 , Sum 2) +-- , (10, Sum 2), (15, Sum 2), (21, Sum 2), -- ... +-- +-- Instead of accumulating it between steps, we get to "catch" the 'Writer' +-- output at every individual step. +-- +-- We can write and compose our own 'Auto's under 'Writer', using the -- convenience of a shared accumulator, and then "use them" with other -- 'Auto's: -- diff --git a/src/Control/Auto/Process/Random.hs b/src/Control/Auto/Process/Random.hs --- a/src/Control/Auto/Process/Random.hs +++ b/src/Control/Auto/Process/Random.hs @@ -8,17 +8,21 @@ -- Portability : portable -- -- This module provides 'Auto's (purely) generating entropy in the form of --- random or noisy processes. Note that every 'Auto' here is completely --- deterministic --- given the same initial seed, one would expect the same --- stream of outputs on every run. Furthermore, if a serializable 'Auto' --- is serialized and resumed, it will continue along the deterministic path +-- random or noisy processes, as well as 'Auto's to purify/seal +-- 'Auto's with underlying entropy. +-- +-- Note that every 'Auto' and combinator here is completely deterministic +-- --- given the same initial seed, one would expect the same stream of +-- outputs on every run. Furthermore, if a serializable 'Auto' is +-- serialized and resumed, it will continue along the deterministic path -- dictated by the /original/ seed given. -- --- All of these 'Auto's come in three flavors: one serializing one that --- works with any serializable 'RandomGen' instance, one serializing one --- that works specifically with 'StdGen' from "System.Random", and one that --- takes any 'RandomGen' (including 'StdGen') and runs it without the --- ability to serialize and resume deterministically. +-- All of these 'Auto's and combinators come in three flavors: one +-- serializing one that works with any serializable 'RandomGen' instance, +-- one serializing one that works specifically with 'StdGen' from +-- "System.Random", and one that takes any 'RandomGen' (including 'StdGen') +-- and runs it without the ability to serialize and resume +-- deterministically. -- -- The reason why there's a specialized 'StdGen' version for all of these -- is that 'StdGen' actually doesn't have a 'Serialize' instance, so a @@ -37,7 +41,7 @@ -- @ -- -- These are useful for generating noise...a new random value at every --- stoep. They are entropy sources. +-- step. They are entropy sources. -- -- Alternatively, if you want to give up parallelizability and determinism -- and have your entire 'Auto' be sequential, you can make your entire @@ -65,24 +69,17 @@ -- you re-load your 'Auto'. Also, 'Auto''s are parallelizable, while -- @'Auto' ('Rand' g)@s are not. -- --- As a compromise, you can then "seal" away the stateful part with --- 'sealState' and 'hoistA': --- --- @ --- sealRandom :: 'Monad' m => 'Auto' ('RandT' g m) a b -> g -> 'Auto' m a b --- sealRandom a0 = 'sealState' . 'hoistA' ('StateT' . 'runRandT') --- --- sealRandom' :: 'Auto' ('Rand' g) a b -> g -> 'Auto'' a b --- sealRandom' = sealRandom --- @ --- --- Where 'hoistA' turns an @'Auto' ('RandT' g m)@ into an @'Auto' m@. +-- As a compromise, you can then "seal" away the underlying monad with +-- 'sealRandom', which takes an @'Auto' ('RandT' g m) a b@, a starting @g@, +-- and turns it into a normal @'Auto' m a b@, with no underlying randomness +-- monad. -- -- In this way, you can run any 'Auto' under 'Rand' or 'RandT' as if it was --- a normal 'Auto' "without" underlying randomness. (These functions --- aren't given here so that this library doesn't incurr a dependency on --- /MonadRandom/). This lets you compose your sequential/non-parallel parts --- in 'Rand' and use it as a part of an 'Auto''. +-- a normal 'Auto' "without" underlying randomness. This lets you compose +-- your sequential/non-parallel parts in 'Rand'...and the later, use it as +-- a part of a parallelizable/potentially non-sequential 'Auto''. It's +-- also convenient because you don't have to manually split and pass around +-- seeds to every 'Auto' that requires entropy. -- -- The other generators given are for useful random processes you might run -- into. The first is a 'Blip' stream that emits at random times with the @@ -116,19 +113,30 @@ , randIntervals , stdRandIntervals , randIntervals_ + -- * Underlying entropy monads + -- ** Sealers + , sealRandom + , sealRandomStd + , sealRandom_ + -- ** Processes + , bernoulliMR + , randIntervalsMR ) where import Control.Applicative import Control.Auto.Blip import Control.Auto.Blip.Internal import Control.Auto.Core +import Control.Auto.Effects import Control.Auto.Interval import Control.Category +import Control.Monad (guard) +import Control.Monad.Random +import Control.Monad.Trans.State (StateT(..)) import Data.Bits import Data.Serialize import Data.Tuple import Prelude hiding (id, (.), concat, concatMap, sum) -import System.Random -- | Given a seed-consuming generating function of form @g -> (b, g)@ -- (where @g@ is the seed, and @b@ is the result) and an initial seed, @@ -173,7 +181,7 @@ -- rands :: (Serialize g, RandomGen g) => (g -> (b, g)) -- ^ random generating function - -> g -- ^ initial generator + -> g -- ^ random generator seed -> Auto m a b rands r = mkState (\_ g -> g `seq` r g) {-# INLINE rands #-} @@ -182,10 +190,10 @@ -- that you can serialize and resume. This is needed because 'StdGen' -- doesn't have a 'Serialize' instance. -- --- See the documentation of 'rands' for more information. +-- See the documentation of 'rands' for more information on this 'Auto'. -- stdRands :: (StdGen -> (b, StdGen)) -- ^ random generating function - -> StdGen -- ^ initial generator + -> StdGen -- ^ random generator seed -> Auto m a b stdRands r = mkState' (read <$> get) (put . show) (\_ g -> r g) {-# INLINE stdRands #-} @@ -194,7 +202,7 @@ -- | The non-serializing/non-resuming version of 'rands'. rands_ :: RandomGen g => (g -> (b, g)) -- ^ random generating function - -> g -- ^ initial generator + -> g -- ^ random generator seed -> Auto m a b rands_ r = mkState_ (\_ g -> r g) {-# INLINE rands_ #-} @@ -214,8 +222,8 @@ -- @ -- randsM :: (Serialize g, RandomGen g, Monad m) - => (g -> m (b, g)) - -> g + => (g -> m (b, g)) -- ^ (monadic) random generating function + -> g -- ^ random generator seed -> Auto m a b randsM r = mkStateM (\_ g -> r g) {-# INLINE randsM #-} @@ -224,19 +232,19 @@ -- that you can serialize and resume. This is needed because 'StdGen' -- doesn't have a 'Serialize' instance. -- --- See the documentation of 'randsM' for more information. +-- See the documentation of 'randsM' for more information on this 'Auto'. -- stdRandsM :: Monad m - => (StdGen -> m (b, StdGen)) - -> StdGen + => (StdGen -> m (b, StdGen)) -- ^ (monadic) random generating function + -> StdGen -- ^ random generator seed -> Auto m a b stdRandsM r = mkStateM' (read <$> get) (put . show) (\_ g -> r g) {-# INLINE stdRandsM #-} -- | The non-serializing/non-resuming version of 'randsM'. randsM_ :: (RandomGen g, Monad m) - => (g -> m (b, g)) - -> g + => (g -> m (b, g)) -- ^ (monadic) random generating function + -> g -- ^ random generator seed -> Auto m a b randsM_ r = mkStateM_ (\_ g -> r g) {-# INLINE randsM_ #-} @@ -263,8 +271,8 @@ -- -- (This is basically 'mkState', specialized.) arrRand :: (Serialize g, RandomGen g) - => (a -> g -> (b, g)) - -> g + => (a -> g -> (b, g)) -- ^ random arrow + -> g -- ^ random generator seed -> Auto m a b arrRand = mkState @@ -280,8 +288,8 @@ -- ('runRandT' .) :: 'RandomGen' g => (a -> 'RandT' g b) -> (a -> g -> m (b, g)) -- @ arrRandM :: (Monad m, Serialize g, RandomGen g) - => (a -> g -> m (b, g)) - -> g + => (a -> g -> m (b, g)) -- ^ (monadic) random arrow + -> g -- ^ random generator seed -> Auto m a b arrRandM = mkStateM @@ -289,10 +297,10 @@ -- that you can serialize and resume. This is needed because 'StdGen' -- doesn't have a 'Serialize' instance. -- --- See the documentation of 'arrRand' for more information. +-- See the documentation of 'arrRand' for more information on this 'Auto'. -- -arrRandStd :: (a -> StdGen -> (b, StdGen)) - -> StdGen +arrRandStd :: (a -> StdGen -> (b, StdGen)) -- ^ random arrow + -> StdGen -- ^ random generator seed -> Auto m a b arrRandStd = mkState' (read <$> get) (put . show) @@ -300,24 +308,24 @@ -- that you can serialize and resume. This is needed because 'StdGen' -- doesn't have a 'Serialize' instance. -- --- See the documentation of 'arrRandM' for more information. +-- See the documentation of 'arrRandM' for more information on this 'Auto'. -- -arrRandStdM :: (a -> StdGen -> m (b, StdGen)) - -> StdGen +arrRandStdM :: (a -> StdGen -> m (b, StdGen)) -- ^ (mondic) random arrow + -> StdGen -- ^ random generator seed -> Auto m a b arrRandStdM = mkStateM' (read <$> get) (put . show) -- | The non-serializing/non-resuming version of 'arrRand'. arrRand_ :: RandomGen g - => (a -> g -> (b, g)) - -> g + => (a -> g -> (b, g)) -- ^ random arrow + -> g -- ^ random generator seed -> Auto m a b arrRand_ = mkState_ -- | The non-serializing/non-resuming version of 'arrRandM'. arrRandM_ :: RandomGen g - => (a -> g -> m (b, g)) - -> g + => (a -> g -> m (b, g)) -- ^ (monadic) random arrow + -> g -- ^ random generator seed -> Auto m a b arrRandM_ = mkStateM_ @@ -335,8 +343,8 @@ -- on average once every @1/p@ ticks. -- bernoulli :: (Serialize g, RandomGen g) - => Double -- ^ probability of success per step - -> g -- ^ initial seed + => Double -- ^ probability of any step emitting + -> g -- ^ random generator seed -> Auto m a (Blip a) bernoulli p = mkState (_bernoulliF p) @@ -344,17 +352,20 @@ -- so that you can serialize and resume. This is needed because 'StdGen' -- doesn't have a 'Serialize' instance. -- --- See the documentation of 'bernoulli' for more information. +-- See the documentation of 'bernoulli' for more information on this +-- 'Auto'. -- stdBernoulli :: Double -- ^ probability of any step emitting - -> StdGen -- ^ initial seed + -> StdGen -- ^ random generator seed + -- (between 0 and 1) -> Auto m a (Blip a) stdBernoulli p = mkState' (read <$> get) (put . show) (_bernoulliF p) -- | The non-serializing/non-resuming version of 'bernoulli'. bernoulli_ :: RandomGen g => Double -- ^ probability of any step emitting - -> g -- ^ initial seed + -> g -- ^ random generator seed + -- (between 0 and 1) -> Auto m a (Blip a) bernoulli_ p = mkState_ (_bernoulliF p) @@ -365,10 +376,29 @@ -> (Blip a, g) _bernoulliF p x g = (outp, g') where - (roll, g') = randomR (0, 1 :: Double) g + (roll, g') = randomR (0, 1) g outp | roll <= p = Blip x | otherwise = NoBlip +-- | 'bernoulli', but uses an underlying entropy source ('MonadRandom') +-- to get its randomness from, instead of an initially passed seed. +-- +-- You can recover exactly @'bernoulli' p@ by using @'sealRandom' +-- ('bernoulliMR' p)@. +-- +-- See 'sealRandom' for more information. +bernoulliMR :: MonadRandom m + => Double -- ^ probability of any step emiting + -- (between 0 and 1) + -> Auto m a (Blip a) +bernoulliMR p = arrM $ \x -> do + roll <- getRandomR (0, 1) + return $ if roll <= p + then Blip x + else NoBlip +-- TODO: rewrite for AMP + + -- | An 'Interval' that is "on" and "off" for contiguous but random -- intervals of time...when "on", allows values to pass as "on" ('Just'), -- but when "off", suppresses all incoming values (outputing 'Nothing'). @@ -386,8 +416,8 @@ -- parameter of @1 / l@. -- randIntervals :: (Serialize g, RandomGen g) - => Double - -> g + => Double -- ^ expected length of on/off intervals + -> g -- ^ random generator seed -> Interval m a a randIntervals l = mkState (_randIntervalsF (1/l)) . swap . random @@ -395,10 +425,11 @@ -- "System.Random", so that you can serialize and resume. This is needed -- because 'StdGen' doesn't have a 'Serialize' instance. -- --- See the documentation of 'randIntervals' for more information. +-- See the documentation of 'randIntervals' for more information on this +-- 'Auto'. -- -stdRandIntervals :: Double - -> StdGen +stdRandIntervals :: Double -- ^ expected length of on/off intervals + -> StdGen -- ^ random generator seed -> Interval m a a stdRandIntervals l = mkState' (read <$> get) (put . show) @@ -407,8 +438,8 @@ -- | The non-serializing/non-resuming version of 'randIntervals'. randIntervals_ :: RandomGen g - => Double - -> g + => Double -- ^ expected length of on/off intervals + -> g -- ^ random generator seed -> Interval m a a randIntervals_ l = mkState_ (_randIntervalsF (1/l)) . swap . random @@ -419,9 +450,75 @@ -> (Maybe a, (g, Bool)) _randIntervalsF thresh x (g, onoff) = (outp, (g', onoff')) where - (roll, g') = randomR (0, 1 :: Double) g + (roll, g') = randomR (0, 1) g onoff' = onoff `xor` (roll <= thresh) - outp | onoff = Just x - | otherwise = Nothing + outp = x <$ guard onoff -- should this be onoff' ? +-- | 'randIntervals', but uses an underlying entropy source ('MonadRandom') +-- to get its randomness from, instead of an initially passed seed. +-- +-- You can recover exactly @'randIntervals' l@ by using @'sealRandom' +-- ('randIntervalsMR' l)@. +-- +-- See 'sealRandom' for more information. +-- +randIntervalsMR :: MonadRandom m + => Double -- ^ expected length of on/off intervals + -> Interval m a a +randIntervalsMR l = flip mkStateM Nothing $ \x monoff -> do + onoff <- case monoff of + Just oo -> return oo + Nothing -> getRandom + roll <- getRandomR (0, 1) + let onoff' = onoff `xor` (roll <= thresh) + return (x <$ guard onoff, Just onoff') + where + thresh = 1/l + +-- | Takes an 'Auto' over an 'Rand' or 'RandT' underlying monad as an +-- entropy source, and "seals it away" to just be a normal 'Auto' or +-- 'Auto'': +-- +-- @ +-- 'sealRandom' :: 'Auto' ('Rand' g) a b -> g -> 'Auto'' a b +-- @ +-- +-- You can now compose your entropic 'Auto' with other 'Auto's (using '.', +-- and other combinators) as if it were a normal 'Auto'. +-- +-- Useful because you can create entire programs that have access to an +-- underlying entropy souce by composing with 'Rand'...and then, at the end +-- of it all, use/compose it with normal 'Auto's as if it were a "pure" +-- 'Auto'. +sealRandom :: (RandomGen g, Serialize g, Monad m) + => Auto (RandT g m) a b -- ^ 'Auto' to seal + -> g -- ^ initial seed + -> Auto m a b +sealRandom a = sealState (hoistA (StateT . runRandT) a) + +-- | The non-serializing/non-resuming version of 'sealRandom_'. The random +-- seed is not re-loaded/resumed, so every time you resume, the stream of +-- available randomness begins afresh. +sealRandom_ :: (RandomGen g, Serialize g, Monad m) + => Auto (RandT g m) a b -- ^ 'Auto' to seal + -> g -- ^ initial seed + -> Auto m a b +sealRandom_ a = sealState_ (hoistA (StateT . runRandT) a) + +-- | Like 'sealRandom', but specialized for 'StdGen' from "System.Random", +-- so that you can serialize and resume. This is needed because 'StdGen' +-- doesn't have a 'Serialize' instance. +-- +-- See the documentation of 'sealRandom' for more information on this +-- combinator. +-- +sealRandomStd :: Monad m + => Auto (RandT StdGen m) a b -- ^ 'Auto' to seal + -> StdGen -- ^ initial seed + -> Auto m a b +sealRandomStd a g0 = mkAutoM (sealRandomStd <$> resumeAuto a <*> (read <$> get)) + (saveAuto a *> put (show g0)) + $ \x -> do + ((y, a'), g1) <- runRandT (stepAuto a x) g0 + return (y, sealRandomStd a' g1)