diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,12 @@ +2.5.0 - 111122 +* added SignalGen liftIO equivalent to assist library writers +* simplified the signatures of effectful* combinators +* updated Param to use the more modern codebase (like Simple and + Clocked); this was necessary to support effectful signals +* temporarily removed the static optimisation from Param +* removed dependency on mersenne-random +* removed legacy branch + 2.4.0 - 111111 * added effectful signals to assist library writers diff --git a/FRP/Elerea/Clocked.hs b/FRP/Elerea/Clocked.hs --- a/FRP/Elerea/Clocked.hs +++ b/FRP/Elerea/Clocked.hs @@ -71,7 +71,6 @@ , start , external , externalMulti - , debug -- * Basic building blocks , delay , generator @@ -85,9 +84,14 @@ , transfer2 , transfer3 , transfer4 - -- * Random sources - , noise - , getRandom + -- * Signals with side effects + -- $effectful + , execute + , effectful + , effectful1 + , effectful2 + , effectful3 + , effectful4 ) where import Control.Applicative @@ -98,7 +102,6 @@ import Data.Maybe import Prelude hiding (until) import System.Mem.Weak -import System.Random.Mersenne -- | A signal represents a value changing over time. It can be -- thought of as a function of type @Nat -> a@, where the argument is @@ -160,7 +163,7 @@ data Phase a = Ready a | Updated a a instance Functor SignalGen where - fmap = (<*>).pure + fmap = liftM instance Applicative SignalGen where pure = return @@ -171,7 +174,7 @@ SG g >>= f = SG $ \p1 p2 -> g p1 p2 >>= \x -> unSG (f x) p1 p2 instance MonadFix SignalGen where - mfix f = SG $ \p1 p2 -> mfix (\x -> unSG (f x) p1 p2) + mfix f = SG $ \p1 p2 -> mfix $ \x -> unSG (f x) p1 p2 getUpdate :: Update -> IO (Maybe (Update, UpdateAction)) getUpdate upd@(USig ptr) = (fmap.fmap) ((,) upd) (deRefWeak ptr) @@ -280,6 +283,10 @@ addSignal return update ref pool +-- | Auxiliary function. +memoise :: IORef (Phase a) -> a -> IO a +memoise ref x = writeIORef ref (Updated undefined x) >> return x + -- | A reactive signal that takes the value to output from a signal -- generator carried by its input with the sampling time provided as -- the start time for the generated structure. It is possible to @@ -314,11 +321,7 @@ generator (S s) = SG $ \gpool pool -> do ref <- newIORef (Ready undefined) - let sample = do - SG g <- s - x <- g gpool pool - writeIORef ref (Updated undefined x) - return x + let sample = (s >>= \(SG g) -> g gpool pool) >>= memoise ref addSignal (const sample) (const (() <$ sample)) ref gpool @@ -344,7 +347,7 @@ memo (S s) = SG $ \_gpool pool -> do ref <- newIORef (Ready undefined) - let sample = s >>= \x -> writeIORef ref (Updated undefined x) >> return x + let sample = s >>= memoise ref addSignal (const sample) (const (() <$ sample)) ref pool @@ -596,28 +599,116 @@ sig' <- delay x0 sig memo (liftM5 f s1 s2 s3 s4 sig') --- | A random signal. It is affected by the associated clock. +{- $effectful + +The following combinators are primarily aimed at library implementors +who wish build abstractions to effectful libraries on top of Elerea. + +-} + +-- | An IO action executed in the 'SignalGen' monad. Can be used as +-- `liftIO`. +execute :: IO a -> SignalGen a +execute act = SG $ \_ _ -> act + +-- | A signal that executes a given IO action once at every sampling. -- +-- In essence, this combinator provides cooperative multitasking +-- capabilities, and its primary purpose is to assist library writers +-- in wrapping effectful APIs as conceptually pure signals. If there +-- are several effectful signals in the system, their order of +-- execution is undefined and should not be relied on. +-- -- Example: -- -- > do --- > smp <- start noise :: IO (IO Double) +-- > smp <- start $ do +-- > ref <- execute $ newIORef 0 +-- > effectful $ do +-- > x <- readIORef ref +-- > putStrLn $ "Count: " ++ show x +-- > writeIORef ref $! x+1 +-- > return () +-- > replicateM_ 5 smp +-- +-- Output: +-- +-- > Count: 0 +-- > Count: 1 +-- > Count: 2 +-- > Count: 3 +-- > Count: 4 +-- +-- Another example (requires mersenne-random): +-- +-- > do +-- > smp <- start $ effectful $ return randomIO :: IO (IO Double) -- > res <- replicateM 5 smp -- > print res -- -- Output: -- -- > [0.12067753390401374,0.8658877349182655,0.7159264443196786,0.1756941896012891,0.9513646060896676] -noise :: MTRandom a => SignalGen (Signal a) -noise = memo (S randomIO) +effectful :: IO a -- ^ the action to be executed repeatedly + -> SignalGen (Signal a) +effectful act = SG $ \_gpool pool -> do + ref <- newIORef (Ready undefined) --- | A random source within the 'SignalGen' monad. -getRandom :: MTRandom a => SignalGen a -getRandom = SG $ \_ _ -> randomIO + let sample = act >>= memoise ref --- | A printing action within the 'SignalGen' monad. -debug :: String -> SignalGen () -debug s = SG $ \_ _ -> putStrLn s + addSignal (const sample) (const (() <$ sample)) ref pool + +-- | A signal that executes a parametric IO action once at every +-- sampling. The parameter is supplied by another signal at every +-- sampling step. +effectful1 :: (t -> IO a) -- ^ the action to be executed repeatedly + -> Signal t -- ^ parameter signal + -> SignalGen (Signal a) +effectful1 act (S s) = SG $ \_gpool pool -> do + ref <- newIORef (Ready undefined) + + let sample = s >>= act >>= memoise ref + + addSignal (const sample) (const (() <$ sample)) ref pool + +-- | Like 'effectful1', but with two parameter signals. +effectful2 :: (t1 -> t2 -> IO a) -- ^ the action to be executed repeatedly + -> Signal t1 -- ^ parameter signal 1 + -> Signal t2 -- ^ parameter signal 2 + -> SignalGen (Signal a) +effectful2 act (S s1) (S s2) = SG $ \_gpool pool -> do + ref <- newIORef (Ready undefined) + + let sample = join (liftM2 act s1 s2) >>= memoise ref + + addSignal (const sample) (const (() <$ sample)) ref pool + +-- | Like 'effectful1', but with three parameter signals. +effectful3 :: (t1 -> t2 -> t3 -> IO a) -- ^ the action to be executed repeatedly + -> Signal t1 -- ^ parameter signal 1 + -> Signal t2 -- ^ parameter signal 2 + -> Signal t3 -- ^ parameter signal 3 + -> SignalGen (Signal a) +effectful3 act (S s1) (S s2) (S s3) = SG $ \_gpool pool -> do + ref <- newIORef (Ready undefined) + + let sample = join (liftM3 act s1 s2 s3) >>= memoise ref + + addSignal (const sample) (const (() <$ sample)) ref pool + +-- | Like 'effectful1', but with four parameter signals. +effectful4 :: (t1 -> t2 -> t3 -> t4 -> IO a) -- ^ the action to be executed repeatedly + -> Signal t1 -- ^ parameter signal 1 + -> Signal t2 -- ^ parameter signal 2 + -> Signal t3 -- ^ parameter signal 3 + -> Signal t4 -- ^ parameter signal 4 + -> SignalGen (Signal a) +effectful4 act (S s1) (S s2) (S s3) (S s4) = SG $ \_gpool pool -> do + ref <- newIORef (Ready undefined) + + let sample = join (liftM4 act s1 s2 s3 s4) >>= memoise ref + + addSignal (const sample) (const (() <$ sample)) ref pool instance Show (Signal a) where showsPrec _ _ s = "" ++ s diff --git a/FRP/Elerea/Legacy.hs b/FRP/Elerea/Legacy.hs deleted file mode 100644 --- a/FRP/Elerea/Legacy.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-| - -Elerea (Eventless Reactivity) is a simplistic FRP implementation that -parts with the concept of events, and introduces various constructs -that can be used to define completely dynamic higher-order dataflow -networks. The user sees the functionality through a hybrid -monadic-applicative interface, where stateful signals can only be -created through a specialised monad, while most combinators are purely -applicative. The combinators build up a network of interconnected -mutable references in the background. The network is executed -iteratively, where each superstep consists of three phases: sampling, -aging, and finalisation. As an example, the following code is a -possible way to define an approximation of our beloved trig functions: - -@ - (sine,cosine) <- mdo - s <- integral 0 c - c <- integral 1 (-s) - return (s,c) -@ - -Note that @integral@ is not a primitive, it can be defined by the user -as a transfer function. A possible implementation that can be used on -any 'Fractional' signal looks like this: - -@ - integral x0 s = transfer x0 (\\dt x x0 -> x0+x*realToFrac dt) s -@ - -Head to "FRP.Elerea.Legacy.Internal" for the implementation details. -To get a general idea how to use the library, check out the sources in -the @elerea-examples@ package. - -The "FRP.Elerea" branch provides a similar interface with a rather -different underlying structure, which is likely to be more efficient. - --} - -module FRP.Elerea.Legacy - ( DTime, Sink, Signal, SignalMonad - , createSignal, superstep - , external - , stateful, transfer, delay - , sampler, generator - , storeJust, toMaybe - , edge - , keepAlive, (.@.) - , (==@), (/=@), (<@), (<=@), (>=@), (>@) - , (&&@), (||@) - , signalDebug -) where - -import Control.Applicative -import FRP.Elerea.Legacy.Internal - -infix 4 ==@, /=@, <@, <=@, >=@, >@ -infixr 3 &&@ -infixr 2 ||@ - -{-| A short alternative name for 'keepAlive'. -} - -(.@.) :: Signal a -> Signal t -> Signal a -(.@.) = keepAlive - -{-| The `edge` transfer function takes a bool signal and emits another -bool signal that turns true only at the moment when there is a rising -edge on the input. -} - -edge :: Signal Bool -> SignalMonad (Signal Bool) -edge b = delay True b >>= \db -> return $ (not <$> db) &&@ b - -{-| The `storeJust` transfer function behaves as a latch on a 'Maybe' -input: it keeps its state when the input is 'Nothing', and replaces it -with the input otherwise. -} - -storeJust :: a -- ^ Initial output - -> Signal (Maybe a) -- ^ Maybe signal to latch on - -> SignalMonad (Signal a) -storeJust x0 s = transfer x0 store s - where store _ Nothing x = x - store _ (Just x) _ = x - -{-| Point-wise equality of two signals. -} - -(==@) :: Eq a => Signal a -> Signal a -> Signal Bool -(==@) = liftA2 (==) - -{-| Point-wise inequality of two signals. -} - -(/=@) :: Eq a => Signal a -> Signal a -> Signal Bool -(/=@) = liftA2 (/=) - -{-| Point-wise comparison of two signals. -} - -(<@) :: Ord a => Signal a -> Signal a -> Signal Bool -(<@) = liftA2 (<) - -{-| Point-wise comparison of two signals. -} - -(<=@) :: Ord a => Signal a -> Signal a -> Signal Bool -(<=@) = liftA2 (<=) - -{-| Point-wise comparison of two signals. -} - -(>=@) :: Ord a => Signal a -> Signal a -> Signal Bool -(>=@) = liftA2 (>=) - -{-| Point-wise comparison of two signals. -} - -(>@) :: Ord a => Signal a -> Signal a -> Signal Bool -(>@) = liftA2 (>) - -{-| Point-wise OR of two boolean signals. -} - -(||@) :: Signal Bool -> Signal Bool -> Signal Bool -(||@) = liftA2 (||) - -{-| Point-wise AND of two boolean signals. -} - -(&&@) :: Signal Bool -> Signal Bool -> Signal Bool -(&&@) = liftA2 (&&) diff --git a/FRP/Elerea/Legacy/Delayed.hs b/FRP/Elerea/Legacy/Delayed.hs deleted file mode 100644 --- a/FRP/Elerea/Legacy/Delayed.hs +++ /dev/null @@ -1,374 +0,0 @@ -{-| - -Note: this module is deprecated, because automatic delays are -ill-defined, and not very useful in practice anyway. Experience with -the library suggests that instantaneous loops are relatively easy to -avoid. - -This version differs from the parametric one in introducing automatic -delays. In practice, if a dependency loop involves a 'transfer' -primitive, it will be resolved during runtime even if transfer -functions are not delayed by default. Also, the until construct and -multi-signal transfer variants are missing from this module. - -The interface of this module differs from the old Elerea in the -following ways: - -* the delta time argument is generalised to an arbitrary type, so it - is possible to do without 'external' altogether in case someone - wants to do so; - -* there is no 'sampler' any more, it is substituted by 'join', as - signals are monads; - -* 'generator' has been conceptually simplified, so it's a more basic - primitive now; - -* all signals are aged regardless of whether they are sampled - (i.e. their behaviour doesn't depend on the context any more); - -* the user needs to cache the results of applicative operations to be - reused in multiple places explicitly using the 'memo' combinator. - --} - -module FRP.Elerea.Legacy.Delayed - ( Signal - , SignalGen - , start - , external - , externalMulti - , delay - , stateful - , transfer - , memo - , generator - , noise - , getRandom - , debug - ) where - -import Control.Applicative -import Control.Concurrent.MVar -import Control.Monad -import Control.Monad.Fix -import Data.IORef -import Data.Maybe -import System.Mem.Weak -import System.Random.Mersenne - --- | A signal can be thought of as a function of type @Nat -> a@, and --- its 'Monad' instance agrees with that intuition. Internally, is --- represented by a sampling computation. -newtype Signal p a = S { unS :: p -> IO a } - --- | A dynamic set of actions to update a network without breaking --- consistency. -type UpdatePool p = [Weak (p -> IO (), IO ())] - --- | A signal generator is the only source of stateful signals. --- Internally, computes a signal structure and adds the new variables --- to an existing update pool. -newtype SignalGen p a = SG { unSG :: IORef (UpdatePool p) -> IO a } - --- | The phases every signal goes through during a superstep: before --- or after sampling. -data Phase s a = Ready s | Sampling s | Aged s a - -instance Functor (Signal p) where - fmap = liftM - -instance Applicative (Signal p) where - pure = return - (<*>) = ap - -instance Monad (Signal p) where - return = S . const . return - S g >>= f = S $ \p -> g p >>= \x -> unS (f x) p - -instance Functor (SignalGen p) where - fmap = liftM - -instance Applicative (SignalGen p) where - pure = return - (<*>) = ap - -instance Monad (SignalGen p) where - return = SG . const . return - SG g >>= f = SG $ \p -> g p >>= \x -> unSG (f x) p - -instance MonadFix (SignalGen p) where - mfix f = SG $ \p -> mfix (($p).unSG.f) - --- | Embedding a signal into an 'IO' environment. Repeated calls to --- the computation returned cause the whole network to be updated, and --- the current sample of the top-level signal is produced as a result. --- The computation accepts a global parameter that will be distributed --- to all signals. For instance, this can be the time step, if we --- want to model continuous-time signals. -start :: SignalGen p (Signal p a) -- ^ the generator of the top-level signal - -> IO (p -> IO a) -- ^ the computation to sample the signal -start (SG gen) = do - pool <- newIORef [] - (S sample) <- gen pool - - ptrs0 <- readIORef pool - writeIORef pool [] - (as0,cs0) <- unzip . map fromJust <$> mapM deRefWeak ptrs0 - let ageStatic param = mapM_ ($param) as0 - commitStatic = sequence_ cs0 - - return $ \param -> do - let update [] ptrs age commit = do - writeIORef pool ptrs - ageStatic param >> age - commitStatic >> commit - update (p:ps) ptrs age commit = do - r <- deRefWeak p - case r of - Nothing -> update ps ptrs age commit - Just (a,c) -> update ps (p:ptrs) (age >> a param) (commit >> c) - - res <- sample param - ptrs <- readIORef pool - update ptrs [] (return ()) (return ()) - return res - --- | Auxiliary function used by all the primitives that create a --- mutable variable. -addSignal :: (p -> Phase s a -> IO a) -- ^ sampling function - -> (p -> Phase s a -> IO ()) -- ^ aging function - -> IORef (Phase s a) -- ^ the mutable variable behind the signal - -> IORef (UpdatePool p) -- ^ the pool of update actions - -> IO (Signal p a) -addSignal sample age ref pool = do - let commit (Aged s _) = Ready s - commit _ = error "commit error: signal not aged" - - sig = S $ \p -> readIORef ref >>= sample p - - update <- mkWeak sig (\p -> readIORef ref >>= age p, modifyIORef ref commit) Nothing - modifyIORef pool (update:) - return sig - --- | The 'delay' transfer function emits the value of a signal from --- the previous superstep, starting with the filler value given in the --- first argument. -delay :: a -- ^ initial output - -> Signal p a -- ^ the signal to delay - -> SignalGen p (Signal p a) -delay x0 (S s) = SG $ \pool -> do - ref <- newIORef (Ready x0) - - let sample _ (Ready x) = return x - sample _ (Aged _ x) = return x - sample _ _ = error "sampling eror: delay" - - age p (Ready x) = s p >>= \x' -> x' `seq` writeIORef ref (Aged x' x) - age _ _ = return () - - addSignal sample age ref pool - --- | Memoising combinator. It can be used to cache results of --- applicative combinators in case they are used in several places. --- Other than that, it is equivalent to 'return'. -memo :: Signal p a -- ^ signal to memoise - -> SignalGen p (Signal p a) -memo (S s) = SG $ \pool -> do - ref <- newIORef (Ready undefined) - - let sample p (Ready _) = s p >>= \x -> writeIORef ref (Aged undefined x) >> return x - sample _ (Aged _ x) = return x - sample _ _ = error "sampling eror: memo" - - age p (Ready _) = s p >>= \x -> writeIORef ref (Aged undefined x) - age _ _ = return () - - addSignal sample age ref pool - --- | A reactive signal that takes the value to output from a monad --- carried by its input. It is possible to create new signals in the --- monad. -generator :: Signal p (SignalGen p a) -- ^ a stream of generators to potentially run - -> SignalGen p (Signal p a) -generator (S gen) = SG $ \pool -> do - ref <- newIORef (Ready undefined) - - let next p = ($pool).unSG =<< gen p - - sample p (Ready _) = next p >>= \x' -> writeIORef ref (Aged x' x') >> return x' - sample _ (Aged _ x) = return x - sample _ _ = error "sampling eror: generator" - - age p (Ready _) = next p >>= \x' -> writeIORef ref (Aged x' x') - age _ _ = return () - - addSignal sample age ref pool - --- | A signal that can be directly fed through the sink function --- returned. This can be used to attach the network to the outer --- world. Note that this is optional, as all the input of the network --- can be fed in through the global parameter, although that is not --- really convenient for many signals. -external :: a -- ^ initial value - -> IO (Signal p a, a -> IO ()) -- ^ the signal and an IO function to feed it -external x = do - ref <- newIORef x - return (S (const (readIORef ref)), writeIORef ref) - --- | An event-like signal that can be fed through the sink function --- returned. The signal carries a list of values fed in since the --- last sampling, i.e. it is constantly [] if the sink is never --- invoked. The order of elements is reversed, so the last value --- passed to the sink is the head of the list. Note that unlike --- 'external' this function only returns a generator to be used within --- the expression constructing the top-level stream, and this --- generator can only be used once. -externalMulti :: IO (SignalGen p (Signal p [a]), a -> IO ()) -- ^ a generator for the event signal and the associated sink -externalMulti = do - var <- newMVar [] - return (SG $ \pool -> do - let sig = S $ const (readMVar var) - update <- mkWeak sig (const (return ()),takeMVar var >> putMVar var []) Nothing - modifyIORef pool (update:) - return sig - ,\val -> do vals <- takeMVar var - putMVar var (val:vals) - ) - --- | A pure stateful signal. The initial state is the first output, --- and every following output is calculated from the previous one and --- the value of the global parameter. -stateful :: a -> (p -> a -> a) -> SignalGen p (Signal p a) -stateful x0 f = SG $ \pool -> do - ref <- newIORef (Ready x0) - - let sample _ (Ready x) = return x - sample _ (Aged _ x) = return x - sample _ _ = error "sampling eror: stateful" - - age p (Ready x) = let x' = f p x in x' `seq` writeIORef ref (Aged x' x) - age _ _ = return () - - addSignal sample age ref pool - --- | A stateful transfer function. The current input affects the --- current output, i.e. the initial state given in the first argument --- is considered to appear before the first output, and can never be --- observed. Every output is derived from the current value of the --- input signal, the global parameter and the previous output. The --- only exception is when a transfer function sits in a loop without a --- delay. In this case, a delay will be inserted at a single place --- during runtime (i.e. the previous output of the node affected will --- be reused) to resolve the circular dependency. -transfer :: a -> (p -> t -> a -> a) -> Signal p t -> SignalGen p (Signal p a) -transfer x0 f (S s) = SG $ \pool -> do - ref <- newIORef (Ready x0) - - let sample p (Ready x) = do - writeIORef ref (Sampling x) - y <- s p - let x' = f p y x - x' `seq` writeIORef ref (Aged x' x') - return x' - sample _ (Sampling x) = return x -- Reusing previous output: automatic delay - sample _ (Aged _ x) = return x - - age p (Ready x) = do - y <- s p - let x' = f p y x - x' `seq` writeIORef ref (Aged x' x') - age _ _ = return () -- If it is Sampling, we'll error out later - - addSignal sample age ref pool - --- | A random signal. -noise :: MTRandom a => SignalGen p (Signal p a) -noise = memo (S (const randomIO)) - --- | A random source within the 'SignalGen' monad. -getRandom :: MTRandom a => SignalGen p a -getRandom = SG (const randomIO) - --- | A printing action within the 'SignalGen' monad. -debug :: String -> SignalGen p () -debug = SG . const . putStrLn - --- | The @Show@ instance is only defined for the sake of 'Num'... -instance Show (Signal p a) where - showsPrec _ _ s = "" ++ s - --- | Equality test is impossible. -instance Eq (Signal p a) where - _ == _ = False - --- | Error message for unimplemented instance functions. -unimp :: String -> a -unimp = error . ("Signal: "++) - -instance Ord t => Ord (Signal p t) where - compare = unimp "compare" - min = liftA2 min - max = liftA2 max - -instance Enum t => Enum (Signal p t) where - succ = fmap succ - pred = fmap pred - toEnum = pure . toEnum - fromEnum = unimp "fromEnum" - enumFrom = unimp "enumFrom" - enumFromThen = unimp "enumFromThen" - enumFromTo = unimp "enumFromTo" - enumFromThenTo = unimp "enumFromThenTo" - -instance Bounded t => Bounded (Signal p t) where - minBound = pure minBound - maxBound = pure maxBound - -instance Num t => Num (Signal p t) where - (+) = liftA2 (+) - (-) = liftA2 (-) - (*) = liftA2 (*) - signum = fmap signum - abs = fmap abs - negate = fmap negate - fromInteger = pure . fromInteger - -instance Real t => Real (Signal p t) where - toRational = unimp "toRational" - -instance Integral t => Integral (Signal p t) where - quot = liftA2 quot - rem = liftA2 rem - div = liftA2 div - mod = liftA2 mod - quotRem a b = (fst <$> qrab,snd <$> qrab) - where qrab = quotRem <$> a <*> b - divMod a b = (fst <$> dmab,snd <$> dmab) - where dmab = divMod <$> a <*> b - toInteger = unimp "toInteger" - -instance Fractional t => Fractional (Signal p t) where - (/) = liftA2 (/) - recip = fmap recip - fromRational = pure . fromRational - -instance Floating t => Floating (Signal p t) where - pi = pure pi - exp = fmap exp - sqrt = fmap sqrt - log = fmap log - (**) = liftA2 (**) - logBase = liftA2 logBase - sin = fmap sin - tan = fmap tan - cos = fmap cos - asin = fmap asin - atan = fmap atan - acos = fmap acos - sinh = fmap sinh - tanh = fmap tanh - cosh = fmap cosh - asinh = fmap asinh - atanh = fmap atanh - acosh = fmap acosh diff --git a/FRP/Elerea/Legacy/Graph.hs b/FRP/Elerea/Legacy/Graph.hs deleted file mode 100644 --- a/FRP/Elerea/Legacy/Graph.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} - -{-| - -This module provides some means to visualise the signal structure. - --} - -module FRP.Elerea.Legacy.Graph (signalToDot) where - -import Data.IORef -import qualified Data.Map as Map -import Foreign.Ptr -import Foreign.StablePtr -import FRP.Elerea.Legacy.Internal - -type Id = Int - -type SignalStore = Map.Map Id SignalInfo - -data SignalInfo - = Const - | Stateful - | Transfer Id - | App Id Id - | Sampler Id - | Generator Id Id - | External - | Delay Id - | Lift1 Id - | Lift2 Id Id - | Lift3 Id Id Id - | Lift4 Id Id Id Id - | Lift5 Id Id Id Id Id - | None - -getPtr :: a -> IO Id -getPtr x = fmap (fromIntegral . ptrToIntPtr . castStablePtrToPtr) (newStablePtr x) - -buildStore :: SignalStore -> Signal a -> IO (Id,SignalStore) -buildStore st (S r) = do - p <- getPtr r - case Map.lookup p st of - Just _ -> return (p,st) - Nothing -> do Ready s <- readIORef r - st' <- insertSignal st p s - return (p,st') - -insertSignal :: SignalStore -> Id -> SignalNode a -> IO SignalStore -insertSignal st p (SNK _) = return (Map.insert p Const st) -insertSignal st p (SNS _ _) = return (Map.insert p Stateful st) -insertSignal st p (SNT s _ _) = do - (s',st') <- buildStore (Map.insert p None st) s - return (Map.insert p (Transfer s') st') -insertSignal st p (SNA sf sx) = do - (sf',st') <- buildStore (Map.insert p None st) sf - (sx',st'') <- buildStore st' sx - return (Map.insert p (App sf' sx') st'') -insertSignal st p (SNH ss _) = do - (ss',st') <- buildStore (Map.insert p None st) ss - return (Map.insert p (Sampler ss') st') -insertSignal st p (SNM b sm) = do - (b',st') <- buildStore (Map.insert p None st) b - (sm',st'') <- buildStore st' sm - return (Map.insert p (Generator b' sm') st'') -insertSignal st p (SNE _) = return (Map.insert p External st) -insertSignal st p (SND _ s) = do - (s',st') <- buildStore (Map.insert p None st) s - return (Map.insert p (Delay s') st') -insertSignal st p (SNKA (S r) _) = do - Ready s <- readIORef r - insertSignal st p s -insertSignal st p (SNF1 _ s1) = do - (s1',st') <- buildStore (Map.insert p None st) s1 - return (Map.insert p (Lift1 s1') st') -insertSignal st p (SNF2 _ s1 s2) = do - (s1',st') <- buildStore (Map.insert p None st) s1 - (s2',st'') <- buildStore st' s2 - return (Map.insert p (Lift2 s1' s2') st'') -insertSignal st p (SNF3 _ s1 s2 s3) = do - (s1',st') <- buildStore (Map.insert p None st) s1 - (s2',st'') <- buildStore st' s2 - (s3',st''') <- buildStore st'' s3 - return (Map.insert p (Lift3 s1' s2' s3') st''') -insertSignal st p (SNF4 _ s1 s2 s3 s4) = do - (s1',st') <- buildStore (Map.insert p None st) s1 - (s2',st'') <- buildStore st' s2 - (s3',st''') <- buildStore st'' s3 - (s4',st'''') <- buildStore st''' s4 - return (Map.insert p (Lift4 s1' s2' s3' s4') st'''') -insertSignal st p (SNF5 _ s1 s2 s3 s4 s5) = do - (s1',st') <- buildStore (Map.insert p None st) s1 - (s2',st'') <- buildStore st' s2 - (s3',st''') <- buildStore st'' s3 - (s4',st'''') <- buildStore st''' s4 - (s5',st''''') <- buildStore st'''' s5 - return (Map.insert p (Lift5 s1' s2' s3' s4' s5') st''''') - -nodeLabel :: Maybe Id -> SignalInfo -> [Char] -nodeLabel id node = case node of - Const -> "const" - Stateful -> "stateful" - Transfer _ -> "transfer" - App _ _ -> "app" - Sampler _ -> "sampler" - Generator _ _ -> "generator" - External -> "external" - Delay _ -> "delay" - Lift1 _ -> "fun1" - Lift2 _ _ -> "fun2" - Lift3 _ _ _ -> "fun3" - Lift4 _ _ _ _ -> "fun4" - Lift5 _ _ _ _ _ -> "fun5" - None -> "NONE" - ++ (maybe "" show id) - -{-| - -Traversing the network starting from the given signal and converting -it into a string containing the graph in Graphviz -() dot format. Stateful nodes are coloured -according to their type. - -The results might differ depending on whether this function is called -before or after sampling (this also affects the actual network!), but -the networks should be still equivalent. - --} - -signalToDot :: Signal a -> IO String -signalToDot s = do - (_,st) <- buildStore Map.empty s - let rules = map mkRule (Map.assocs st) - mkRule (id,n) = " " ++ name ++ attrs ++ edges - where name = nodeLabel (Just id) n - attrs = mkLabel (nodeLabel Nothing n) ("style=filled,fillcolor=\"#" ++ nodeCol ++ "\",shape=" ++ nodeShape) - edges = case n of - Transfer s -> mkEdge s "\"\"" - App sf sx -> mkEdge sf "f" ++ mkEdge sx "x" - Sampler ss -> mkEdge ss "\"\"" - Generator b sm -> mkEdge b "ctl" ++ mkEdge sm "gen" - Delay s -> mkEdge s "\"\"" - Lift1 s1 -> mkEdge s1 "x1" - Lift2 s1 s2 -> mkEdge s1 "x1" ++ mkEdge s2 "x2" - Lift3 s1 s2 s3 -> mkEdge s1 "x1" ++ mkEdge s2 "x2" ++ mkEdge s3 "x3" - Lift4 s1 s2 s3 s4 -> mkEdge s1 "x1" ++ mkEdge s2 "x2" ++ mkEdge s3 "x3" ++ mkEdge s4 "x4" - Lift5 s1 s2 s3 s4 s5 -> mkEdge s1 "x1" ++ mkEdge s2 "x2" ++ mkEdge s3 "x3" ++ mkEdge s4 "x4" ++ mkEdge s5 "x5" - _ -> "" - mkEdge endId label = " " ++ name ++ " -> " ++ - nodeLabel (Just endId) (st Map.! endId) ++ - mkLabel label "dir=back" - mkLabel name attrs = " [label=" ++ name ++ "," ++ attrs ++ "];\n" - nodeCol = case n of - Transfer _ -> "ffcc99" - Sampler _ -> "99ccff" - Generator _ _ -> "ccffff" - External -> "ccff99" - Stateful -> "ffffcc" - Delay _ -> "ffccff" - _ -> "ffffff" - nodeShape = case n of - Transfer _ -> "diamond" - Sampler _ -> "hexagon" - Generator _ _ -> "house" - External -> "invtriangle" - Delay _ -> "box" - _ -> "ellipse" - return $ "digraph G {\n" ++ concat rules ++ "}\n" diff --git a/FRP/Elerea/Legacy/Internal.hs b/FRP/Elerea/Legacy/Internal.hs deleted file mode 100644 --- a/FRP/Elerea/Legacy/Internal.hs +++ /dev/null @@ -1,546 +0,0 @@ -{-# LANGUAGE ExistentialQuantification, GeneralizedNewtypeDeriving #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} - -{-| - -This is the core module of Elerea, which contains the signal -implementation and the atomic constructors. - -The basic idea is to create a dataflow network whose structure closely -resembles the user's definitions by turning each combinator into a -mutable variable (an 'IORef'). In other words, each signal is -represented by a variable. Such a variable contains information about -the operation to perform and (depending on the operation) references -to other signals. For instance, a pointwise function application -created by the '<*>' operator contains an 'SNA' node, which holds two -references: one to the function signal and another to the argument -signal. - -In order to have a pure(-looking) applicative interface for the most -part, the library relies on 'unsafePerformIO' to create the references -of stateless signals, while stateful signals have to be obtained from -a special 'SignalMonad', which is just a wrapping of 'IO' that doesn't -allow any other action to be performed. - -The execution of the network is explicitly marked as an IO operation. -The core library exposes a single function to animate the network -called 'superstep', which takes a signal and a time interval, and -mutates all the variables the signal depends on. It is supposed to be -called repeatedly in a loop that also takes care of user input. - -To ensure consistency, a superstep has three phases: sampling, aging -and finalisation. Each signal reachable from the top-level signal -passed to 'superstep' is sampled at the current point of time -('sample'), and the sample is stored along with the old signal in its -reference. If the value of a signal is requested multiple times, the -sample is simply reused. After successfully sampling the top-level -signal, the network is traversed again to advance by the desired time -('advance'), and when that's completed, the finalisation process -throws away the intermediate samples and marks the aged signals as the -current ones, ready to be sampled again. If there is a dependency -loop, the system tries to use the 'sampleDelayed' function instead of -'sample' to get a useful value at the problematic spot instead of -entering an infinite loop. Evaluation is initiated by the -'signalValue' function (which is used in both the sampling and the -aging phase to calculate samples and retrieve the cached values if -they are requested again), aging is performed by 'age', while -finalisation is done by 'commit'. Since these functions are invoked -recursively on a data structure with existential types, their types -also need to be explicity quantified. - -As a bonus, applicative nodes are automatically collapsed into lifted -functions of up to five arguments. This optimisation significantly -reduces the number of nodes in the network. - --} - -module FRP.Elerea.Legacy.Internal where - -import Control.Applicative -import Control.Monad -import Control.Monad.Fix -import Data.IORef -import System.IO.Unsafe - --- * Implementation - --- ** Some type synonyms - -{-| Time is continuous. Nothing fancy. -} - -type DTime = Double - -{-| Sinks are used when feeding input into peripheral-bound signals. -} - -type Sink a = a -> IO () - --- ** The data structures behind signals - -{-| A restricted monad to create stateful signals in. -} - -newtype SignalMonad a = SM { createSignal :: IO a } deriving (Monad,Applicative,Functor,MonadFix) - -{-| A printing function that can be used in the 'SignalMonad'. -Provided for debugging purposes. -} - -signalDebug :: Show a => a -> SignalMonad () -signalDebug = SM . print - -{-| A signal is conceptually a time-varying value. -} - -newtype Signal a = S (IORef (SignalTrans a)) - -{-| A node can have four states that distinguish various stages of -sampling and aging. -} - -data SignalTrans a - -- | @Ready s@ is simply the signal @s@ that was not sampled yet - = Ready (SignalNode a) - -- | @Sampling s@ is signal @s@ after its current value was - -- requested, but not yet delivered - | Sampling (SignalNode a) - -- | @Sampled x s@ is signal @s@ paired with its current value @x@ - | Sampled a (SignalNode a) - -- | @Aged x s@ is the aged version of signal @s@ paired with its - -- current value @x@ - | Aged a (SignalNode a) - -{-| The possible structures of a node are defined by the 'SignalNode' -type. Note that the @SNFx@ nodes are only needed to optimise -applicatives, they can all be expressed in terms of @SNK@ and -@SNA@. -} - -data SignalNode a - -- | @SNK x@: constantly @x@ - = SNK a - -- | @SNS x t@: stateful generator, where @x@ is current state and - -- @t@ is the update function - | SNS a (DTime -> a -> a) - -- | @SNT s x t@: stateful transfer function, which also depends - -- on an input signal @s@ - | forall t . SNT (Signal t) a (DTime -> t -> a -> a) - -- | @SNA sf sx@: pointwise function application - | forall t . SNA (Signal (t -> a)) (Signal t) - -- | @SNH ss r@: the higher-order signal @ss@ collapsed into a - -- signal cached in reference @r@; @r@ is used during the aging - -- phase - | SNH (Signal (Signal a)) (IORef (Signal a)) - -- | @SNM b sm@: signal generator that executes the monad carried - -- by @sm@ whenever @b@ is true, and outputs the result (or - -- undefined when @b@ is false) - | SNM (Signal Bool) (Signal (SignalMonad a)) - -- | @SNE r@: opaque reference to connect peripherals - | SNE (IORef a) - -- | @SND s@: the @s@ signal delayed by one superstep - | SND a (Signal a) - -- | @SNKA s l@: equivalent to @s@ while aging signal @l@ - | forall t . SNKA (Signal a) (Signal t) - -- | @SNF1 f@: @fmap f@ - | forall t . SNF1 (t -> a) (Signal t) - -- | @SNF2 f@: @liftA2 f@ - | forall t1 t2 . SNF2 (t1 -> t2 -> a) (Signal t1) (Signal t2) - -- | @SNF3 f@: @liftA3 f@ - | forall t1 t2 t3 . SNF3 (t1 -> t2 -> t3 -> a) (Signal t1) (Signal t2) (Signal t3) - -- | @SNF4 f@: @liftA4 f@ - | forall t1 t2 t3 t4 . SNF4 (t1 -> t2 -> t3 -> t4 -> a) (Signal t1) (Signal t2) (Signal t3) (Signal t4) - -- | @SNF5 f@: @liftA5 f@ - | forall t1 t2 t3 t4 t5 . SNF5 (t1 -> t2 -> t3 -> t4 -> t5 -> a) (Signal t1) (Signal t2) (Signal t3) (Signal t4) (Signal t5) - -{-| You can uncomment the verbose version of this function to see the -applicative optimisations in action. -} - -debugLog :: String -> IO a -> IO a ---debugLog s io = putStrLn s >> io -debugLog _ io = io - -instance Functor Signal where - fmap = (<*>) . pure - -{-| The 'Applicative' instance with run-time optimisation. The '<*>' -operator tries to move all the pure parts to its left side in order to -flatten the structure, hence cutting down on book-keeping costs. Since -applicatives are used with pure functions and lifted values most of -the time, one can gain a lot by merging these nodes. -} - -instance Applicative Signal where - -- | A constant signal - pure = makeSignalUnsafe . SNK - -- | Point-wise application of a function and a data signal (like @ZipList@) - --- --mf <*> mx = sampler (fmap (\f -> sampler (fmap (pure . f) mx)) mf) --- sf <*> sx = sampler (makeSignalUnsafe (SNF1 (\f -> sampler (makeSignalUnsafe (SNF1 (pure . f) sx))) sf)) - - f@(S rf) <*> x@(S rx) = unsafePerformIO $ do - -- General fall-back case - c <- newIORef (Ready (SNA f x)) - - let opt s = writeIORef c (Ready s) - - -- Optimisations might go haywire in the presence of loops, - -- so we need to prepare to meeting undefined references by - -- wrapping reads into exception handlers. - - flip catch (const (debugLog "no_fun" $ return ())) $ do - Ready nf <- readIORef rf - - merged <- flip catch (const (debugLog "no_arg" $ return False)) $ do - -- Merging constant branches from the two sides - Ready nx <- readIORef rx - case (nf,nx) of - (SNK g,SNK y) -> debugLog "merge_00" $ opt (SNK (g y)) - (SNK g,SNF1 h y1) -> debugLog "merge_01" $ opt (SNF1 (g.h) y1) - (SNK g,SNF2 h y1 y2) -> debugLog "merge_02" $ opt (SNF2 (\y1 y2 -> g (h y1 y2)) y1 y2) - (SNK g,SNF3 h y1 y2 y3) -> debugLog "merge_03" $ opt (SNF3 (\y1 y2 y3 -> g (h y1 y2 y3)) y1 y2 y3) - (SNK g,SNF4 h y1 y2 y3 y4) -> debugLog "merge_04" $ opt (SNF4 (\y1 y2 y3 y4 -> g (h y1 y2 y3 y4)) y1 y2 y3 y4) - (SNK g,SNF5 h y1 y2 y3 y4 y5) -> debugLog "merge_05" $ opt (SNF5 (\y1 y2 y3 y4 y5 -> g (h y1 y2 y3 y4 y5)) y1 y2 y3 y4 y5) - (SNK g,_) -> debugLog "lift_1x" $ opt (SNF1 g x) - (SNF1 g x1,SNK y) -> debugLog "merge_10" $ opt (SNF1 (\x1 -> g x1 y) x1) - (SNF1 g x1,SNF1 h y1) -> debugLog "merge_11" $ opt (SNF2 (\x1 y1 -> g x1 (h y1)) x1 y1) - (SNF1 g x1,SNF2 h y1 y2) -> debugLog "merge_12" $ opt (SNF3 (\x1 y1 y2 -> g x1 (h y1 y2)) x1 y1 y2) - (SNF1 g x1,SNF3 h y1 y2 y3) -> debugLog "merge_13" $ opt (SNF4 (\x1 y1 y2 y3 -> g x1 (h y1 y2 y3)) x1 y1 y2 y3) - (SNF1 g x1,SNF4 h y1 y2 y3 y4) -> debugLog "merge_14" $ opt (SNF5 (\x1 y1 y2 y3 y4 -> g x1 (h y1 y2 y3 y4)) x1 y1 y2 y3 y4) - (SNF1 g x1,_) -> debugLog "lift_2x" $ opt (SNF2 g x1 x) - (SNF2 g x1 x2,SNK y) -> debugLog "merge_20" $ opt (SNF2 (\x1 x2 -> g x1 x2 y) x1 x2) - (SNF2 g x1 x2,SNF1 h y1) -> debugLog "merge_21" $ opt (SNF3 (\x1 x2 y1 -> g x1 x2 (h y1)) x1 x2 y1) - (SNF2 g x1 x2,SNF2 h y1 y2) -> debugLog "merge_22" $ opt (SNF4 (\x1 x2 y1 y2 -> g x1 x2 (h y1 y2)) x1 x2 y1 y2) - (SNF2 g x1 x2,SNF3 h y1 y2 y3) -> debugLog "merge_23" $ opt (SNF5 (\x1 x2 y1 y2 y3 -> g x1 x2 (h y1 y2 y3)) x1 x2 y1 y2 y3) - (SNF2 g x1 x2,_) -> debugLog "lift_3x" $ opt (SNF3 g x1 x2 x) - (SNF3 g x1 x2 x3,SNK y) -> debugLog "merge_30" $ opt (SNF3 (\x1 x2 x3 -> g x1 x2 x3 y) x1 x2 x3) - (SNF3 g x1 x2 x3,SNF1 h y1) -> debugLog "merge_31" $ opt (SNF4 (\x1 x2 x3 y1 -> g x1 x2 x3 (h y1)) x1 x2 x3 y1) - (SNF3 g x1 x2 x3,SNF2 h y1 y2) -> debugLog "merge_32" $ opt (SNF5 (\x1 x2 x3 y1 y2 -> g x1 x2 x3 (h y1 y2)) x1 x2 x3 y1 y2) - (SNF3 g x1 x2 x3,_) -> debugLog "lift_4x" $ opt (SNF4 g x1 x2 x3 x) - (SNF4 g x1 x2 x3 x4,SNK y) -> debugLog "merge_40" $ opt (SNF4 (\x1 x2 x3 x4 -> g x1 x2 x3 x4 y) x1 x2 x3 x4) - (SNF4 g x1 x2 x3 x4,SNF1 h y1) -> debugLog "merge_41" $ opt (SNF5 (\x1 x2 x3 x4 y1 -> g x1 x2 x3 x4 (h y1)) x1 x2 x3 x4 y1) - (SNF4 g x1 x2 x3 x4,_) -> debugLog "lift_5x" $ opt (SNF5 g x1 x2 x3 x4 x) - (SNF5 g x1 x2 x3 x4 x5,SNK y) -> debugLog "merge_50" $ opt (SNF5 (\x1 x2 x3 x4 x5 -> g x1 x2 x3 x4 x5 y) x1 x2 x3 x4 x5) - _ -> return () - return True - - -- Lifting into higher arity not knowing the argument - when (not merged) $ case nf of - SNK g -> debugLog "lift_1" $ opt (SNF1 g x) - SNF1 g x1 -> debugLog "lift_2" $ opt (SNF2 g x1 x) - SNF2 g x1 x2 -> debugLog "lift_3" $ opt (SNF3 g x1 x2 x) - SNF3 g x1 x2 x3 -> debugLog "lift_4" $ opt (SNF4 g x1 x2 x3 x) - SNF4 g x1 x2 x3 x4 -> debugLog "lift_5" $ opt (SNF5 g x1 x2 x3 x4 x) - _ -> return () - - -- The final version - return (S c) - -{-| The @Show@ instance is only defined for the sake of 'Num'... -} - -instance Show (Signal a) where - showsPrec _ _ s = "" ++ s - -{-| The equality test checks whether two signals are physically the same. -} - -instance Eq (Signal a) where - S s1 == S s2 = s1 == s2 - -{-| Error message for unimplemented instance functions. -} - -unimp :: String -> a -unimp = error . ("Signal: "++) - -instance Ord t => Ord (Signal t) where - compare = unimp "compare" - min = liftA2 min - max = liftA2 max - -instance Enum t => Enum (Signal t) where - succ = fmap succ - pred = fmap pred - toEnum = pure . toEnum - fromEnum = unimp "fromEnum" - enumFrom = unimp "enumFrom" - enumFromThen = unimp "enumFromThen" - enumFromTo = unimp "enumFromTo" - enumFromThenTo = unimp "enumFromThenTo" - -instance Bounded t => Bounded (Signal t) where - minBound = pure minBound - maxBound = pure maxBound - -instance Num t => Num (Signal t) where - (+) = liftA2 (+) - (-) = liftA2 (-) - (*) = liftA2 (*) - signum = fmap signum - abs = fmap abs - negate = fmap negate - fromInteger = pure . fromInteger - -instance Real t => Real (Signal t) where - toRational = unimp "toRational" - -instance Integral t => Integral (Signal t) where - quot = liftA2 quot - rem = liftA2 rem - div = liftA2 div - mod = liftA2 mod - quotRem a b = (fst <$> qrab,snd <$> qrab) - where qrab = quotRem <$> a <*> b - divMod a b = (fst <$> dmab,snd <$> dmab) - where dmab = divMod <$> a <*> b - toInteger = unimp "toInteger" - -instance Fractional t => Fractional (Signal t) where - (/) = liftA2 (/) - recip = fmap recip - fromRational = pure . fromRational - -instance Floating t => Floating (Signal t) where - pi = pure pi - exp = fmap exp - sqrt = fmap sqrt - log = fmap log - (**) = liftA2 (**) - logBase = liftA2 logBase - sin = fmap sin - tan = fmap tan - cos = fmap cos - asin = fmap asin - atan = fmap atan - acos = fmap acos - sinh = fmap sinh - tanh = fmap tanh - cosh = fmap cosh - asinh = fmap asinh - atanh = fmap atanh - acosh = fmap acosh - --- ** Internal functions to run the network - -{-| Creating a reference within the 'SignalMonad'. Used for stateful -signals. -} - -makeSignal :: SignalNode a -> SignalMonad (Signal a) -makeSignal node = SM $ do - ref <- newIORef (Ready node) - return (S ref) - -{-| Creating a reference as a pure value. Used for stateless -signals. -} - -makeSignalUnsafe :: SignalNode a -> Signal a -makeSignalUnsafe = S . unsafePerformIO . newIORef . Ready - -{-| Sampling the signal and all of its dependencies, at the same time. -We don't need the aged signal in the current superstep, only the -current value, so we sample before propagating the changes, which -might require the fresh sample because of recursive definitions. -} - -signalValue :: forall a . Signal a -> DTime -> IO a -signalValue (S r) dt = do - t <- readIORef r - case t of - Ready s -> do writeIORef r (Sampling s) - -- TODO: advance can be evaluated in a separate - -- thread, since we don't need its result right - -- away, only in the next superstep. - v <- sample s dt - -- We memorise the sample to handle loops - -- nicely. The undefined future signal cannot - -- bite us, because we don't need it during the - -- evaluation phase. - writeIORef r (Sampled v s) - return v - Sampling s -> do -- We started sampling this already, so there is - -- a dependency cycle we have to resolve by - -- adding a delay to stateful signals. Stateless - -- signals should not form a loop, which is - -- obvious... - v <- sampleDelayed s dt - writeIORef r (Sampled v s) - -- Since we are sampling it already, this node - -- will be overwritten by the case above when - -- the loop is closed. - return v - Sampled v _ -> return v - Aged v _ -> return v - -{-| Aging the network of signals the given signal depends on. -} - -age :: forall a . Signal a -> DTime -> IO () -age (S r) dt = do - t <- readIORef r - case t of - Sampled v s -> do s' <- advance s v dt - writeIORef r (Aged v s') - -- TODO: branching can be trivially parallelised - case s' of - SNT s _ _ -> age s dt - SNA sf sx -> age sf dt >> age sx dt - SNH ss r -> age ss dt >> readIORef r >>= \s -> age s dt - SNM b sm -> age b dt >> age sm dt - SND _ s -> age s dt - SNKA s l -> age s dt >> age l dt - SNF1 _ s -> age s dt - SNF2 _ s1 s2 -> age s1 dt >> age s2 dt - SNF3 _ s1 s2 s3 -> age s1 dt >> age s2 dt >> age s3 dt - SNF4 _ s1 s2 s3 s4 -> age s1 dt >> age s2 dt >> age s3 dt >> age s4 dt - SNF5 _ s1 s2 s3 s4 s5 -> age s1 dt >> age s2 dt >> age s3 dt >> age s4 dt >> age s5 dt - _ -> return () - Aged _ _ -> return () - _ -> error "Inconsistent state: signal not sampled properly!" - -{-| Finalising aged signals for the next round. -} - -commit :: forall a . Signal a -> IO () -commit (S r) = do - t <- readIORef r - case t of - Aged _ s -> do writeIORef r (Ready s) - -- TODO: branching can be trivially parallelised - case s of - SNT s _ _ -> commit s - SNA sf sx -> commit sf >> commit sx - SNH ss r -> commit ss >> readIORef r >>= \s -> commit s - SNM b sm -> commit b >> commit sm - SND _ s -> commit s - SNKA s l -> commit s >> commit l - SNF1 _ s -> commit s - SNF2 _ s1 s2 -> commit s1 >> commit s2 - SNF3 _ s1 s2 s3 -> commit s1 >> commit s2 >> commit s3 - SNF4 _ s1 s2 s3 s4 -> commit s1 >> commit s2 >> commit s3 >> commit s4 - SNF5 _ s1 s2 s3 s4 s5 -> commit s1 >> commit s2 >> commit s3 >> commit s4 >> commit s5 - _ -> return () - Ready _ -> return () - _ -> error "Inconsistent state: signal not aged properly!" - -{-| Aging the signal. Stateful signals have their state forced to -prevent building up big thunks. The other nodes are structurally -static. -} - -advance :: SignalNode a -> a -> DTime -> IO (SignalNode a) -advance (SNS x f) _ dt = x `seq` return (SNS (f dt x) f) -advance (SNT s _ f) v _ = v `seq` return (SNT s v f) -advance (SND _ s) _ dt = do x <- signalValue s dt - return (SND x s) -advance s _ _ = return s - -{-| Sampling the signal at the current moment. This is where static -nodes propagate changes to those they depend on. Transfer functions -('SNT') work without delay, i.e. the effects of their input signals -can be observed in the same superstep. -} - -sample :: SignalNode a -> DTime -> IO a -sample (SNK x) _ = return x -sample (SNS x _) _ = return x -sample (SNT s x f) dt = do t <- signalValue s dt - return $! f dt t x -sample (SNA sf sx) dt = signalValue sf dt <*> signalValue sx dt -sample (SNH ss r) dt = do s <- signalValue ss dt - writeIORef r s - signalValue s dt -sample (SNM b sm) dt = do c <- signalValue b dt - SM m <- signalValue sm dt - if c then m else return undefined -sample (SNE r) _ = readIORef r -sample (SND v _) _ = return v -sample (SNKA s l) dt = do _ <- signalValue l dt - signalValue s dt -sample (SNF1 f s) dt = f <$> signalValue s dt -sample (SNF2 f s1 s2) dt = liftM2 f (signalValue s1 dt) (signalValue s2 dt) -sample (SNF3 f s1 s2 s3) dt = liftM3 f (signalValue s1 dt) (signalValue s2 dt) (signalValue s3 dt) -sample (SNF4 f s1 s2 s3 s4) dt = liftM4 f (signalValue s1 dt) (signalValue s2 dt) (signalValue s3 dt) (signalValue s4 dt) -sample (SNF5 f s1 s2 s3 s4 s5) dt = liftM5 f (signalValue s1 dt) (signalValue s2 dt) (signalValue s3 dt) (signalValue s4 dt) (signalValue s5 dt) - -{-| Sampling the signal with some kind of delay in order to resolve -dependency loops. Transfer functions simply return their previous -output (delays can be considered a special case, because they always -do that, so 'sampleDelayed' is never called with them), while other -types of signals are always handled by the 'sample' function, so it is -not possible to create a working stateful loop composed of solely -stateless combinators. -} - -sampleDelayed :: SignalNode a -> DTime -> IO a -sampleDelayed (SNT _ x _) _ = return x -sampleDelayed sn dt = sample sn dt - --- ** Userland combinators - -{-| Advancing the whole network that the given signal depends on by -the amount of time given in the second argument. -} - -superstep :: Signal a -- ^ the top-level signal - -> DTime -- ^ the amount of time to advance - -> IO a -- ^ the current value of the signal -superstep world dt = do - snapshot <- signalValue world dt - age world dt - commit world - return snapshot - -{-| A pure stateful signal. The initial state is the first output. -} - -stateful :: a -- ^ initial state - -> (DTime -> a -> a) -- ^ state transformation - -> SignalMonad (Signal a) -stateful x0 f = makeSignal (SNS x0 f) - -{-| A stateful transfer function. The current input affects the -current output, i.e. the initial state given in the first argument is -considered to appear before the first output, and can only be directly -observed by the `sampleDelayed` function. -} - -transfer :: a -- ^ initial internal state - -> (DTime -> t -> a -> a) -- ^ state updater function - -> Signal t -- ^ input signal - -> SignalMonad (Signal a) -transfer x0 f s = makeSignal (SNT s x0 f) - -{-| A continuous sampler that flattens a higher-order signal by -outputting its current snapshots. -} - -sampler :: Signal (Signal a) -- ^ signal to flatten - -> Signal a -sampler ss = makeSignalUnsafe (SNH ss (unsafePerformIO (newIORef undefined))) - -{-| A reactive signal that takes the value to output from a monad -carried by its input when a boolean control signal is true, otherwise -it outputs 'Nothing'. It is possible to create new signals in the -monad and also to print debug messages. -} - -generator :: Signal Bool -- ^ control (trigger) signal - -> Signal (SignalMonad a) -- ^ a stream of monads to potentially run - -> Signal (Maybe a) -generator b sm = toMaybe <$> b <*> makeSignalUnsafe (SNM b sm) - -{-| A helper function to wrap any value in a 'Maybe' depending on a -boolean condition. -} - -toMaybe :: Bool -> a -> Maybe a -toMaybe c v = if c then Just v else Nothing - -{-| A signal that can be directly fed through the sink function -returned. This can be used to attach the network to the outer -world. -} - -external :: a -- ^ initial value - -> IO (Signal a, Sink a) -- ^ the signal and an IO function to feed it -external x0 = do - ref <- newIORef x0 - snr <- newIORef (Ready (SNE ref)) - return (S snr,writeIORef ref) - -{-| The `delay` transfer function emits the value of a signal from the -previous superstep, starting with the filler value given in the first -argument. It has to be a primitive, otherwise it could not be used to -prevent automatic delays. -} - -delay :: a -- ^ initial output - -> Signal a -- ^ the signal to delay - -> SignalMonad (Signal a) -delay x0 s = makeSignal (SND x0 s) - -{-| Dependency injection to allow aging signals whose output is not -necessarily needed to produce the current sample of the first -argument. It's equivalent to @(flip . liftA2 . flip) const@, as it -evaluates its second argument first. -} - -keepAlive :: Signal a -- ^ the actual output - -> Signal t -- ^ a signal guaranteed to age when this one is sampled - -> Signal a -keepAlive s l = makeSignalUnsafe (SNKA s l) diff --git a/FRP/Elerea/Param.hs b/FRP/Elerea/Param.hs --- a/FRP/Elerea/Param.hs +++ b/FRP/Elerea/Param.hs @@ -20,7 +20,6 @@ , start , external , externalMulti - , debug -- * Basic building blocks , delay , generator @@ -34,9 +33,14 @@ , transfer2 , transfer3 , transfer4 - -- * Random sources - , noise - , getRandom + -- * Signals with side effects + -- $effectful + , execute + , effectful + , effectful1 + , effectful2 + , effectful3 + , effectful4 ) where import Control.Applicative @@ -47,7 +51,6 @@ import Data.Maybe import Prelude hiding (until) import System.Mem.Weak -import System.Random.Mersenne -- | A signal represents a value changing over time. It can be -- thought of as a function of type @Nat -> a@, where the argument is @@ -97,9 +100,8 @@ -- signals in the resulting structure. newtype SignalGen p a = SG { unSG :: IORef UpdatePool -> Signal p -> IO a } --- | The phases every signal goes through during a superstep: before --- or after sampling. -data Phase s a = Ready s | Aged s a +-- | The phases every signal goes through during a superstep. +data Phase a = Ready a | Updated a a instance Functor (SignalGen p) where fmap = liftM @@ -109,11 +111,11 @@ (<*>) = ap instance Monad (SignalGen p) where - return = SG . const . const . return + return x = SG $ \_ _ -> return x SG g >>= f = SG $ \p i -> g p i >>= \x -> unSG (f x) p i instance MonadFix (SignalGen p) where - mfix f = SG $ \p i -> mfix (($i).($p).unSG.f) + mfix f = SG $ \p i -> mfix $ \x -> unSG (f x) p i -- | Embedding a signal into an 'IO' environment. Repeated calls to -- the computation returned cause the whole network to be updated, and @@ -141,45 +143,38 @@ pool <- newIORef [] (inp,sink) <- external undefined S sample <- gen pool inp - - ptrs0 <- readIORef pool - writeIORef pool [] - (as0,cs0) <- unzip . map fromJust <$> mapM deRefWeak ptrs0 - let ageStatic = sequence_ as0 - commitStatic = sequence_ cs0 - return $ \param -> do - let update [] ptrs age commit = do - writeIORef pool ptrs - ageStatic >> age - commitStatic >> commit - update (p:ps) ptrs age commit = do - r <- deRefWeak p - case r of - Nothing -> update ps ptrs age commit - Just (a,c) -> update ps (p:ptrs) (age >> a) (commit >> c) - + let deref ptr = (fmap.fmap) ((,) ptr) (deRefWeak ptr) sink param res <- sample - ptrs <- readIORef pool - update ptrs [] (return ()) (return ()) + (ptrs,acts) <- unzip.catMaybes <$> (mapM deref =<< readIORef pool) + writeIORef pool ptrs + mapM_ fst acts + mapM_ snd acts return res -- | Auxiliary function used by all the primitives that create a -- mutable variable. -addSignal :: (Phase s a -> IO a) -- ^ sampling function - -> (Phase s a -> IO ()) -- ^ aging function - -> IORef (Phase s a) -- ^ the mutable variable behind the signal - -> IORef UpdatePool -- ^ the pool of update actions +addSignal :: (a -> IO a) -- ^ sampling function + -> (a -> IO ()) -- ^ aging function + -> IORef (Phase a) -- ^ the mutable variable behind the signal + -> IORef UpdatePool -- ^ the pool of update actions -> IO (Signal a) -addSignal sample age ref pool = do - let commit (Aged s _) = Ready s - commit _ = error "commit error: signal not aged" +addSignal sample update ref pool = do + let upd = readIORef ref >>= \v -> case v of + Ready x -> update x + _ -> return () - sig = S $ readIORef ref >>= sample + fin = readIORef ref >>= \v -> case v of + Updated x _ -> writeIORef ref $! Ready x + _ -> error "Signal not updated!" - update <- mkWeak sig (readIORef ref >>= age, modifyIORef ref commit) Nothing - modifyIORef pool (update:) + sig = S $ readIORef ref >>= \v -> case v of + Ready x -> sample x + Updated _ x -> return x + + updateActions <- mkWeak sig (upd,fin) Nothing + modifyIORef pool (updateActions:) return sig -- | The 'delay' combinator is the elementary building block for @@ -226,40 +221,13 @@ delay x0 (S s) = SG $ \pool _ -> do ref <- newIORef (Ready x0) - let sample (Ready x) = return x - sample (Aged _ x) = return x - - age (Ready x) = s >>= \x' -> x' `seq` writeIORef ref (Aged x' x) - age _ = return () - - addSignal sample age ref pool - --- | Memoising combinator. It can be used to cache results of --- applicative combinators in case they are used in several places. --- It is observationally equivalent to 'return' in the 'SignalGen' --- monad. --- --- > memo s = <|s s s s ...|> --- --- For instance, if @s = f \<$\> s'@, then @f@ will be recalculated --- once for each sampling of @s@. This can be avoided by writing @s --- \<- memo (f \<$\> s')@ instead. However, 'memo' incurs a small --- overhead, therefore it should not be used blindly. --- --- All the functions defined in this module return memoised signals. --- Just like 'delay', it is independent of the global input. -memo :: Signal a -- ^ signal to memoise - -> SignalGen p (Signal a) -memo (S s) = SG $ \pool _ -> do - ref <- newIORef (Ready undefined) - - let sample (Ready _) = s >>= \x -> writeIORef ref (Aged undefined x) >> return x - sample (Aged _ x) = return x + let update x = s >>= \x' -> x' `seq` writeIORef ref (Updated x' x) - age (Ready _) = s >>= \x -> writeIORef ref (Aged undefined x) - age _ = return () + addSignal return update ref pool - addSignal sample age ref pool +-- | Auxiliary function. +memoise :: IORef (Phase a) -> a -> IO a +memoise ref x = writeIORef ref (Updated undefined x) >> return x -- | A reactive signal that takes the value to output from a signal -- generator carried by its input with the sampling time provided as @@ -291,20 +259,37 @@ -- -- Refer to the longer example at the bottom of "FRP.Elerea.Simple" to -- see how it can be used. -generator :: Signal (SignalGen p a) -- ^ a stream of generators to potentially run - -> SignalGen p (Signal a) -generator (S gen) = SG $ \pool inp -> do +generator :: Signal (SignalGen p a) -- ^ the signal of generators to run + -> SignalGen p (Signal a) -- ^ the signal of generated structures +generator (S s) = SG $ \pool inp -> do ref <- newIORef (Ready undefined) - let next = ($inp).($pool).unSG =<< gen + let sample = (s >>= \(SG g) -> g pool inp) >>= memoise ref + + addSignal (const sample) (const (() <$ sample)) ref pool - sample (Ready _) = next >>= \x' -> writeIORef ref (Aged x' x') >> return x' - sample (Aged _ x) = return x +-- | Memoising combinator. It can be used to cache results of +-- applicative combinators in case they are used in several places. +-- It is observationally equivalent to 'return' in the 'SignalGen' +-- monad. +-- +-- > memo s = <|s s s s ...|> +-- +-- For instance, if @s = f \<$\> s'@, then @f@ will be recalculated +-- once for each sampling of @s@. This can be avoided by writing @s +-- \<- memo (f \<$\> s')@ instead. However, 'memo' incurs a small +-- overhead, therefore it should not be used blindly. +-- +-- All the functions defined in this module return memoised signals. +-- Just like 'delay', it is independent of the global input. +memo :: Signal a -- ^ the signal to cache + -> SignalGen p (Signal a) -- ^ a signal observationally equivalent to the argument +memo (S s) = SG $ \pool _ -> do + ref <- newIORef (Ready undefined) - age (Ready _) = next >>= \x' -> writeIORef ref (Aged x' x') - age _ = return () + let sample = s >>= memoise ref - addSignal sample age ref pool + addSignal (const sample) (const (() <$ sample)) ref pool -- | A signal that is true exactly once: the first time the input -- signal is true. Afterwards, it is constantly false, and it holds @@ -350,9 +335,9 @@ rsmp <- mfix $ \rs -> newIORef $ do x <- s - writeIORef ref (Aged undefined x) + writeIORef ref (Updated undefined x) when x $ writeIORef rs $ do - writeIORef ref (Aged undefined False) + writeIORef ref (Updated undefined False) return False return x @@ -430,8 +415,8 @@ update <- mkWeak sig (return (),takeMVar var >> putMVar var []) Nothing modifyIORef pool (update:) return sig - ,\val -> do vals <- takeMVar var - putMVar var (val:vals) + ,\val -> do vals <- takeMVar var + putMVar var (val:vals) ) -- | A direct stateful transformation of the input. The initial state @@ -522,28 +507,117 @@ sig' <- delay x0 sig memo (liftM5 f inp s1 s2 s3 s4 `ap` sig') --- | A random signal. +{- $effectful + +The following combinators are primarily aimed at library implementors +who wish build abstractions to effectful libraries on top of Elerea. + +-} + +-- | An IO action executed in the 'SignalGen' monad. Can be used as +-- `liftIO`. +execute :: IO a -> SignalGen p a +execute act = SG $ \_ _ -> act + +-- | A signal that executes a given IO action once at every sampling. -- +-- In essence, this combinator provides cooperative multitasking +-- capabilities, and its primary purpose is to assist library writers +-- in wrapping effectful APIs as conceptually pure signals. If there +-- are several effectful signals in the system, their order of +-- execution is undefined and should not be relied on. +-- -- Example: -- -- > do --- > smp <- start noise :: IO (IO Double) +-- > act <- start $ do +-- > ref <- execute $ newIORef 0 +-- > let accum n = do +-- > x <- readIORef ref +-- > putStrLn $ "Accumulator: " ++ show x +-- > writeIORef ref $! x+n +-- > return () +-- > effectful1 accum =<< input +-- > forM_ [4,9,2,1,5] act +-- +-- Output: +-- +-- > Accumulator: 0 +-- > Accumulator: 4 +-- > Accumulator: 13 +-- > Accumulator: 15 +-- > Accumulator: 16 +-- +-- Another example (requires mersenne-random): +-- +-- > do +-- > smp <- start $ effectful randomIO :: IO (IO Double) -- > res <- replicateM 5 smp -- > print res -- -- Output: -- -- > [0.12067753390401374,0.8658877349182655,0.7159264443196786,0.1756941896012891,0.9513646060896676] -noise :: MTRandom a => SignalGen p (Signal a) -noise = memo (S randomIO) +effectful :: IO a -- ^ the action to be executed repeatedly + -> SignalGen p (Signal a) +effectful act = SG $ \pool _ -> do + ref <- newIORef (Ready undefined) --- | A random source within the 'SignalGen' monad. -getRandom :: MTRandom a => SignalGen p a -getRandom = SG (const (const randomIO)) + let sample = act >>= memoise ref --- | A printing action within the 'SignalGen' monad. -debug :: String -> SignalGen p () -debug = SG . const . const . putStrLn + addSignal (const sample) (const (() <$ sample)) ref pool + +-- | A signal that executes a parametric IO action once at every +-- sampling. The parameter is supplied by another signal at every +-- sampling step. +effectful1 :: (t -> IO a) -- ^ the action to be executed repeatedly + -> Signal t -- ^ parameter signal + -> SignalGen p (Signal a) +effectful1 act (S s) = SG $ \pool _ -> do + ref <- newIORef (Ready undefined) + + let sample = s >>= act >>= memoise ref + + addSignal (const sample) (const (() <$ sample)) ref pool + +-- | Like 'effectful1', but with two parameter signals. +effectful2 :: (t1 -> t2 -> IO a) -- ^ the action to be executed repeatedly + -> Signal t1 -- ^ parameter signal 1 + -> Signal t2 -- ^ parameter signal 2 + -> SignalGen p (Signal a) +effectful2 act (S s1) (S s2) = SG $ \pool _ -> do + ref <- newIORef (Ready undefined) + + let sample = join (liftM2 act s1 s2) >>= memoise ref + + addSignal (const sample) (const (() <$ sample)) ref pool + +-- | Like 'effectful1', but with three parameter signals. +effectful3 :: (t1 -> t2 -> t3 -> IO a) -- ^ the action to be executed repeatedly + -> Signal t1 -- ^ parameter signal 1 + -> Signal t2 -- ^ parameter signal 2 + -> Signal t3 -- ^ parameter signal 3 + -> SignalGen p (Signal a) +effectful3 act (S s1) (S s2) (S s3) = SG $ \pool _ -> do + ref <- newIORef (Ready undefined) + + let sample = join (liftM3 act s1 s2 s3) >>= memoise ref + + addSignal (const sample) (const (() <$ sample)) ref pool + +-- | Like 'effectful1', but with four parameter signals. +effectful4 :: (t1 -> t2 -> t3 -> t4 -> IO a) -- ^ the action to be executed repeatedly + -> Signal t1 -- ^ parameter signal 1 + -> Signal t2 -- ^ parameter signal 2 + -> Signal t3 -- ^ parameter signal 3 + -> Signal t4 -- ^ parameter signal 4 + -> SignalGen p (Signal a) +effectful4 act (S s1) (S s2) (S s3) (S s4) = SG $ \pool _ -> do + ref <- newIORef (Ready undefined) + + let sample = join (liftM4 act s1 s2 s3 s4) >>= memoise ref + + addSignal (const sample) (const (() <$ sample)) ref pool -- | The @Show@ instance is only defined for the sake of 'Num'... instance Show (Signal a) where diff --git a/FRP/Elerea/Simple.hs b/FRP/Elerea/Simple.hs --- a/FRP/Elerea/Simple.hs +++ b/FRP/Elerea/Simple.hs @@ -16,7 +16,6 @@ , start , external , externalMulti - , debug -- * Basic building blocks , delay , generator @@ -29,14 +28,13 @@ , transfer3 , transfer4 -- * Signals with side effects + -- $effectful + , execute , effectful , effectful1 , effectful2 , effectful3 , effectful4 - -- * Random sources - , noise - , getRandom -- * A longer example -- $example ) where @@ -49,7 +47,6 @@ import Data.Maybe import Prelude hiding (until) import System.Mem.Weak -import System.Random.Mersenne -- | A signal represents a value changing over time. It can be -- thought of as a function of type @Nat -> a@, where the argument is @@ -73,7 +70,7 @@ -- | A dynamic set of actions to update a network without breaking -- consistency. -type UpdatePool = [Weak (IO (),IO ())] +type UpdatePool = [Weak (IO (), IO ())] -- | A signal generator is the only source of stateful signals. It -- can be thought of as a function of type @Nat -> a@, where the @@ -101,18 +98,18 @@ data Phase a = Ready a | Updated a a instance Functor SignalGen where - fmap = (<*>).pure + fmap = liftM instance Applicative SignalGen where pure = return (<*>) = ap instance Monad SignalGen where - return = SG . const . return + return x = SG $ \_ -> return x SG g >>= f = SG $ \p -> g p >>= \x -> unSG (f x) p instance MonadFix SignalGen where - mfix f = SG $ \p -> mfix (($p).unSG.f) + mfix f = SG $ \p -> mfix $ \x -> unSG (f x) p -- | Embedding a signal into an 'IO' environment. Repeated calls to -- the computation returned cause the whole network to be updated, and @@ -155,17 +152,17 @@ -> IORef UpdatePool -- ^ the pool of update actions -> IO (Signal a) -- ^ the signal created addSignal sample update ref pool = do - let upd = readIORef ref >>= \v -> case v of - Ready x -> update x - _ -> return () + let upd = readIORef ref >>= \v -> case v of + Ready x -> update x + _ -> return () - fin = readIORef ref >>= \v -> case v of - Updated x _ -> writeIORef ref $! Ready x - _ -> error "Signal not updated!" + fin = readIORef ref >>= \v -> case v of + Updated x _ -> writeIORef ref $! Ready x + _ -> error "Signal not updated!" - sig = S $ readIORef ref >>= \v -> case v of - Ready x -> sample x - Updated _ x -> return x + sig = S $ readIORef ref >>= \v -> case v of + Ready x -> sample x + Updated _ x -> return x updateActions <- mkWeak sig (upd,fin) Nothing modifyIORef pool (updateActions:) @@ -218,6 +215,10 @@ addSignal return update ref pool +-- | Auxiliary function. +memoise :: IORef (Phase a) -> a -> IO a +memoise ref x = writeIORef ref (Updated undefined x) >> return x + -- | A reactive signal that takes the value to output from a signal -- generator carried by its input with the sampling time provided as -- the start time for the generated structure. It is possible to @@ -250,17 +251,10 @@ generator (S s) = SG $ \pool -> do ref <- newIORef (Ready undefined) - let sample = do SG g <- s - x <- g pool - writeIORef ref (Updated undefined x) - return x + let sample = (s >>= \(SG g) -> g pool) >>= memoise ref addSignal (const sample) (const (() <$ sample)) ref pool --- | Auxiliary function. -memoise :: IORef (Phase a) -> a -> IO a -memoise ref x = writeIORef ref (Updated undefined x) >> return x - -- | Memoising combinator. It can be used to cache results of -- applicative combinators in case they are used in several places. -- It is observationally equivalent to 'return' in the 'SignalGen' @@ -402,8 +396,8 @@ update <- mkWeak sig (return (),takeMVar var >> putMVar var []) Nothing modifyIORef pool (update:) return sig - ,\val -> do vals <- takeMVar var - putMVar var (val:vals) + ,\val -> do vals <- takeMVar var + putMVar var (val:vals) ) -- | A pure stateful signal. The initial state is the first output, @@ -485,8 +479,19 @@ sig' <- delay x0 sig memo (liftM5 f s1 s2 s3 s4 sig') +{- $effectful + +The following combinators are primarily aimed at library implementors +who wish build abstractions to effectful libraries on top of Elerea. + +-} + +-- | An IO action executed in the 'SignalGen' monad. Can be used as +-- `liftIO`. +execute :: IO a -> SignalGen a +execute act = SG $ \_ -> act + -- | A signal that executes a given IO action once at every sampling. --- The IO action is constructed by an initialiser. -- -- In essence, this combinator provides cooperative multitasking -- capabilities, and its primary purpose is to assist library writers @@ -497,14 +502,14 @@ -- Example: -- -- > do --- > act <- start $ effectful $ do --- > ref <- newIORef 0 --- > return $ do --- > x <- readIORef ref --- > putStrLn $ "Count: " ++ show x --- > writeIORef ref $! x+1 --- > return () --- > replicateM_ 5 act +-- > smp <- start $ do +-- > ref <- execute $ newIORef 0 +-- > effectful $ do +-- > x <- readIORef ref +-- > putStrLn $ "Count: " ++ show x +-- > writeIORef ref $! x+1 +-- > return () +-- > replicateM_ 5 smp -- -- Output: -- @@ -513,94 +518,77 @@ -- > Count: 2 -- > Count: 3 -- > Count: 4 -effectful :: IO (IO a) -- ^ initialiser that yields the action to be executed repeatedly +-- +-- Another example (requires mersenne-random): +-- +-- > do +-- > smp <- start $ effectful randomIO :: IO (IO Double) +-- > res <- replicateM 5 smp +-- > print res +-- +-- Output: +-- +-- > [0.12067753390401374,0.8658877349182655,0.7159264443196786,0.1756941896012891,0.9513646060896676] +effectful :: IO a -- ^ the action to be executed repeatedly -> SignalGen (Signal a) -effectful gen = SG $ \pool -> do +effectful act = SG $ \pool -> do ref <- newIORef (Ready undefined) - act <- gen let sample = act >>= memoise ref addSignal (const sample) (const (() <$ sample)) ref pool -- | A signal that executes a parametric IO action once at every --- sampling. The IO action is constructed by an initialiser, and the --- parameter is supplied by another signal at every sampling step. -effectful1 :: IO (t -> IO a) -- ^ initialiser that yields the action to be executed repeatedly - -> Signal t -- ^ parameter signal +-- sampling. The parameter is supplied by another signal at every +-- sampling step. +effectful1 :: (t -> IO a) -- ^ the action to be executed repeatedly + -> Signal t -- ^ parameter signal -> SignalGen (Signal a) -effectful1 gen (S s) = SG $ \pool -> do +effectful1 act (S s) = SG $ \pool -> do ref <- newIORef (Ready undefined) - act <- gen let sample = s >>= act >>= memoise ref addSignal (const sample) (const (() <$ sample)) ref pool -- | Like 'effectful1', but with two parameter signals. -effectful2 :: IO (t1 -> t2 -> IO a) -- ^ initialiser that yields the action to be executed repeatedly - -> Signal t1 -- ^ parameter signal 1 - -> Signal t2 -- ^ parameter signal 2 +effectful2 :: (t1 -> t2 -> IO a) -- ^ the action to be executed repeatedly + -> Signal t1 -- ^ parameter signal 1 + -> Signal t2 -- ^ parameter signal 2 -> SignalGen (Signal a) -effectful2 gen (S s1) (S s2) = SG $ \pool -> do +effectful2 act (S s1) (S s2) = SG $ \pool -> do ref <- newIORef (Ready undefined) - act <- gen let sample = join (liftM2 act s1 s2) >>= memoise ref addSignal (const sample) (const (() <$ sample)) ref pool -- | Like 'effectful1', but with three parameter signals. -effectful3 :: IO (t1 -> t2 -> t3 -> IO a) -- ^ initialiser that yields the action to be executed repeatedly - -> Signal t1 -- ^ parameter signal 1 - -> Signal t2 -- ^ parameter signal 2 - -> Signal t3 -- ^ parameter signal 3 +effectful3 :: (t1 -> t2 -> t3 -> IO a) -- ^ the action to be executed repeatedly + -> Signal t1 -- ^ parameter signal 1 + -> Signal t2 -- ^ parameter signal 2 + -> Signal t3 -- ^ parameter signal 3 -> SignalGen (Signal a) -effectful3 gen (S s1) (S s2) (S s3) = SG $ \pool -> do +effectful3 act (S s1) (S s2) (S s3) = SG $ \pool -> do ref <- newIORef (Ready undefined) - act <- gen let sample = join (liftM3 act s1 s2 s3) >>= memoise ref addSignal (const sample) (const (() <$ sample)) ref pool -- | Like 'effectful1', but with four parameter signals. -effectful4 :: IO (t1 -> t2 -> t3 -> t4 -> IO a) -- ^ initialiser that yields the action to be executed repeatedly - -> Signal t1 -- ^ parameter signal 1 - -> Signal t2 -- ^ parameter signal 2 - -> Signal t3 -- ^ parameter signal 3 - -> Signal t4 -- ^ parameter signal 4 +effectful4 :: (t1 -> t2 -> t3 -> t4 -> IO a) -- ^ the action to be executed repeatedly + -> Signal t1 -- ^ parameter signal 1 + -> Signal t2 -- ^ parameter signal 2 + -> Signal t3 -- ^ parameter signal 3 + -> Signal t4 -- ^ parameter signal 4 -> SignalGen (Signal a) -effectful4 gen (S s1) (S s2) (S s3) (S s4) = SG $ \pool -> do +effectful4 act (S s1) (S s2) (S s3) (S s4) = SG $ \pool -> do ref <- newIORef (Ready undefined) - act <- gen let sample = join (liftM4 act s1 s2 s3 s4) >>= memoise ref addSignal (const sample) (const (() <$ sample)) ref pool - --- | A random signal. --- --- Example: --- --- > do --- > smp <- start noise :: IO (IO Double) --- > res <- replicateM 5 smp --- > print res --- --- Output: --- --- > [0.12067753390401374,0.8658877349182655,0.7159264443196786,0.1756941896012891,0.9513646060896676] -noise :: MTRandom a => SignalGen (Signal a) -noise = memo (S randomIO) - --- | A random source within the 'SignalGen' monad. -getRandom :: MTRandom a => SignalGen a -getRandom = SG (const randomIO) - --- | A printing action within the 'SignalGen' monad. -debug :: String -> SignalGen () -debug = SG . const . putStrLn -- | The Show instance is only defined for the sake of Num... instance Show (Signal a) where diff --git a/elerea.cabal b/elerea.cabal --- a/elerea.cabal +++ b/elerea.cabal @@ -1,5 +1,5 @@ Name: elerea -Version: 2.4.0 +Version: 2.5.0 Cabal-Version: >= 1.2 Synopsis: A minimalistic FRP library Category: reactivity, FRP @@ -50,13 +50,9 @@ Library Exposed-Modules: FRP.Elerea - FRP.Elerea.Legacy - FRP.Elerea.Legacy.Graph - FRP.Elerea.Legacy.Internal - FRP.Elerea.Legacy.Delayed FRP.Elerea.Simple FRP.Elerea.Param FRP.Elerea.Clocked - Build-Depends: base >= 4 && < 5, containers, mersenne-random + Build-Depends: base >= 4 && < 5, containers ghc-options: -Wall -O2