elerea 1.2.3 → 2.0.0

raw patch · 16 files changed

+2408/−2109 lines, 16 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGES +4/−0
• FRP/Elerea.hs +0/−122
• FRP/Elerea/Clocked.hs +399/−0
• FRP/Elerea/Delayed.hs +368/−0
• FRP/Elerea/Experimental.hs +0/−102
• FRP/Elerea/Experimental/Delayed.hs +0/−368
• FRP/Elerea/Experimental/Param.hs +0/−357
• FRP/Elerea/Experimental/Simple.hs +0/−435
• FRP/Elerea/Graph.hs +0/−171
• FRP/Elerea/Internal.hs +0/−546
• FRP/Elerea/Legacy.hs +122/−0
• FRP/Elerea/Legacy/Graph.hs +169/−0
• FRP/Elerea/Legacy/Internal.hs +546/−0
• FRP/Elerea/Param.hs +357/−0
• FRP/Elerea/Simple.hs +435/−0
• elerea.cabal +8/−8

@@ -1,3 +1,7 @@+2.0.0 - 100718+* moved experimental branch to the top (version 1 went into legacy status)+* added the clocked version+ 1.2.3 - 100131 * added externalMulti to handle events that can fire several times within a superstep * added a cache to the noise signal for safety reasons, so it lives in SignalGen now

@@ -1,122 +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.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.Experimental" branch provides a similar interface with-a rather different underlying structure, which is likely to be more-efficient.---}--module FRP.Elerea-    ( DTime, Sink, Signal, SignalMonad-    , createSignal, superstep-    , external-    , stateful, transfer, delay-    , sampler, generator-    , storeJust, toMaybe-    , edge-    , keepAlive, (.@.)-    , (==@), (/=@), (<@), (<=@), (>=@), (>@)-    , (&&@), (||@)-    , signalDebug-) where--import Control.Applicative-import FRP.Elerea.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 (&&)

