diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -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 diff --git a/FRP/Elerea.hs b/FRP/Elerea.hs deleted file mode 100644 --- a/FRP/Elerea.hs +++ /dev/null @@ -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 (&&) diff --git a/FRP/Elerea/Clocked.hs b/FRP/Elerea/Clocked.hs new file mode 100644 --- /dev/null +++ b/FRP/Elerea/Clocked.hs @@ -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 = "" ++ 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 diff --git a/FRP/Elerea/Delayed.hs b/FRP/Elerea/Delayed.hs new file mode 100644 --- /dev/null +++ b/FRP/Elerea/Delayed.hs @@ -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 = "" ++ s + +-- | Equality test is impossible. +instance Eq (Signal p a) where + _ == _ = False + +-- | Error message for unimplemented instance functions. +unimp :: String -> a +unimp = error . ("Signal: "++) + +instance Ord t => Ord (Signal p t) where + compare = unimp "compare" + min = liftA2 min + max = liftA2 max + +instance Enum t => Enum (Signal p t) where + succ = fmap succ + pred = fmap pred + toEnum = pure . toEnum + fromEnum = unimp "fromEnum" + enumFrom = unimp "enumFrom" + enumFromThen = unimp "enumFromThen" + enumFromTo = unimp "enumFromTo" + enumFromThenTo = unimp "enumFromThenTo" + +instance Bounded t => Bounded (Signal p t) where + minBound = pure minBound + maxBound = pure maxBound + +instance Num t => Num (Signal p t) where + (+) = liftA2 (+) + (-) = liftA2 (-) + (*) = liftA2 (*) + signum = fmap signum + abs = fmap abs + negate = fmap negate + fromInteger = pure . fromInteger + +instance Real t => Real (Signal p t) where + toRational = unimp "toRational" + +instance Integral t => Integral (Signal p t) where + quot = liftA2 quot + rem = liftA2 rem + div = liftA2 div + mod = liftA2 mod + quotRem a b = (fst <$> qrab,snd <$> qrab) + where qrab = quotRem <$> a <*> b + divMod a b = (fst <$> dmab,snd <$> dmab) + where dmab = divMod <$> a <*> b + toInteger = unimp "toInteger" + +instance Fractional t => Fractional (Signal p t) where + (/) = liftA2 (/) + recip = fmap recip + fromRational = pure . fromRational + +instance Floating t => Floating (Signal p t) where + pi = pure pi + exp = fmap exp + sqrt = fmap sqrt + log = fmap log + (**) = liftA2 (**) + logBase = liftA2 logBase + sin = fmap sin + tan = fmap tan + cos = fmap cos + asin = fmap asin + atan = fmap atan + acos = fmap acos + sinh = fmap sinh + tanh = fmap tanh + cosh = fmap cosh + asinh = fmap asinh + atanh = fmap atanh + acosh = fmap acosh diff --git a/FRP/Elerea/Experimental.hs b/FRP/Elerea/Experimental.hs deleted file mode 100644 --- a/FRP/Elerea/Experimental.hs +++ /dev/null @@ -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 diff --git a/FRP/Elerea/Experimental/Delayed.hs b/FRP/Elerea/Experimental/Delayed.hs deleted file mode 100644 --- a/FRP/Elerea/Experimental/Delayed.hs +++ /dev/null @@ -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 = "" ++ s - --- | Equality test is impossible. -instance Eq (Signal p a) where - _ == _ = False - --- | Error message for unimplemented instance functions. -unimp :: String -> a -unimp = error . ("Signal: "++) - -instance Ord t => Ord (Signal p t) where - compare = unimp "compare" - min = liftA2 min - max = liftA2 max - -instance Enum t => Enum (Signal p t) where - succ = fmap succ - pred = fmap pred - toEnum = pure . toEnum - fromEnum = unimp "fromEnum" - enumFrom = unimp "enumFrom" - enumFromThen = unimp "enumFromThen" - enumFromTo = unimp "enumFromTo" - enumFromThenTo = unimp "enumFromThenTo" - -instance Bounded t => Bounded (Signal p t) where - minBound = pure minBound - maxBound = pure maxBound - -instance Num t => Num (Signal p t) where - (+) = liftA2 (+) - (-) = liftA2 (-) - (*) = liftA2 (*) - signum = fmap signum - abs = fmap abs - negate = fmap negate - fromInteger = pure . fromInteger - -instance Real t => Real (Signal p t) where - toRational = unimp "toRational" - -instance Integral t => Integral (Signal p t) where - quot = liftA2 quot - rem = liftA2 rem - div = liftA2 div - mod = liftA2 mod - quotRem a b = (fst <$> qrab,snd <$> qrab) - where qrab = quotRem <$> a <*> b - divMod a b = (fst <$> dmab,snd <$> dmab) - where dmab = divMod <$> a <*> b - toInteger = unimp "toInteger" - -instance Fractional t => Fractional (Signal p t) where - (/) = liftA2 (/) - recip = fmap recip - fromRational = pure . fromRational - -instance Floating t => Floating (Signal p t) where - pi = pure pi - exp = fmap exp - sqrt = fmap sqrt - log = fmap log - (**) = liftA2 (**) - logBase = liftA2 logBase - sin = fmap sin - tan = fmap tan - cos = fmap cos - asin = fmap asin - atan = fmap atan - acos = fmap acos - sinh = fmap sinh - tanh = fmap tanh - cosh = fmap cosh - asinh = fmap asinh - atanh = fmap atanh - acosh = fmap acosh diff --git a/FRP/Elerea/Experimental/Param.hs b/FRP/Elerea/Experimental/Param.hs deleted file mode 100644 --- a/FRP/Elerea/Experimental/Param.hs +++ /dev/null @@ -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 = "" ++ s - --- | Equality test is impossible. -instance Eq (Signal p a) where - _ == _ = False - --- | Error message for unimplemented instance functions. -unimp :: String -> a -unimp = error . ("Signal: "++) - -instance Ord t => Ord (Signal p t) where - compare = unimp "compare" - min = liftA2 min - max = liftA2 max - -instance Enum t => Enum (Signal p t) where - succ = fmap succ - pred = fmap pred - toEnum = pure . toEnum - fromEnum = unimp "fromEnum" - enumFrom = unimp "enumFrom" - enumFromThen = unimp "enumFromThen" - enumFromTo = unimp "enumFromTo" - enumFromThenTo = unimp "enumFromThenTo" - -instance Bounded t => Bounded (Signal p t) where - minBound = pure minBound - maxBound = pure maxBound - -instance Num t => Num (Signal p t) where - (+) = liftA2 (+) - (-) = liftA2 (-) - (*) = liftA2 (*) - signum = fmap signum - abs = fmap abs - negate = fmap negate - fromInteger = pure . fromInteger - -instance Real t => Real (Signal p t) where - toRational = unimp "toRational" - -instance Integral t => Integral (Signal p t) where - quot = liftA2 quot - rem = liftA2 rem - div = liftA2 div - mod = liftA2 mod - quotRem a b = (fst <$> qrab,snd <$> qrab) - where qrab = quotRem <$> a <*> b - divMod a b = (fst <$> dmab,snd <$> dmab) - where dmab = divMod <$> a <*> b - toInteger = unimp "toInteger" - -instance Fractional t => Fractional (Signal p t) where - (/) = liftA2 (/) - recip = fmap recip - fromRational = pure . fromRational - -instance Floating t => Floating (Signal p t) where - pi = pure pi - exp = fmap exp - sqrt = fmap sqrt - log = fmap log - (**) = liftA2 (**) - logBase = liftA2 logBase - sin = fmap sin - tan = fmap tan - cos = fmap cos - asin = fmap asin - atan = fmap atan - acos = fmap acos - sinh = fmap sinh - tanh = fmap tanh - cosh = fmap cosh - asinh = fmap asinh - atanh = fmap atanh - acosh = fmap acosh diff --git a/FRP/Elerea/Experimental/Simple.hs b/FRP/Elerea/Experimental/Simple.hs deleted file mode 100644 --- a/FRP/Elerea/Experimental/Simple.hs +++ /dev/null @@ -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 -() 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 = "" ++ 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 diff --git a/FRP/Elerea/Graph.hs b/FRP/Elerea/Graph.hs deleted file mode 100644 --- a/FRP/Elerea/Graph.hs +++ /dev/null @@ -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 -() dot format. Stateful nodes are coloured -according to their type. - -The results might differ depending on whether this function is called -before or after sampling (this also affects the actual network!), but -the networks should be still equivalent. - --} - -signalToDot :: Signal a -> IO String -signalToDot s = do - (_,st) <- buildStore Map.empty s - let rules = map mkRule (Map.assocs st) - mkRule (id,n) = " " ++ name ++ attrs ++ edges - where name = nodeLabel (Just id) n - attrs = mkLabel (nodeLabel Nothing n) ("style=filled,fillcolor=\"#" ++ nodeCol ++ "\",shape=" ++ nodeShape) - edges = case n of - Transfer s -> mkEdge s "\"\"" - App sf sx -> mkEdge sf "f" ++ mkEdge sx "x" - Sampler ss -> mkEdge ss "\"\"" - Generator b sm -> mkEdge b "ctl" ++ mkEdge sm "gen" - Delay s -> mkEdge s "\"\"" - Lift1 s1 -> mkEdge s1 "x1" - Lift2 s1 s2 -> mkEdge s1 "x1" ++ mkEdge s2 "x2" - Lift3 s1 s2 s3 -> mkEdge s1 "x1" ++ mkEdge s2 "x2" ++ mkEdge s3 "x3" - Lift4 s1 s2 s3 s4 -> mkEdge s1 "x1" ++ mkEdge s2 "x2" ++ mkEdge s3 "x3" ++ mkEdge s4 "x4" - Lift5 s1 s2 s3 s4 s5 -> mkEdge s1 "x1" ++ mkEdge s2 "x2" ++ mkEdge s3 "x3" ++ mkEdge s4 "x4" ++ mkEdge s5 "x5" - _ -> "" - mkEdge endId label = " " ++ name ++ " -> " ++ - nodeLabel (Just endId) (st Map.! endId) ++ - mkLabel label "dir=back" - mkLabel name attrs = " [label=" ++ name ++ "," ++ attrs ++ "];\n" - nodeCol = case n of - Transfer _ -> "ffcc99" - Sampler _ -> "99ccff" - Generator _ _ -> "ccffff" - External -> "ccff99" - Stateful -> "ffffcc" - Delay _ -> "ffccff" - _ -> "ffffff" - nodeShape = case n of - Transfer _ -> "diamond" - Sampler _ -> "hexagon" - Generator _ _ -> "house" - External -> "invtriangle" - Delay _ -> "box" - _ -> "ellipse" - return $ "digraph G {\n" ++ concat rules ++ "}\n" diff --git a/FRP/Elerea/Internal.hs b/FRP/Elerea/Internal.hs deleted file mode 100644 --- a/FRP/Elerea/Internal.hs +++ /dev/null @@ -1,546 +0,0 @@ -{-# LANGUAGE ExistentialQuantification, GeneralizedNewtypeDeriving #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} - -{-| - -This is the core module of Elerea, which contains the signal -implementation and the atomic constructors. - -The basic idea is to create a dataflow network whose structure closely -resembles the user's definitions by turning each combinator into a -mutable variable (an 'IORef'). In other words, each signal is -represented by a variable. Such a variable contains information about -the operation to perform and (depending on the operation) references -to other signals. For instance, a pointwise function application -created by the '<*>' operator contains an 'SNA' node, which holds two -references: one to the function signal and another to the argument -signal. - -In order to have a pure(-looking) applicative interface for the most -part, the library relies on 'unsafePerformIO' to create the references -of stateless signals, while stateful signals have to be obtained from -a special 'SignalMonad', which is just a wrapping of 'IO' that doesn't -allow any other action to be performed. - -The execution of the network is explicitly marked as an IO operation. -The core library exposes a single function to animate the network -called 'superstep', which takes a signal and a time interval, and -mutates all the variables the signal depends on. It is supposed to be -called repeatedly in a loop that also takes care of user input. - -To ensure consistency, a superstep has three phases: sampling, aging -and finalisation. Each signal reachable from the top-level signal -passed to 'superstep' is sampled at the current point of time -('sample'), and the sample is stored along with the old signal in its -reference. If the value of a signal is requested multiple times, the -sample is simply reused. After successfully sampling the top-level -signal, the network is traversed again to advance by the desired time -('advance'), and when that's completed, the finalisation process -throws away the intermediate samples and marks the aged signals as the -current ones, ready to be sampled again. If there is a dependency -loop, the system tries to use the 'sampleDelayed' function instead of -'sample' to get a useful value at the problematic spot instead of -entering an infinite loop. Evaluation is initiated by the -'signalValue' function (which is used in both the sampling and the -aging phase to calculate samples and retrieve the cached values if -they are requested again), aging is performed by 'age', while -finalisation is done by 'commit'. Since these functions are invoked -recursively on a data structure with existential types, their types -also need to be explicity quantified. - -As a bonus, applicative nodes are automatically collapsed into lifted -functions of up to five arguments. This optimisation significantly -reduces the number of nodes in the network. - --} - -module FRP.Elerea.Internal where - -import Control.Applicative -import Control.Monad -import Control.Monad.Fix -import Data.IORef -import System.IO.Unsafe - --- * Implementation - --- ** Some type synonyms - -{-| Time is continuous. Nothing fancy. -} - -type DTime = Double - -{-| Sinks are used when feeding input into peripheral-bound signals. -} - -type Sink a = a -> IO () - --- ** The data structures behind signals - -{-| A restricted monad to create stateful signals in. -} - -newtype SignalMonad a = SM { createSignal :: IO a } deriving (Monad,Applicative,Functor,MonadFix) - -{-| A printing function that can be used in the 'SignalMonad'. -Provided for debugging purposes. -} - -signalDebug :: Show a => a -> SignalMonad () -signalDebug = SM . print - -{-| A signal is conceptually a time-varying value. -} - -newtype Signal a = S (IORef (SignalTrans a)) - -{-| A node can have four states that distinguish various stages of -sampling and aging. -} - -data SignalTrans a - -- | @Ready s@ is simply the signal @s@ that was not sampled yet - = Ready (SignalNode a) - -- | @Sampling s@ is signal @s@ after its current value was - -- requested, but not yet delivered - | Sampling (SignalNode a) - -- | @Sampled x s@ is signal @s@ paired with its current value @x@ - | Sampled a (SignalNode a) - -- | @Aged x s@ is the aged version of signal @s@ paired with its - -- current value @x@ - | Aged a (SignalNode a) - -{-| The possible structures of a node are defined by the 'SignalNode' -type. Note that the @SNFx@ nodes are only needed to optimise -applicatives, they can all be expressed in terms of @SNK@ and -@SNA@. -} - -data SignalNode a - -- | @SNK x@: constantly @x@ - = SNK a - -- | @SNS x t@: stateful generator, where @x@ is current state and - -- @t@ is the update function - | SNS a (DTime -> a -> a) - -- | @SNT s x t@: stateful transfer function, which also depends - -- on an input signal @s@ - | forall t . SNT (Signal t) a (DTime -> t -> a -> a) - -- | @SNA sf sx@: pointwise function application - | forall t . SNA (Signal (t -> a)) (Signal t) - -- | @SNH ss r@: the higher-order signal @ss@ collapsed into a - -- signal cached in reference @r@; @r@ is used during the aging - -- phase - | SNH (Signal (Signal a)) (IORef (Signal a)) - -- | @SNM b sm@: signal generator that executes the monad carried - -- by @sm@ whenever @b@ is true, and outputs the result (or - -- undefined when @b@ is false) - | SNM (Signal Bool) (Signal (SignalMonad a)) - -- | @SNE r@: opaque reference to connect peripherals - | SNE (IORef a) - -- | @SND s@: the @s@ signal delayed by one superstep - | SND a (Signal a) - -- | @SNKA s l@: equivalent to @s@ while aging signal @l@ - | forall t . SNKA (Signal a) (Signal t) - -- | @SNF1 f@: @fmap f@ - | forall t . SNF1 (t -> a) (Signal t) - -- | @SNF2 f@: @liftA2 f@ - | forall t1 t2 . SNF2 (t1 -> t2 -> a) (Signal t1) (Signal t2) - -- | @SNF3 f@: @liftA3 f@ - | forall t1 t2 t3 . SNF3 (t1 -> t2 -> t3 -> a) (Signal t1) (Signal t2) (Signal t3) - -- | @SNF4 f@: @liftA4 f@ - | forall t1 t2 t3 t4 . SNF4 (t1 -> t2 -> t3 -> t4 -> a) (Signal t1) (Signal t2) (Signal t3) (Signal t4) - -- | @SNF5 f@: @liftA5 f@ - | forall t1 t2 t3 t4 t5 . SNF5 (t1 -> t2 -> t3 -> t4 -> t5 -> a) (Signal t1) (Signal t2) (Signal t3) (Signal t4) (Signal t5) - -{-| You can uncomment the verbose version of this function to see the -applicative optimisations in action. -} - -debugLog :: String -> IO a -> IO a ---debugLog s io = putStrLn s >> io -debugLog _ io = io - -instance Functor Signal where - fmap = (<*>) . pure - -{-| The 'Applicative' instance with run-time optimisation. The '<*>' -operator tries to move all the pure parts to its left side in order to -flatten the structure, hence cutting down on book-keeping costs. Since -applicatives are used with pure functions and lifted values most of -the time, one can gain a lot by merging these nodes. -} - -instance Applicative Signal where - -- | A constant signal - pure = makeSignalUnsafe . SNK - -- | Point-wise application of a function and a data signal (like @ZipList@) - --- --mf <*> mx = sampler (fmap (\f -> sampler (fmap (pure . f) mx)) mf) --- sf <*> sx = sampler (makeSignalUnsafe (SNF1 (\f -> sampler (makeSignalUnsafe (SNF1 (pure . f) sx))) sf)) - - f@(S rf) <*> x@(S rx) = unsafePerformIO $ do - -- General fall-back case - c <- newIORef (Ready (SNA f x)) - - let opt s = writeIORef c (Ready s) - - -- Optimisations might go haywire in the presence of loops, - -- so we need to prepare to meeting undefined references by - -- wrapping reads into exception handlers. - - flip catch (const (debugLog "no_fun" $ return ())) $ do - Ready nf <- readIORef rf - - merged <- flip catch (const (debugLog "no_arg" $ return False)) $ do - -- Merging constant branches from the two sides - Ready nx <- readIORef rx - case (nf,nx) of - (SNK g,SNK y) -> debugLog "merge_00" $ opt (SNK (g y)) - (SNK g,SNF1 h y1) -> debugLog "merge_01" $ opt (SNF1 (g.h) y1) - (SNK g,SNF2 h y1 y2) -> debugLog "merge_02" $ opt (SNF2 (\y1 y2 -> g (h y1 y2)) y1 y2) - (SNK g,SNF3 h y1 y2 y3) -> debugLog "merge_03" $ opt (SNF3 (\y1 y2 y3 -> g (h y1 y2 y3)) y1 y2 y3) - (SNK g,SNF4 h y1 y2 y3 y4) -> debugLog "merge_04" $ opt (SNF4 (\y1 y2 y3 y4 -> g (h y1 y2 y3 y4)) y1 y2 y3 y4) - (SNK g,SNF5 h y1 y2 y3 y4 y5) -> debugLog "merge_05" $ opt (SNF5 (\y1 y2 y3 y4 y5 -> g (h y1 y2 y3 y4 y5)) y1 y2 y3 y4 y5) - (SNK g,_) -> debugLog "lift_1x" $ opt (SNF1 g x) - (SNF1 g x1,SNK y) -> debugLog "merge_10" $ opt (SNF1 (\x1 -> g x1 y) x1) - (SNF1 g x1,SNF1 h y1) -> debugLog "merge_11" $ opt (SNF2 (\x1 y1 -> g x1 (h y1)) x1 y1) - (SNF1 g x1,SNF2 h y1 y2) -> debugLog "merge_12" $ opt (SNF3 (\x1 y1 y2 -> g x1 (h y1 y2)) x1 y1 y2) - (SNF1 g x1,SNF3 h y1 y2 y3) -> debugLog "merge_13" $ opt (SNF4 (\x1 y1 y2 y3 -> g x1 (h y1 y2 y3)) x1 y1 y2 y3) - (SNF1 g x1,SNF4 h y1 y2 y3 y4) -> debugLog "merge_14" $ opt (SNF5 (\x1 y1 y2 y3 y4 -> g x1 (h y1 y2 y3 y4)) x1 y1 y2 y3 y4) - (SNF1 g x1,_) -> debugLog "lift_2x" $ opt (SNF2 g x1 x) - (SNF2 g x1 x2,SNK y) -> debugLog "merge_20" $ opt (SNF2 (\x1 x2 -> g x1 x2 y) x1 x2) - (SNF2 g x1 x2,SNF1 h y1) -> debugLog "merge_21" $ opt (SNF3 (\x1 x2 y1 -> g x1 x2 (h y1)) x1 x2 y1) - (SNF2 g x1 x2,SNF2 h y1 y2) -> debugLog "merge_22" $ opt (SNF4 (\x1 x2 y1 y2 -> g x1 x2 (h y1 y2)) x1 x2 y1 y2) - (SNF2 g x1 x2,SNF3 h y1 y2 y3) -> debugLog "merge_23" $ opt (SNF5 (\x1 x2 y1 y2 y3 -> g x1 x2 (h y1 y2 y3)) x1 x2 y1 y2 y3) - (SNF2 g x1 x2,_) -> debugLog "lift_3x" $ opt (SNF3 g x1 x2 x) - (SNF3 g x1 x2 x3,SNK y) -> debugLog "merge_30" $ opt (SNF3 (\x1 x2 x3 -> g x1 x2 x3 y) x1 x2 x3) - (SNF3 g x1 x2 x3,SNF1 h y1) -> debugLog "merge_31" $ opt (SNF4 (\x1 x2 x3 y1 -> g x1 x2 x3 (h y1)) x1 x2 x3 y1) - (SNF3 g x1 x2 x3,SNF2 h y1 y2) -> debugLog "merge_32" $ opt (SNF5 (\x1 x2 x3 y1 y2 -> g x1 x2 x3 (h y1 y2)) x1 x2 x3 y1 y2) - (SNF3 g x1 x2 x3,_) -> debugLog "lift_4x" $ opt (SNF4 g x1 x2 x3 x) - (SNF4 g x1 x2 x3 x4,SNK y) -> debugLog "merge_40" $ opt (SNF4 (\x1 x2 x3 x4 -> g x1 x2 x3 x4 y) x1 x2 x3 x4) - (SNF4 g x1 x2 x3 x4,SNF1 h y1) -> debugLog "merge_41" $ opt (SNF5 (\x1 x2 x3 x4 y1 -> g x1 x2 x3 x4 (h y1)) x1 x2 x3 x4 y1) - (SNF4 g x1 x2 x3 x4,_) -> debugLog "lift_5x" $ opt (SNF5 g x1 x2 x3 x4 x) - (SNF5 g x1 x2 x3 x4 x5,SNK y) -> debugLog "merge_50" $ opt (SNF5 (\x1 x2 x3 x4 x5 -> g x1 x2 x3 x4 x5 y) x1 x2 x3 x4 x5) - _ -> return () - return True - - -- Lifting into higher arity not knowing the argument - when (not merged) $ case nf of - SNK g -> debugLog "lift_1" $ opt (SNF1 g x) - SNF1 g x1 -> debugLog "lift_2" $ opt (SNF2 g x1 x) - SNF2 g x1 x2 -> debugLog "lift_3" $ opt (SNF3 g x1 x2 x) - SNF3 g x1 x2 x3 -> debugLog "lift_4" $ opt (SNF4 g x1 x2 x3 x) - SNF4 g x1 x2 x3 x4 -> debugLog "lift_5" $ opt (SNF5 g x1 x2 x3 x4 x) - _ -> return () - - -- The final version - return (S c) - -{-| The @Show@ instance is only defined for the sake of 'Num'... -} - -instance Show (Signal a) where - showsPrec _ _ s = "" ++ s - -{-| The equality test checks whether two signals are physically the same. -} - -instance Eq (Signal a) where - S s1 == S s2 = s1 == s2 - -{-| Error message for unimplemented instance functions. -} - -unimp :: String -> a -unimp = error . ("Signal: "++) - -instance Ord t => Ord (Signal t) where - compare = unimp "compare" - min = liftA2 min - max = liftA2 max - -instance Enum t => Enum (Signal t) where - succ = fmap succ - pred = fmap pred - toEnum = pure . toEnum - fromEnum = unimp "fromEnum" - enumFrom = unimp "enumFrom" - enumFromThen = unimp "enumFromThen" - enumFromTo = unimp "enumFromTo" - enumFromThenTo = unimp "enumFromThenTo" - -instance Bounded t => Bounded (Signal t) where - minBound = pure minBound - maxBound = pure maxBound - -instance Num t => Num (Signal t) where - (+) = liftA2 (+) - (-) = liftA2 (-) - (*) = liftA2 (*) - signum = fmap signum - abs = fmap abs - negate = fmap negate - fromInteger = pure . fromInteger - -instance Real t => Real (Signal t) where - toRational = unimp "toRational" - -instance Integral t => Integral (Signal t) where - quot = liftA2 quot - rem = liftA2 rem - div = liftA2 div - mod = liftA2 mod - quotRem a b = (fst <$> qrab,snd <$> qrab) - where qrab = quotRem <$> a <*> b - divMod a b = (fst <$> dmab,snd <$> dmab) - where dmab = divMod <$> a <*> b - toInteger = unimp "toInteger" - -instance Fractional t => Fractional (Signal t) where - (/) = liftA2 (/) - recip = fmap recip - fromRational = pure . fromRational - -instance Floating t => Floating (Signal t) where - pi = pure pi - exp = fmap exp - sqrt = fmap sqrt - log = fmap log - (**) = liftA2 (**) - logBase = liftA2 logBase - sin = fmap sin - tan = fmap tan - cos = fmap cos - asin = fmap asin - atan = fmap atan - acos = fmap acos - sinh = fmap sinh - tanh = fmap tanh - cosh = fmap cosh - asinh = fmap asinh - atanh = fmap atanh - acosh = fmap acosh - --- ** Internal functions to run the network - -{-| Creating a reference within the 'SignalMonad'. Used for stateful -signals. -} - -makeSignal :: SignalNode a -> SignalMonad (Signal a) -makeSignal node = SM $ do - ref <- newIORef (Ready node) - return (S ref) - -{-| Creating a reference as a pure value. Used for stateless -signals. -} - -makeSignalUnsafe :: SignalNode a -> Signal a -makeSignalUnsafe = S . unsafePerformIO . newIORef . Ready - -{-| Sampling the signal and all of its dependencies, at the same time. -We don't need the aged signal in the current superstep, only the -current value, so we sample before propagating the changes, which -might require the fresh sample because of recursive definitions. -} - -signalValue :: forall a . Signal a -> DTime -> IO a -signalValue (S r) dt = do - t <- readIORef r - case t of - Ready s -> do writeIORef r (Sampling s) - -- TODO: advance can be evaluated in a separate - -- thread, since we don't need its result right - -- away, only in the next superstep. - v <- sample s dt - -- We memorise the sample to handle loops - -- nicely. The undefined future signal cannot - -- bite us, because we don't need it during the - -- evaluation phase. - writeIORef r (Sampled v s) - return v - Sampling s -> do -- We started sampling this already, so there is - -- a dependency cycle we have to resolve by - -- adding a delay to stateful signals. Stateless - -- signals should not form a loop, which is - -- obvious... - v <- sampleDelayed s dt - writeIORef r (Sampled v s) - -- Since we are sampling it already, this node - -- will be overwritten by the case above when - -- the loop is closed. - return v - Sampled v _ -> return v - Aged v _ -> return v - -{-| Aging the network of signals the given signal depends on. -} - -age :: forall a . Signal a -> DTime -> IO () -age (S r) dt = do - t <- readIORef r - case t of - Sampled v s -> do s' <- advance s v dt - writeIORef r (Aged v s') - -- TODO: branching can be trivially parallelised - case s' of - SNT s _ _ -> age s dt - SNA sf sx -> age sf dt >> age sx dt - SNH ss r -> age ss dt >> readIORef r >>= \s -> age s dt - SNM b sm -> age b dt >> age sm dt - SND _ s -> age s dt - SNKA s l -> age s dt >> age l dt - SNF1 _ s -> age s dt - SNF2 _ s1 s2 -> age s1 dt >> age s2 dt - SNF3 _ s1 s2 s3 -> age s1 dt >> age s2 dt >> age s3 dt - SNF4 _ s1 s2 s3 s4 -> age s1 dt >> age s2 dt >> age s3 dt >> age s4 dt - SNF5 _ s1 s2 s3 s4 s5 -> age s1 dt >> age s2 dt >> age s3 dt >> age s4 dt >> age s5 dt - _ -> return () - Aged _ _ -> return () - _ -> error "Inconsistent state: signal not sampled properly!" - -{-| Finalising aged signals for the next round. -} - -commit :: forall a . Signal a -> IO () -commit (S r) = do - t <- readIORef r - case t of - Aged _ s -> do writeIORef r (Ready s) - -- TODO: branching can be trivially parallelised - case s of - SNT s _ _ -> commit s - SNA sf sx -> commit sf >> commit sx - SNH ss r -> commit ss >> readIORef r >>= \s -> commit s - SNM b sm -> commit b >> commit sm - SND _ s -> commit s - SNKA s l -> commit s >> commit l - SNF1 _ s -> commit s - SNF2 _ s1 s2 -> commit s1 >> commit s2 - SNF3 _ s1 s2 s3 -> commit s1 >> commit s2 >> commit s3 - SNF4 _ s1 s2 s3 s4 -> commit s1 >> commit s2 >> commit s3 >> commit s4 - SNF5 _ s1 s2 s3 s4 s5 -> commit s1 >> commit s2 >> commit s3 >> commit s4 >> commit s5 - _ -> return () - Ready _ -> return () - _ -> error "Inconsistent state: signal not aged properly!" - -{-| Aging the signal. Stateful signals have their state forced to -prevent building up big thunks. The other nodes are structurally -static. -} - -advance :: SignalNode a -> a -> DTime -> IO (SignalNode a) -advance (SNS x f) _ dt = x `seq` return (SNS (f dt x) f) -advance (SNT s _ f) v _ = v `seq` return (SNT s v f) -advance (SND _ s) _ dt = do x <- signalValue s dt - return (SND x s) -advance s _ _ = return s - -{-| Sampling the signal at the current moment. This is where static -nodes propagate changes to those they depend on. Transfer functions -('SNT') work without delay, i.e. the effects of their input signals -can be observed in the same superstep. -} - -sample :: SignalNode a -> DTime -> IO a -sample (SNK x) _ = return x -sample (SNS x _) _ = return x -sample (SNT s x f) dt = do t <- signalValue s dt - return $! f dt t x -sample (SNA sf sx) dt = signalValue sf dt <*> signalValue sx dt -sample (SNH ss r) dt = do s <- signalValue ss dt - writeIORef r s - signalValue s dt -sample (SNM b sm) dt = do c <- signalValue b dt - SM m <- signalValue sm dt - if c then m else return undefined -sample (SNE r) _ = readIORef r -sample (SND v _) _ = return v -sample (SNKA s l) dt = do signalValue l dt - signalValue s dt -sample (SNF1 f s) dt = f <$> signalValue s dt -sample (SNF2 f s1 s2) dt = liftM2 f (signalValue s1 dt) (signalValue s2 dt) -sample (SNF3 f s1 s2 s3) dt = liftM3 f (signalValue s1 dt) (signalValue s2 dt) (signalValue s3 dt) -sample (SNF4 f s1 s2 s3 s4) dt = liftM4 f (signalValue s1 dt) (signalValue s2 dt) (signalValue s3 dt) (signalValue s4 dt) -sample (SNF5 f s1 s2 s3 s4 s5) dt = liftM5 f (signalValue s1 dt) (signalValue s2 dt) (signalValue s3 dt) (signalValue s4 dt) (signalValue s5 dt) - -{-| Sampling the signal with some kind of delay in order to resolve -dependency loops. Transfer functions simply return their previous -output (delays can be considered a special case, because they always -do that, so 'sampleDelayed' is never called with them), while other -types of signals are always handled by the 'sample' function, so it is -not possible to create a working stateful loop composed of solely -stateless combinators. -} - -sampleDelayed :: SignalNode a -> DTime -> IO a -sampleDelayed (SNT _ x _) _ = return x -sampleDelayed sn dt = sample sn dt - --- ** Userland combinators - -{-| Advancing the whole network that the given signal depends on by -the amount of time given in the second argument. -} - -superstep :: Signal a -- ^ the top-level signal - -> DTime -- ^ the amount of time to advance - -> IO a -- ^ the current value of the signal -superstep world dt = do - snapshot <- signalValue world dt - age world dt - commit world - return snapshot - -{-| A pure stateful signal. The initial state is the first output. -} - -stateful :: a -- ^ initial state - -> (DTime -> a -> a) -- ^ state transformation - -> SignalMonad (Signal a) -stateful x0 f = makeSignal (SNS x0 f) - -{-| A stateful transfer function. The current input affects the -current output, i.e. the initial state given in the first argument is -considered to appear before the first output, and can only be directly -observed by the `sampleDelayed` function. -} - -transfer :: a -- ^ initial internal state - -> (DTime -> t -> a -> a) -- ^ state updater function - -> Signal t -- ^ input signal - -> SignalMonad (Signal a) -transfer x0 f s = makeSignal (SNT s x0 f) - -{-| A continuous sampler that flattens a higher-order signal by -outputting its current snapshots. -} - -sampler :: Signal (Signal a) -- ^ signal to flatten - -> Signal a -sampler ss = makeSignalUnsafe (SNH ss (unsafePerformIO (newIORef undefined))) - -{-| A reactive signal that takes the value to output from a monad -carried by its input when a boolean control signal is true, otherwise -it outputs 'Nothing'. It is possible to create new signals in the -monad and also to print debug messages. -} - -generator :: Signal Bool -- ^ control (trigger) signal - -> Signal (SignalMonad a) -- ^ a stream of monads to potentially run - -> Signal (Maybe a) -generator b sm = toMaybe <$> b <*> makeSignalUnsafe (SNM b sm) - -{-| A helper function to wrap any value in a 'Maybe' depending on a -boolean condition. -} - -toMaybe :: Bool -> a -> Maybe a -toMaybe c v = if c then Just v else Nothing - -{-| A signal that can be directly fed through the sink function -returned. This can be used to attach the network to the outer -world. -} - -external :: a -- ^ initial value - -> IO (Signal a, Sink a) -- ^ the signal and an IO function to feed it -external x0 = do - ref <- newIORef x0 - snr <- newIORef (Ready (SNE ref)) - return (S snr,writeIORef ref) - -{-| The `delay` transfer function emits the value of a signal from the -previous superstep, starting with the filler value given in the first -argument. It has to be a primitive, otherwise it could not be used to -prevent automatic delays. -} - -delay :: a -- ^ initial output - -> Signal a -- ^ the signal to delay - -> SignalMonad (Signal a) -delay x0 s = makeSignal (SND x0 s) - -{-| Dependency injection to allow aging signals whose output is not -necessarily needed to produce the current sample of the first -argument. It's equivalent to @(flip . liftA2 . flip) const@, as it -evaluates its second argument first. -} - -keepAlive :: Signal a -- ^ the actual output - -> Signal t -- ^ a signal guaranteed to age when this one is sampled - -> Signal a -keepAlive s l = makeSignalUnsafe (SNKA s l) diff --git a/FRP/Elerea/Legacy.hs b/FRP/Elerea/Legacy.hs new file mode 100644 --- /dev/null +++ b/FRP/Elerea/Legacy.hs @@ -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 (&&) diff --git a/FRP/Elerea/Legacy/Graph.hs b/FRP/Elerea/Legacy/Graph.hs new file mode 100644 --- /dev/null +++ b/FRP/Elerea/Legacy/Graph.hs @@ -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 +() dot format. Stateful nodes are coloured +according to their type. + +The results might differ depending on whether this function is called +before or after sampling (this also affects the actual network!), but +the networks should be still equivalent. + +-} + +signalToDot :: Signal a -> IO String +signalToDot s = do + (_,st) <- buildStore Map.empty s + let rules = map mkRule (Map.assocs st) + mkRule (id,n) = " " ++ name ++ attrs ++ edges + where name = nodeLabel (Just id) n + attrs = mkLabel (nodeLabel Nothing n) ("style=filled,fillcolor=\"#" ++ nodeCol ++ "\",shape=" ++ nodeShape) + edges = case n of + Transfer s -> mkEdge s "\"\"" + App sf sx -> mkEdge sf "f" ++ mkEdge sx "x" + Sampler ss -> mkEdge ss "\"\"" + Generator b sm -> mkEdge b "ctl" ++ mkEdge sm "gen" + Delay s -> mkEdge s "\"\"" + Lift1 s1 -> mkEdge s1 "x1" + Lift2 s1 s2 -> mkEdge s1 "x1" ++ mkEdge s2 "x2" + Lift3 s1 s2 s3 -> mkEdge s1 "x1" ++ mkEdge s2 "x2" ++ mkEdge s3 "x3" + Lift4 s1 s2 s3 s4 -> mkEdge s1 "x1" ++ mkEdge s2 "x2" ++ mkEdge s3 "x3" ++ mkEdge s4 "x4" + Lift5 s1 s2 s3 s4 s5 -> mkEdge s1 "x1" ++ mkEdge s2 "x2" ++ mkEdge s3 "x3" ++ mkEdge s4 "x4" ++ mkEdge s5 "x5" + _ -> "" + mkEdge endId label = " " ++ name ++ " -> " ++ + nodeLabel (Just endId) (st Map.! endId) ++ + mkLabel label "dir=back" + mkLabel name attrs = " [label=" ++ name ++ "," ++ attrs ++ "];\n" + nodeCol = case n of + Transfer _ -> "ffcc99" + Sampler _ -> "99ccff" + Generator _ _ -> "ccffff" + External -> "ccff99" + Stateful -> "ffffcc" + Delay _ -> "ffccff" + _ -> "ffffff" + nodeShape = case n of + Transfer _ -> "diamond" + Sampler _ -> "hexagon" + Generator _ _ -> "house" + External -> "invtriangle" + Delay _ -> "box" + _ -> "ellipse" + return $ "digraph G {\n" ++ concat rules ++ "}\n" diff --git a/FRP/Elerea/Legacy/Internal.hs b/FRP/Elerea/Legacy/Internal.hs new file mode 100644 --- /dev/null +++ b/FRP/Elerea/Legacy/Internal.hs @@ -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 = "" ++ s + +{-| The equality test checks whether two signals are physically the same. -} + +instance Eq (Signal a) where + S s1 == S s2 = s1 == s2 + +{-| Error message for unimplemented instance functions. -} + +unimp :: String -> a +unimp = error . ("Signal: "++) + +instance Ord t => Ord (Signal t) where + compare = unimp "compare" + min = liftA2 min + max = liftA2 max + +instance Enum t => Enum (Signal t) where + succ = fmap succ + pred = fmap pred + toEnum = pure . toEnum + fromEnum = unimp "fromEnum" + enumFrom = unimp "enumFrom" + enumFromThen = unimp "enumFromThen" + enumFromTo = unimp "enumFromTo" + enumFromThenTo = unimp "enumFromThenTo" + +instance Bounded t => Bounded (Signal t) where + minBound = pure minBound + maxBound = pure maxBound + +instance Num t => Num (Signal t) where + (+) = liftA2 (+) + (-) = liftA2 (-) + (*) = liftA2 (*) + signum = fmap signum + abs = fmap abs + negate = fmap negate + fromInteger = pure . fromInteger + +instance Real t => Real (Signal t) where + toRational = unimp "toRational" + +instance Integral t => Integral (Signal t) where + quot = liftA2 quot + rem = liftA2 rem + div = liftA2 div + mod = liftA2 mod + quotRem a b = (fst <$> qrab,snd <$> qrab) + where qrab = quotRem <$> a <*> b + divMod a b = (fst <$> dmab,snd <$> dmab) + where dmab = divMod <$> a <*> b + toInteger = unimp "toInteger" + +instance Fractional t => Fractional (Signal t) where + (/) = liftA2 (/) + recip = fmap recip + fromRational = pure . fromRational + +instance Floating t => Floating (Signal t) where + pi = pure pi + exp = fmap exp + sqrt = fmap sqrt + log = fmap log + (**) = liftA2 (**) + logBase = liftA2 logBase + sin = fmap sin + tan = fmap tan + cos = fmap cos + asin = fmap asin + atan = fmap atan + acos = fmap acos + sinh = fmap sinh + tanh = fmap tanh + cosh = fmap cosh + asinh = fmap asinh + atanh = fmap atanh + acosh = fmap acosh + +-- ** Internal functions to run the network + +{-| Creating a reference within the 'SignalMonad'. Used for stateful +signals. -} + +makeSignal :: SignalNode a -> SignalMonad (Signal a) +makeSignal node = SM $ do + ref <- newIORef (Ready node) + return (S ref) + +{-| Creating a reference as a pure value. Used for stateless +signals. -} + +makeSignalUnsafe :: SignalNode a -> Signal a +makeSignalUnsafe = S . unsafePerformIO . newIORef . Ready + +{-| Sampling the signal and all of its dependencies, at the same time. +We don't need the aged signal in the current superstep, only the +current value, so we sample before propagating the changes, which +might require the fresh sample because of recursive definitions. -} + +signalValue :: forall a . Signal a -> DTime -> IO a +signalValue (S r) dt = do + t <- readIORef r + case t of + Ready s -> do writeIORef r (Sampling s) + -- TODO: advance can be evaluated in a separate + -- thread, since we don't need its result right + -- away, only in the next superstep. + v <- sample s dt + -- We memorise the sample to handle loops + -- nicely. The undefined future signal cannot + -- bite us, because we don't need it during the + -- evaluation phase. + writeIORef r (Sampled v s) + return v + Sampling s -> do -- We started sampling this already, so there is + -- a dependency cycle we have to resolve by + -- adding a delay to stateful signals. Stateless + -- signals should not form a loop, which is + -- obvious... + v <- sampleDelayed s dt + writeIORef r (Sampled v s) + -- Since we are sampling it already, this node + -- will be overwritten by the case above when + -- the loop is closed. + return v + Sampled v _ -> return v + Aged v _ -> return v + +{-| Aging the network of signals the given signal depends on. -} + +age :: forall a . Signal a -> DTime -> IO () +age (S r) dt = do + t <- readIORef r + case t of + Sampled v s -> do s' <- advance s v dt + writeIORef r (Aged v s') + -- TODO: branching can be trivially parallelised + case s' of + SNT s _ _ -> age s dt + SNA sf sx -> age sf dt >> age sx dt + SNH ss r -> age ss dt >> readIORef r >>= \s -> age s dt + SNM b sm -> age b dt >> age sm dt + SND _ s -> age s dt + SNKA s l -> age s dt >> age l dt + SNF1 _ s -> age s dt + SNF2 _ s1 s2 -> age s1 dt >> age s2 dt + SNF3 _ s1 s2 s3 -> age s1 dt >> age s2 dt >> age s3 dt + SNF4 _ s1 s2 s3 s4 -> age s1 dt >> age s2 dt >> age s3 dt >> age s4 dt + SNF5 _ s1 s2 s3 s4 s5 -> age s1 dt >> age s2 dt >> age s3 dt >> age s4 dt >> age s5 dt + _ -> return () + Aged _ _ -> return () + _ -> error "Inconsistent state: signal not sampled properly!" + +{-| Finalising aged signals for the next round. -} + +commit :: forall a . Signal a -> IO () +commit (S r) = do + t <- readIORef r + case t of + Aged _ s -> do writeIORef r (Ready s) + -- TODO: branching can be trivially parallelised + case s of + SNT s _ _ -> commit s + SNA sf sx -> commit sf >> commit sx + SNH ss r -> commit ss >> readIORef r >>= \s -> commit s + SNM b sm -> commit b >> commit sm + SND _ s -> commit s + SNKA s l -> commit s >> commit l + SNF1 _ s -> commit s + SNF2 _ s1 s2 -> commit s1 >> commit s2 + SNF3 _ s1 s2 s3 -> commit s1 >> commit s2 >> commit s3 + SNF4 _ s1 s2 s3 s4 -> commit s1 >> commit s2 >> commit s3 >> commit s4 + SNF5 _ s1 s2 s3 s4 s5 -> commit s1 >> commit s2 >> commit s3 >> commit s4 >> commit s5 + _ -> return () + Ready _ -> return () + _ -> error "Inconsistent state: signal not aged properly!" + +{-| Aging the signal. Stateful signals have their state forced to +prevent building up big thunks. The other nodes are structurally +static. -} + +advance :: SignalNode a -> a -> DTime -> IO (SignalNode a) +advance (SNS x f) _ dt = x `seq` return (SNS (f dt x) f) +advance (SNT s _ f) v _ = v `seq` return (SNT s v f) +advance (SND _ s) _ dt = do x <- signalValue s dt + return (SND x s) +advance s _ _ = return s + +{-| Sampling the signal at the current moment. This is where static +nodes propagate changes to those they depend on. Transfer functions +('SNT') work without delay, i.e. the effects of their input signals +can be observed in the same superstep. -} + +sample :: SignalNode a -> DTime -> IO a +sample (SNK x) _ = return x +sample (SNS x _) _ = return x +sample (SNT s x f) dt = do t <- signalValue s dt + return $! f dt t x +sample (SNA sf sx) dt = signalValue sf dt <*> signalValue sx dt +sample (SNH ss r) dt = do s <- signalValue ss dt + writeIORef r s + signalValue s dt +sample (SNM b sm) dt = do c <- signalValue b dt + SM m <- signalValue sm dt + if c then m else return undefined +sample (SNE r) _ = readIORef r +sample (SND v _) _ = return v +sample (SNKA s l) dt = do _ <- signalValue l dt + signalValue s dt +sample (SNF1 f s) dt = f <$> signalValue s dt +sample (SNF2 f s1 s2) dt = liftM2 f (signalValue s1 dt) (signalValue s2 dt) +sample (SNF3 f s1 s2 s3) dt = liftM3 f (signalValue s1 dt) (signalValue s2 dt) (signalValue s3 dt) +sample (SNF4 f s1 s2 s3 s4) dt = liftM4 f (signalValue s1 dt) (signalValue s2 dt) (signalValue s3 dt) (signalValue s4 dt) +sample (SNF5 f s1 s2 s3 s4 s5) dt = liftM5 f (signalValue s1 dt) (signalValue s2 dt) (signalValue s3 dt) (signalValue s4 dt) (signalValue s5 dt) + +{-| Sampling the signal with some kind of delay in order to resolve +dependency loops. Transfer functions simply return their previous +output (delays can be considered a special case, because they always +do that, so 'sampleDelayed' is never called with them), while other +types of signals are always handled by the 'sample' function, so it is +not possible to create a working stateful loop composed of solely +stateless combinators. -} + +sampleDelayed :: SignalNode a -> DTime -> IO a +sampleDelayed (SNT _ x _) _ = return x +sampleDelayed sn dt = sample sn dt + +-- ** Userland combinators + +{-| Advancing the whole network that the given signal depends on by +the amount of time given in the second argument. -} + +superstep :: Signal a -- ^ the top-level signal + -> DTime -- ^ the amount of time to advance + -> IO a -- ^ the current value of the signal +superstep world dt = do + snapshot <- signalValue world dt + age world dt + commit world + return snapshot + +{-| A pure stateful signal. The initial state is the first output. -} + +stateful :: a -- ^ initial state + -> (DTime -> a -> a) -- ^ state transformation + -> SignalMonad (Signal a) +stateful x0 f = makeSignal (SNS x0 f) + +{-| A stateful transfer function. The current input affects the +current output, i.e. the initial state given in the first argument is +considered to appear before the first output, and can only be directly +observed by the `sampleDelayed` function. -} + +transfer :: a -- ^ initial internal state + -> (DTime -> t -> a -> a) -- ^ state updater function + -> Signal t -- ^ input signal + -> SignalMonad (Signal a) +transfer x0 f s = makeSignal (SNT s x0 f) + +{-| A continuous sampler that flattens a higher-order signal by +outputting its current snapshots. -} + +sampler :: Signal (Signal a) -- ^ signal to flatten + -> Signal a +sampler ss = makeSignalUnsafe (SNH ss (unsafePerformIO (newIORef undefined))) + +{-| A reactive signal that takes the value to output from a monad +carried by its input when a boolean control signal is true, otherwise +it outputs 'Nothing'. It is possible to create new signals in the +monad and also to print debug messages. -} + +generator :: Signal Bool -- ^ control (trigger) signal + -> Signal (SignalMonad a) -- ^ a stream of monads to potentially run + -> Signal (Maybe a) +generator b sm = toMaybe <$> b <*> makeSignalUnsafe (SNM b sm) + +{-| A helper function to wrap any value in a 'Maybe' depending on a +boolean condition. -} + +toMaybe :: Bool -> a -> Maybe a +toMaybe c v = if c then Just v else Nothing + +{-| A signal that can be directly fed through the sink function +returned. This can be used to attach the network to the outer +world. -} + +external :: a -- ^ initial value + -> IO (Signal a, Sink a) -- ^ the signal and an IO function to feed it +external x0 = do + ref <- newIORef x0 + snr <- newIORef (Ready (SNE ref)) + return (S snr,writeIORef ref) + +{-| The `delay` transfer function emits the value of a signal from the +previous superstep, starting with the filler value given in the first +argument. It has to be a primitive, otherwise it could not be used to +prevent automatic delays. -} + +delay :: a -- ^ initial output + -> Signal a -- ^ the signal to delay + -> SignalMonad (Signal a) +delay x0 s = makeSignal (SND x0 s) + +{-| Dependency injection to allow aging signals whose output is not +necessarily needed to produce the current sample of the first +argument. It's equivalent to @(flip . liftA2 . flip) const@, as it +evaluates its second argument first. -} + +keepAlive :: Signal a -- ^ the actual output + -> Signal t -- ^ a signal guaranteed to age when this one is sampled + -> Signal a +keepAlive s l = makeSignalUnsafe (SNKA s l) diff --git a/FRP/Elerea/Param.hs b/FRP/Elerea/Param.hs new file mode 100644 --- /dev/null +++ b/FRP/Elerea/Param.hs @@ -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 = "" ++ s + +-- | Equality test is impossible. +instance Eq (Signal p a) where + _ == _ = False + +-- | Error message for unimplemented instance functions. +unimp :: String -> a +unimp = error . ("Signal: "++) + +instance Ord t => Ord (Signal p t) where + compare = unimp "compare" + min = liftA2 min + max = liftA2 max + +instance Enum t => Enum (Signal p t) where + succ = fmap succ + pred = fmap pred + toEnum = pure . toEnum + fromEnum = unimp "fromEnum" + enumFrom = unimp "enumFrom" + enumFromThen = unimp "enumFromThen" + enumFromTo = unimp "enumFromTo" + enumFromThenTo = unimp "enumFromThenTo" + +instance Bounded t => Bounded (Signal p t) where + minBound = pure minBound + maxBound = pure maxBound + +instance Num t => Num (Signal p t) where + (+) = liftA2 (+) + (-) = liftA2 (-) + (*) = liftA2 (*) + signum = fmap signum + abs = fmap abs + negate = fmap negate + fromInteger = pure . fromInteger + +instance Real t => Real (Signal p t) where + toRational = unimp "toRational" + +instance Integral t => Integral (Signal p t) where + quot = liftA2 quot + rem = liftA2 rem + div = liftA2 div + mod = liftA2 mod + quotRem a b = (fst <$> qrab,snd <$> qrab) + where qrab = quotRem <$> a <*> b + divMod a b = (fst <$> dmab,snd <$> dmab) + where dmab = divMod <$> a <*> b + toInteger = unimp "toInteger" + +instance Fractional t => Fractional (Signal p t) where + (/) = liftA2 (/) + recip = fmap recip + fromRational = pure . fromRational + +instance Floating t => Floating (Signal p t) where + pi = pure pi + exp = fmap exp + sqrt = fmap sqrt + log = fmap log + (**) = liftA2 (**) + logBase = liftA2 logBase + sin = fmap sin + tan = fmap tan + cos = fmap cos + asin = fmap asin + atan = fmap atan + acos = fmap acos + sinh = fmap sinh + tanh = fmap tanh + cosh = fmap cosh + asinh = fmap asinh + atanh = fmap atanh + acosh = fmap acosh diff --git a/FRP/Elerea/Simple.hs b/FRP/Elerea/Simple.hs new file mode 100644 --- /dev/null +++ b/FRP/Elerea/Simple.hs @@ -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 +() 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 = "" ++ 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 diff --git a/elerea.cabal b/elerea.cabal --- a/elerea.cabal +++ b/elerea.cabal @@ -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