@@ -0,0 +1,399 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{-|++This version differs from the simple one in adding associated freeze+control signals ("clocks") to stateful entities to be able to pause+entire subnetworks without having to write all the low-level logic+explicitly.  The clocks are fixed to signals upon their creation, and+the 'withClock' function can be used to specify the common clock for+the signals created in a given generator.++A clock signal affects 'delay' elements the following way: if the+clock signal is true, the delay works as usual, otherwise it remembers+its current output and throws away its current input.  If we consider+signals to be functions of time (natural numbers), the behaviour of+delay can be described by the following function:++@+ delay x0 s (t_start,clk) t_sample+   | t_start == t_sample = x0+   | t_start \< t_sample  = if clk t_sample+                             then s (t_sample-1)+                             else delay x0 s (t_start (t_sample-1)+   | otherwise           = error \"stream doesn't exist yet\"+@++A simple example to create counters operating at different rates using+the same generator:++@+ divisibleBy n x = x \`mod\` n == 0+@++@+ counter = stateful 0 (+1)+@++@+ drift = do+   time \<- counter+   c1 \<- withClock (divisibleBy 2 \<$\> time) counter+   c2 \<- withClock (divisibleBy 3 \<$\> time) counter+   return ((,) \<$\> c1 \<*\> c2)+@++Note that if you want to slow down the drift system defined above, the+naive approach might lead to surprising results:++@+ slowDrift = do+   time \<- counter+   withClock (divisibleBy 2 \<$\> time) drift+@++The problem is that the clocks are also slowed down, and their spikes+double in length.  This may or may not be what you want.  To overcome+this problem, we can define a clock oblivious edge detector to be used+within the definition of @drift@:++@+ edge = withClock (pure True) . transfer False (\\b b' -> b && not b')+@++@+ drift = do+   time \<- counter+   t2 \<- edge (divisibleBy 2 \<$\> time)+   t3 \<- edge (divisibleBy 3 \<$\> time)+   c1 \<- withClock t2 counter+   c2 \<- withClock t3 counter+   return ((,) \<$\> c1 \<*\> c2)+@++This works because the 'withClock' function overrides any clock+imposed on the generator from outside.++-}++module FRP.Elerea.Clocked+    ( Signal+    , SignalGen+    , start+    , external+    , externalMulti+    , delay+    , generator+    , withClock+    , memo+    , stateful+    , transfer+    , noise+    , getRandom+    ) 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@,+-- where the argument is the sampling time, and the 'Monad' instance+-- agrees with the intuition (bind corresponds to extracting the+-- current sample).+newtype Signal a = S (IO a) deriving (Functor, Applicative, Monad)++-- | A dynamic set of actions to update a network without breaking+-- consistency.+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+-- result is an arbitrary data structure that can potentially contain+-- new signals, and the argument is the creation time of these new+-- signals.  It exposes the 'MonadFix' interface, which makes it+-- possible to define signals in terms of each other.+newtype SignalGen a = SG { unSG :: IORef UpdatePool -> Signal Bool -> IO a }++-- | The phases every signal goes through during a superstep.+data Phase a = Ready a | Updated a a++instance Functor SignalGen where+  fmap = (<*>).pure++instance Applicative SignalGen where+  pure = return+  (<*>) = ap++instance Monad SignalGen where+  return = SG . const . const . return+  SG g >>= f = SG $ \p c -> g p c >>= \x -> unSG (f x) p c++instance MonadFix SignalGen where+  mfix f = SG $ \p c -> mfix (($c).($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. This is the only way to extract a signal generator outside+-- the network, and it is equivalent to passing zero to the function+-- representing the generator.+start :: SignalGen (Signal a) -- ^ the generator of the top-level signal+      -> IO (IO a)            -- ^ the computation to sample the signal+start (SG gen) = do+  pool <- newIORef []+  S sample <- gen pool (pure True)+  return $ do+    let deref ptr = (fmap.fmap) ((,) ptr) (deRefWeak ptr)+    res <- sample+    (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 :: (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)    -- ^ the signal created+addSignal sample update ref pool = do+  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!"++       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' transfer function emits the value of a signal from+-- the previous superstep, starting with the filler value given in the+-- first argument.  It can be thought of as the following function+-- (which should also make it clear why the return value is+-- 'SignalGen'):+--+-- @+--  delay x0 s t_start t_sample+--    | t_start == t_sample = x0+--    | t_start < t_sample  = s (t_sample-1)+--    | otherwise           = error \"Premature sample!\"+-- @+--+-- The way signal generators are extracted ensures that the error can+-- never happen.+delay :: a                    -- ^ initial output at creation time+      -> Signal a             -- ^ the signal to delay+      -> SignalGen (Signal a) -- ^ the delayed signal+delay x0 (S s) = SG $ \pool (S clk) -> do+  ref <- newIORef (Ready x0)++  let update x = do  x' <- s+                     c <- clk+                     x' `seq` writeIORef ref (Updated (if c then x' else x) x)++  addSignal return update ref pool++-- | A reactive signal that takes the value to output from a signal+-- generator carried by its input with the sampling time provided as+-- the time of generation.  It is possible to create new signals in+-- the monad.  It can be thought of as the following function:+--+-- @+--  generator g t_start t_sample = g t_sample t_sample+-- @+--+-- It has to live in the 'SignalGen' monad, because it needs to+-- maintain an internal state to be able to cache the current sample+-- for efficiency reasons. However, this state is not carried between+-- samples, therefore starting time doesn't matter and can be ignored.+generator :: Signal (SignalGen a) -- ^ the signal of generators to run+          -> SignalGen (Signal a) -- ^ the signal of generated structures+generator (S s) = SG $ \pool clk -> do+  ref <- newIORef (Ready undefined)++  let sample = do  SG g <- s+                   x <- g pool clk+                   writeIORef ref (Updated undefined x)+                   return x++  addSignal (const sample) (const (sample >> return ())) ref pool++-- | Override the clock used in a generator.  Note that clocks don't+-- interact unless one is used in the definition of the other, i.e. it+-- is possible to provide a fast clock within a generator with a slow+-- associated clock.+withClock :: Signal Bool -> SignalGen a -> SignalGen a+withClock clk (SG g) = SG $ \pool _ -> g pool clk++-- | 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 :: Signal a             -- ^ the signal to cache+     -> SignalGen (Signal a) -- ^ a signal observationally equivalent to the argument+memo (S s) = SG $ \pool _ -> do+  ref <- newIORef (Ready undefined)++  let sample = s >>= \x -> writeIORef ref (Updated undefined x) >> return x++  addSignal (const sample) (const (sample >> return ())) 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.+external :: a                         -- ^ initial value+         -> IO (Signal a, a -> IO ()) -- ^ the signal and an IO function to feed it+external x = do+  ref <- newIORef x+  return (S (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 (Signal [a]), a -> IO ()) -- ^ a generator for the event signal and the associated sink+externalMulti = do+  var <- newMVar []+  return (SG $ \pool _ -> do+             let sig = S $ readMVar var+             update <- mkWeak sig (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 subsequent state is derived from the preceding one by+-- applying a pure transformation.  It is equivalent to the following+-- expression:+--+-- @+--  stateful x0 f = 'mfix' $ \sig -> 'delay' x0 (f '<$>' sig)+-- @+stateful :: a                    -- ^ initial state+         -> (a -> a)             -- ^ state transformation+         -> SignalGen (Signal a)+stateful x0 f = mfix $ \sig -> delay x0 (f <$> sig)++-- | 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, and subsequent states are determined by combining the+-- preceding state with the current output of the input signal using+-- the function supplied.  It is equivalent to the following+-- expression:+--+-- @+--  transfer x0 f s = 'mfix' $ \sig -> 'liftA2' f s '<$>' 'delay' x0 sig+-- @+transfer :: a                    -- ^ initial internal state+         -> (t -> a -> a)        -- ^ state updater function+         -> Signal t             -- ^ input signal+         -> SignalGen (Signal a)+transfer x0 f s = mfix $ \sig -> liftA2 f s <$> delay x0 sig++-- | A random signal.+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 (const randomIO))++-- The Show instance is only defined for the sake of Num...+instance Show (Signal a) where+  showsPrec _ _ s = "<SIGNAL>" ++ s++-- Equality test is impossible.+instance Eq (Signal a) where+  _ == _ = False++-- 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

@@ -0,0 +1,368 @@+{-|++This version differs from the parametric one in introducing autmatic+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.++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.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 = "<SIGNAL>" ++ 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

@@ -1,102 +0,0 @@-{-|--This branch is an experimental version of Elerea that does not build-an actual graph of the dataflow network, just maintains a list of-actions to update signals.  Each signal consists of a mutable-variable, an aging action and a finalising action.  The variables can-only be accessed through a sampling action, and they are only referred-to in the corresponding aging and finalising action.  These actions-can be accessed through weak pointers that get invalidated when all-other references to the corresponding variable are lost.--This approach has both advantages and disadvantages.  On the plus-side, we don't have to create nodes for the applicative operations any-more, because they can be encoded in the sampling actions in an-efficient way.  Also, since we have a list of independent actions to-update the network, we can achieve nearly perfect parallelism, just-like with a raytracer: all we need is a clever way of assigning-actions to processing units.  The downside is that we have to-explicitly memoise the results of applicative operations in case they-are used more than once.--The modules below implement the basic idea in two variations:--* "FRP.Elerea.Experimental.Simple" provides discrete signals,-  i.e. streams;--* "FRP.Elerea.Experimental.Param" adds an extra parameter that's-  accessible to every node during the update, which can be used to-  provide a time step between samplings, or any other input necessary;--* "FRP.Elerea.Experimental.Delayed" adds automatic delays, which-  violates referential transparency in a limited way, but improves the-  usability of the API when this doesn't matter.--This module exports the delayed version along with a few utility-functions.---}--module FRP.Elerea.Experimental-       ( module FRP.Elerea.Experimental.Delayed-       , (-->)-       , edge-       , (==@), (/=@), (<@), (<=@), (>=@), (>@)-       , (&&@), (||@)-       ) where--import Control.Applicative-import FRP.Elerea.Experimental.Delayed--infix  4 ==@, /=@, <@, <=@, >=@, >@-infixr 3 &&@-infixr 2 ||@-infix  2 -->---- | 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 p Bool -> SignalGen p (Signal p Bool)-edge b = delay True b >>= \db -> return $ (not <$> db) &&@ b---- | The '-->' 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.-(-->) :: a                        -- ^ Initial output-      -> Signal p (Maybe a)       -- ^ Maybe signal to latch on-      -> SignalGen p (Signal p a)-x0 --> s = transfer x0 store s-    where store _ Nothing  x = x-          store _ (Just x) _ = x---- | Point-wise equality of two signals.-(==@) :: Eq a => Signal p a -> Signal p a -> Signal p Bool-(==@) = liftA2 (==)---- | Point-wise inequality of two signals.-(/=@) :: Eq a => Signal p a -> Signal p a -> Signal p Bool-(/=@) = liftA2 (/=)---- | Point-wise comparison of two signals.-(<@) :: Ord a => Signal p a -> Signal p a -> Signal p Bool-(<@) = liftA2 (<)---- | Point-wise comparison of two signals.-(<=@) :: Ord a => Signal p a -> Signal p a -> Signal p Bool-(<=@) = liftA2 (<=)---- | Point-wise comparison of two signals.-(>=@) :: Ord a => Signal p a -> Signal p a -> Signal p Bool-(>=@) = liftA2 (>=)---- | Point-wise comparison of two signals.-(>@) :: Ord a => Signal p a -> Signal p a -> Signal p Bool-(>@) = liftA2 (>)---- | Point-wise OR of two boolean signals.-(||@) :: Signal p Bool -> Signal p Bool -> Signal p Bool-s1 ||@ s2 = s1 >>= \b -> if b then return True else s2---- | Point-wise AND of two boolean signals.-(&&@) :: Signal p Bool -> Signal p Bool -> Signal p Bool-s1 &&@ s2 = s1 >>= \b -> if b then s2 else return False

@@ -1,368 +0,0 @@-{-|--This version differs from the parametric one in introducing autmatic-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.--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.Experimental.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 = "<SIGNAL>" ++ 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

@@ -1,357 +0,0 @@-{-|--This version differs from the simple one in providing an extra-argument to the sampling action that will be globally distributed to-every node and can be used to update the state.  For instance, it can-hold the time step between the two samplings, but it could also encode-all the external input to the system.--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;--* there is no automatic delay in order to preserve semantic soundness-  (e.g. the monad laws for signals);--* 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.Experimental.Param-    ( 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 | 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--       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--       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--       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--       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.-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)  = s p >>= \y -> let x' = f p y x in-                                            x' `seq` writeIORef ref (Aged x' x') >> return x'-       sample _ (Aged _ x) = return x--       age p (Ready x) = s p >>= \y -> let x' = f p y x in-                                        x' `seq` writeIORef ref (Aged x' x')-       age _ _         = return ()--  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 = "<SIGNAL>" ++ 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

@@ -1,435 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--{-|--This module provides leak-free and referentially transparent-higher-order discrete signals.  For a not entirely trivial example,-let's create a dynamic collection of countdown timers, where each-expired timer is removed from the collection.  First of all, we'll-need a simple tester function:--@- sigtest gen = 'replicateM' 15 '=<<' 'start' gen-@--We can try it with a trivial example:--@- \> sigtest $ 'stateful' 2 (+3)- [2,5,8,11,14,17,20,23,26,29,32,35,38,41,44,47]-@--Our first definition will be a signal representing a simple named-timer:--@- countdown :: String -\> Int -\> SignalGen (Signal (String,Maybe Int))- countdown name t = do-   let tick prev = do { t \<- prev ; 'guard' (t \> 0) ; 'return' (t-1) }-   timer \<- 'stateful' (Just t) tick-   'return' ((,) name '<$>' timer)-@--Let's see if it works:--@- \> sigtest $ countdown \"foo\" 4- [(\"foo\",Just 4),(\"foo\",Just 3),(\"foo\",Just 2),(\"foo\",Just 1),(\"foo\",Just 0),-  (\"foo\",Nothing),(\"foo\",Nothing),(\"foo\",Nothing),...]-@--Next, we will define a timer source that takes a list of timer names,-starting values and start times and creates a signal that delivers the-list of new timers at every point:--@- timerSource :: [(String, Int, Int)] -\> SignalGen (Signal [Signal (String, Maybe Int)])- timerSource ts = do-   let gen t = 'mapM' ('uncurry' countdown) newTimers-           where newTimers = [(n,v) | (n,v,st) \<- ts, st == t]-   cnt \<- 'stateful' 0 (+1)-   'generator' (gen '<$>' cnt)-@--Now we need to encapsulate the timer source signal in another signal-expression that takes care of maintaining the list of live timers.-Since working with dynamic collections is a recurring task, let's-define a generic combinator that maintains a dynamic list of signals-given a source and a test that tells from the output of each signal-whether it should be kept.  We can use @mdo@ expressions (a variant of-@do@ expressions allowing forward references) as syntactic sugar for-'mfix' to make life easier:--@- collection :: Signal [Signal a] -\> (a -\> Bool) -\> SignalGen (Signal [a])- collection source isAlive = mdo-   sig \<- 'delay' [] ('map' 'snd' '<$>' collWithVals')-   coll \<- 'memo' ('liftA2' (++) source sig)-   let collWithVals = 'zip' '<$>' ('sequence' '=<<' coll) '<*>' coll-   collWithVals' \<- 'memo' ('filter' (isAlive . 'fst') '<$>' collWithVals)-   'return' $ 'map' 'fst' '<$>' collWithVals'-@--We need recursion to define the @coll@ signal as a delayed version of-its continuation, which does not contain signals that need to be-removed in the current sample.  At every point of time the running-collection is concatenated with the source.  We define @collWithVals@,-which simply pairs up every signal with its current output.  The-output is obtained by extracting the current value of the signal-container and sampling each element with 'sequence'.  We can then-derive @collWithVals'@, which contains only the signals that must be-kept for the next round along with their output.  Both @coll@ and-@collWithVals'@ have to be memoised, because they are used more than-once (the program would work without that, but it would recalculate-both signals each time they are used).  By throwing out the respective-parts, we can get both the final output and the collection for the-next step (@coll'@).--Now we can easily finish the original task:--@- timers :: [(String, Int, Int)] -\> SignalGen (Signal [(String, Int)])- timers timerData = do-   src \<- timerSource timerData-   getOutput '<$>' collection src ('isJust' . 'snd')-     where getOutput = 'fmap' ('map' (\\(name,Just val) -> (name,val)))-@--As a test, we can start four timers: /a/ at t=0 with value 3, /b/ and-/c/ at t=1 with values 5 and 3, and /d/ at t=3 with value 4:--@- \> sigtest $ timers [(\"a\",3,0),(\"b\",5,1),(\"c\",3,1),(\"d\",4,3)]- [[(\"a\",3)],[(\"b\",5),(\"c\",3),(\"a\",2)],[(\"b\",4),(\"c\",2),(\"a\",1)],-  [(\"d\",4),(\"b\",3),(\"c\",1),(\"a\",0)],[(\"d\",3),(\"b\",2),(\"c\",0)],-  [(\"d\",2),(\"b\",1)],[(\"d\",1),(\"b\",0)],[(\"d\",0)],[],[],[],[],[],[],[]]-@--If the noise of the applicative lifting operators feels annoying, she-(<http://personal.cis.strath.ac.uk/~conor/pub/she/>) comes to the-save.  Among other features it provides idiom brackets, which can-substitute the explicit lifting.  For instance, it allows us to define-@collection@ this way:--@- collection :: Stream [Stream a] -> (a -> Bool) -> StreamGen (Stream [a])- collection source isAlive = mdo-   sig \<- 'delay' [] (|'map' ~'snd' collWithVals'|)-   coll \<- 'memo' (|source ++ sig|)-   collWithVals' \<- 'memo' (|'filter' ~(isAlive . 'fst') (|'zip' ('sequence' '=<<' coll) coll|)|)-   'return' (|'map' ~'fst' collWithVals'|)-@---}--module FRP.Elerea.Experimental.Simple-    ( Signal-    , SignalGen-    , start-    , external-    , externalMulti-    , delay-    , generator-    , memo-    , stateful-    , transfer-    , noise-    , getRandom-    ) 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@,--- where the argument is the sampling time, and the 'Monad' instance--- agrees with the intuition (bind corresponds to extracting the--- current sample).-newtype Signal a = S (IO a) deriving (Functor, Applicative, Monad)---- | A dynamic set of actions to update a network without breaking--- consistency.-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--- result is an arbitrary data structure that can potentially contain--- new signals, and the argument is the creation time of these new--- signals.  It exposes the 'MonadFix' interface, which makes it--- possible to define signals in terms of each other.-newtype SignalGen a = SG { unSG :: IORef UpdatePool -> IO a }---- | The phases every signal goes through during a superstep.-data Phase a = Ready a | Updated a a--instance Functor SignalGen where-  fmap = (<*>).pure--instance Applicative SignalGen where-  pure = return-  (<*>) = ap--instance Monad SignalGen where-  return = SG . const . return-  SG g >>= f = SG $ \p -> g p >>= \x -> unSG (f x) p--instance MonadFix SignalGen 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. This is the only way to extract a signal generator outside--- the network, and it is equivalent to passing zero to the function--- representing the generator.-start :: SignalGen (Signal a) -- ^ the generator of the top-level signal-      -> IO (IO a)            -- ^ the computation to sample the signal-start (SG gen) = do-  pool <- newIORef []-  S sample <- gen pool-  return $ do-    let deref ptr = (fmap.fmap) ((,) ptr) (deRefWeak ptr)-    res <- sample-    (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 :: (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)    -- ^ the signal created-addSignal sample update ref pool = do-  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!"--       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' transfer function emits the value of a signal from--- the previous superstep, starting with the filler value given in the--- first argument.  It can be thought of as the following function--- (which should also make it clear why the return value is--- 'SignalGen'):------ @---  delay x0 s t_start t_sample---    | t_start == t_sample = x0---    | t_start < t_sample  = s (t_sample-1)---    | otherwise           = error \"Premature sample!\"--- @------ The way signal generators are extracted ensures that the error can--- never happen.-delay :: a                    -- ^ initial output at creation time-      -> Signal a             -- ^ the signal to delay-      -> SignalGen (Signal a) -- ^ the delayed signal-delay x0 (S s) = SG $ \pool -> do-  ref <- newIORef (Ready x0)--  let update x = s >>= \x' -> x' `seq` writeIORef ref (Updated x' x)--  addSignal return update ref pool---- | A reactive signal that takes the value to output from a signal--- generator carried by its input with the sampling time provided as--- the time of generation.  It is possible to create new signals in--- the monad.  It can be thought of as the following function:------ @---  generator g t_start t_sample = g t_sample t_sample--- @------ It has to live in the 'SignalGen' monad, because it needs to--- maintain an internal state to be able to cache the current sample--- for efficiency reasons. However, this state is not carried between--- samples, therefore starting time doesn't matter and can be ignored.-generator :: Signal (SignalGen a) -- ^ the signal of generators to run-          -> SignalGen (Signal a) -- ^ the signal of generated structures-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--  addSignal (const sample) (const (sample >> return ())) 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 :: Signal a             -- ^ the signal to cache-     -> SignalGen (Signal a) -- ^ a signal observationally equivalent to the argument-memo (S s) = SG $ \pool -> do-  ref <- newIORef (Ready undefined)--  let sample = s >>= \x -> writeIORef ref (Updated undefined x) >> return x--  addSignal (const sample) (const (sample >> return ())) 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.-external :: a                         -- ^ initial value-         -> IO (Signal a, a -> IO ()) -- ^ the signal and an IO function to feed it-external x = do-  ref <- newIORef x-  return (S (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 (Signal [a]), a -> IO ()) -- ^ a generator for the event signal and the associated sink-externalMulti = do-  var <- newMVar []-  return (SG $ \pool -> do-             let sig = S $ readMVar var-             update <- mkWeak sig (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 subsequent state is derived from the preceding one by--- applying a pure transformation.  It is equivalent to the following--- expression:------ @---  stateful x0 f = 'mfix' $ \sig -> 'delay' x0 (f '<$>' sig)--- @-stateful :: a                    -- ^ initial state-         -> (a -> a)             -- ^ state transformation-         -> SignalGen (Signal a)-stateful x0 f = mfix $ \sig -> delay x0 (f <$> sig)---- | 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, and subsequent states are determined by combining the--- preceding state with the current output of the input signal using--- the function supplied.  It is equivalent to the following--- expression:------ @---  transfer x0 f s = 'mfix' $ \sig -> 'liftA2' f s '<$>' 'delay' x0 sig--- @-transfer :: a                    -- ^ initial internal state-         -> (t -> a -> a)        -- ^ state updater function-         -> Signal t             -- ^ input signal-         -> SignalGen (Signal a)-transfer x0 f s = mfix $ \sig -> liftA2 f s <$> delay x0 sig---- | A random signal.-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)---- The Show instance is only defined for the sake of Num...-instance Show (Signal a) where-  showsPrec _ _ s = "<SIGNAL>" ++ s---- Equality test is impossible.-instance Eq (Signal a) where-  _ == _ = False---- 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

@@ -1,171 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}--{-|--This module provides some means to visualise the signal structure.---}--module FRP.Elerea.Graph (signalToDot) where--import Control.Monad-import Data.IORef-import Data.Maybe-import qualified Data.Map as Map-import Foreign.Ptr-import Foreign.StablePtr-import FRP.Elerea.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-(<http://www.graphviz.org/>) 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"

@@ -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.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 = "<SIGNAL>" ++ 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)

@@ -0,0 +1,122 @@+{-|++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.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.Experimental" 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 (&&)

@@ -0,0 +1,169 @@+{-# 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+(<http://www.graphviz.org/>) 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"

@@ -0,0 +1,546 @@+{-# 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 = "<SIGNAL>" ++ 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)

@@ -0,0 +1,357 @@+{-|++This version differs from the simple one in providing an extra+argument to the sampling action that will be globally distributed to+every node and can be used to update the state.  For instance, it can+hold the time step between the two samplings, but it could also encode+all the external input to the system.++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;++* there is no automatic delay in order to preserve semantic soundness+  (e.g. the monad laws for signals);++* 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.Param+    ( 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 | 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++       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++       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++       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++       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.+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)  = s p >>= \y -> let x' = f p y x in+                                            x' `seq` writeIORef ref (Aged x' x') >> return x'+       sample _ (Aged _ x) = return x++       age p (Ready x) = s p >>= \y -> let x' = f p y x in+                                        x' `seq` writeIORef ref (Aged x' x')+       age _ _         = return ()++  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 = "<SIGNAL>" ++ 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

@@ -0,0 +1,435 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{-|++This module provides leak-free and referentially transparent+higher-order discrete signals.  For a not entirely trivial example,+let's create a dynamic collection of countdown timers, where each+expired timer is removed from the collection.  First of all, we'll+need a simple tester function:++@+ sigtest gen = 'replicateM' 15 '=<<' 'start' gen+@++We can try it with a trivial example:++@+ \> sigtest $ 'stateful' 2 (+3)+ [2,5,8,11,14,17,20,23,26,29,32,35,38,41,44,47]+@++Our first definition will be a signal representing a simple named+timer:++@+ countdown :: String -\> Int -\> SignalGen (Signal (String,Maybe Int))+ countdown name t = do+   let tick prev = do { t \<- prev ; 'guard' (t \> 0) ; 'return' (t-1) }+   timer \<- 'stateful' (Just t) tick+   'return' ((,) name '<$>' timer)+@++Let's see if it works:++@+ \> sigtest $ countdown \"foo\" 4+ [(\"foo\",Just 4),(\"foo\",Just 3),(\"foo\",Just 2),(\"foo\",Just 1),(\"foo\",Just 0),+  (\"foo\",Nothing),(\"foo\",Nothing),(\"foo\",Nothing),...]+@++Next, we will define a timer source that takes a list of timer names,+starting values and start times and creates a signal that delivers the+list of new timers at every point:++@+ timerSource :: [(String, Int, Int)] -\> SignalGen (Signal [Signal (String, Maybe Int)])+ timerSource ts = do+   let gen t = 'mapM' ('uncurry' countdown) newTimers+           where newTimers = [(n,v) | (n,v,st) \<- ts, st == t]+   cnt \<- 'stateful' 0 (+1)+   'generator' (gen '<$>' cnt)+@++Now we need to encapsulate the timer source signal in another signal+expression that takes care of maintaining the list of live timers.+Since working with dynamic collections is a recurring task, let's+define a generic combinator that maintains a dynamic list of signals+given a source and a test that tells from the output of each signal+whether it should be kept.  We can use @mdo@ expressions (a variant of+@do@ expressions allowing forward references) as syntactic sugar for+'mfix' to make life easier:++@+ collection :: Signal [Signal a] -\> (a -\> Bool) -\> SignalGen (Signal [a])+ collection source isAlive = mdo+   sig \<- 'delay' [] ('map' 'snd' '<$>' collWithVals')+   coll \<- 'memo' ('liftA2' (++) source sig)+   let collWithVals = 'zip' '<$>' ('sequence' '=<<' coll) '<*>' coll+   collWithVals' \<- 'memo' ('filter' (isAlive . 'fst') '<$>' collWithVals)+   'return' $ 'map' 'fst' '<$>' collWithVals'+@++We need recursion to define the @coll@ signal as a delayed version of+its continuation, which does not contain signals that need to be+removed in the current sample.  At every point of time the running+collection is concatenated with the source.  We define @collWithVals@,+which simply pairs up every signal with its current output.  The+output is obtained by extracting the current value of the signal+container and sampling each element with 'sequence'.  We can then+derive @collWithVals'@, which contains only the signals that must be+kept for the next round along with their output.  Both @coll@ and+@collWithVals'@ have to be memoised, because they are used more than+once (the program would work without that, but it would recalculate+both signals each time they are used).  By throwing out the respective+parts, we can get both the final output and the collection for the+next step (@coll'@).++Now we can easily finish the original task:++@+ timers :: [(String, Int, Int)] -\> SignalGen (Signal [(String, Int)])+ timers timerData = do+   src \<- timerSource timerData+   getOutput '<$>' collection src ('isJust' . 'snd')+     where getOutput = 'fmap' ('map' (\\(name,Just val) -> (name,val)))+@++As a test, we can start four timers: /a/ at t=0 with value 3, /b/ and+/c/ at t=1 with values 5 and 3, and /d/ at t=3 with value 4:++@+ \> sigtest $ timers [(\"a\",3,0),(\"b\",5,1),(\"c\",3,1),(\"d\",4,3)]+ [[(\"a\",3)],[(\"b\",5),(\"c\",3),(\"a\",2)],[(\"b\",4),(\"c\",2),(\"a\",1)],+  [(\"d\",4),(\"b\",3),(\"c\",1),(\"a\",0)],[(\"d\",3),(\"b\",2),(\"c\",0)],+  [(\"d\",2),(\"b\",1)],[(\"d\",1),(\"b\",0)],[(\"d\",0)],[],[],[],[],[],[],[]]+@++If the noise of the applicative lifting operators feels annoying, she+(<http://personal.cis.strath.ac.uk/~conor/pub/she/>) comes to the+save.  Among other features it provides idiom brackets, which can+substitute the explicit lifting.  For instance, it allows us to define+@collection@ this way:++@+ collection :: Stream [Stream a] -> (a -> Bool) -> StreamGen (Stream [a])+ collection source isAlive = mdo+   sig \<- 'delay' [] (|'map' ~'snd' collWithVals'|)+   coll \<- 'memo' (|source ++ sig|)+   collWithVals' \<- 'memo' (|'filter' ~(isAlive . 'fst') (|'zip' ('sequence' '=<<' coll) coll|)|)+   'return' (|'map' ~'fst' collWithVals'|)+@++-}++module FRP.Elerea.Simple+    ( Signal+    , SignalGen+    , start+    , external+    , externalMulti+    , delay+    , generator+    , memo+    , stateful+    , transfer+    , noise+    , getRandom+    ) 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@,+-- where the argument is the sampling time, and the 'Monad' instance+-- agrees with the intuition (bind corresponds to extracting the+-- current sample).+newtype Signal a = S (IO a) deriving (Functor, Applicative, Monad)++-- | A dynamic set of actions to update a network without breaking+-- consistency.+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+-- result is an arbitrary data structure that can potentially contain+-- new signals, and the argument is the creation time of these new+-- signals.  It exposes the 'MonadFix' interface, which makes it+-- possible to define signals in terms of each other.+newtype SignalGen a = SG { unSG :: IORef UpdatePool -> IO a }++-- | The phases every signal goes through during a superstep.+data Phase a = Ready a | Updated a a++instance Functor SignalGen where+  fmap = (<*>).pure++instance Applicative SignalGen where+  pure = return+  (<*>) = ap++instance Monad SignalGen where+  return = SG . const . return+  SG g >>= f = SG $ \p -> g p >>= \x -> unSG (f x) p++instance MonadFix SignalGen 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. This is the only way to extract a signal generator outside+-- the network, and it is equivalent to passing zero to the function+-- representing the generator.+start :: SignalGen (Signal a) -- ^ the generator of the top-level signal+      -> IO (IO a)            -- ^ the computation to sample the signal+start (SG gen) = do+  pool <- newIORef []+  S sample <- gen pool+  return $ do+    let deref ptr = (fmap.fmap) ((,) ptr) (deRefWeak ptr)+    res <- sample+    (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 :: (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)    -- ^ the signal created+addSignal sample update ref pool = do+  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!"++       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' transfer function emits the value of a signal from+-- the previous superstep, starting with the filler value given in the+-- first argument.  It can be thought of as the following function+-- (which should also make it clear why the return value is+-- 'SignalGen'):+--+-- @+--  delay x0 s t_start t_sample+--    | t_start == t_sample = x0+--    | t_start < t_sample  = s (t_sample-1)+--    | otherwise           = error \"Premature sample!\"+-- @+--+-- The way signal generators are extracted ensures that the error can+-- never happen.+delay :: a                    -- ^ initial output at creation time+      -> Signal a             -- ^ the signal to delay+      -> SignalGen (Signal a) -- ^ the delayed signal+delay x0 (S s) = SG $ \pool -> do+  ref <- newIORef (Ready x0)++  let update x = s >>= \x' -> x' `seq` writeIORef ref (Updated x' x)++  addSignal return update ref pool++-- | A reactive signal that takes the value to output from a signal+-- generator carried by its input with the sampling time provided as+-- the time of generation.  It is possible to create new signals in+-- the monad.  It can be thought of as the following function:+--+-- @+--  generator g t_start t_sample = g t_sample t_sample+-- @+--+-- It has to live in the 'SignalGen' monad, because it needs to+-- maintain an internal state to be able to cache the current sample+-- for efficiency reasons. However, this state is not carried between+-- samples, therefore starting time doesn't matter and can be ignored.+generator :: Signal (SignalGen a) -- ^ the signal of generators to run+          -> SignalGen (Signal a) -- ^ the signal of generated structures+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++  addSignal (const sample) (const (sample >> return ())) 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 :: Signal a             -- ^ the signal to cache+     -> SignalGen (Signal a) -- ^ a signal observationally equivalent to the argument+memo (S s) = SG $ \pool -> do+  ref <- newIORef (Ready undefined)++  let sample = s >>= \x -> writeIORef ref (Updated undefined x) >> return x++  addSignal (const sample) (const (sample >> return ())) 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.+external :: a                         -- ^ initial value+         -> IO (Signal a, a -> IO ()) -- ^ the signal and an IO function to feed it+external x = do+  ref <- newIORef x+  return (S (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 (Signal [a]), a -> IO ()) -- ^ a generator for the event signal and the associated sink+externalMulti = do+  var <- newMVar []+  return (SG $ \pool -> do+             let sig = S $ readMVar var+             update <- mkWeak sig (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 subsequent state is derived from the preceding one by+-- applying a pure transformation.  It is equivalent to the following+-- expression:+--+-- @+--  stateful x0 f = 'mfix' $ \sig -> 'delay' x0 (f '<$>' sig)+-- @+stateful :: a                    -- ^ initial state+         -> (a -> a)             -- ^ state transformation+         -> SignalGen (Signal a)+stateful x0 f = mfix $ \sig -> delay x0 (f <$> sig)++-- | 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, and subsequent states are determined by combining the+-- preceding state with the current output of the input signal using+-- the function supplied.  It is equivalent to the following+-- expression:+--+-- @+--  transfer x0 f s = 'mfix' $ \sig -> 'liftA2' f s '<$>' 'delay' x0 sig+-- @+transfer :: a                    -- ^ initial internal state+         -> (t -> a -> a)        -- ^ state updater function+         -> Signal t             -- ^ input signal+         -> SignalGen (Signal a)+transfer x0 f s = mfix $ \sig -> liftA2 f s <$> delay x0 sig++-- | A random signal.+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)++-- The Show instance is only defined for the sake of Num...+instance Show (Signal a) where+  showsPrec _ _ s = "<SIGNAL>" ++ s++-- Equality test is impossible.+instance Eq (Signal a) where+  _ == _ = False++-- 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

@@ -1,5 +1,5 @@ Name:                elerea-Version:             1.2.3+Version:             2.0.0 Cabal-Version:       >= 1.2 Synopsis:            A minimalistic FRP library Category:            reactivity, FRP@@ -37,13 +37,13 @@  Library   Exposed-Modules:-    FRP.Elerea-    FRP.Elerea.Internal-    FRP.Elerea.Graph-    FRP.Elerea.Experimental-    FRP.Elerea.Experimental.Simple-    FRP.Elerea.Experimental.Param-    FRP.Elerea.Experimental.Delayed+    FRP.Elerea.Legacy+    FRP.Elerea.Legacy.Graph+    FRP.Elerea.Legacy.Internal+    FRP.Elerea.Simple+    FRP.Elerea.Param+    FRP.Elerea.Clocked+    FRP.Elerea.Delayed    Build-Depends:       base >= 3 && < 5, containers, mersenne-random   ghc-options:         -Wall -O2