diff --git a/FRP/Elerea.hs b/FRP/Elerea.hs new file mode 100644 --- /dev/null +++ b/FRP/Elerea.hs @@ -0,0 +1,43 @@ +{-| + +Elerea (Eventless Reactivity) is a simplistic FRP implementation that +parts with the concept of events, and uses a continuous latching +construct instead. The user sees the functionality through an +applicative interface, which is used to build up a network of +interconnected mutable references. The network is executed +iteratively, where each superstep consists of two 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 = integral 0 cosine + cosine = integral 1 (-sine) +@ + +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. + +-} + +module FRP.Elerea ( + Time, DTime, + Sink, + Signal, + superstep, + time, + stateless, + stateful, + transfer, + latcher, + external +) where + +import FRP.Elerea.Internal diff --git a/FRP/Elerea/Internal.hs b/FRP/Elerea/Internal.hs new file mode 100644 --- /dev/null +++ b/FRP/Elerea/Internal.hs @@ -0,0 +1,381 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +{-| + +This is the core module of Elerea, which contains the signal +implementation and the primitive 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, the library +relies on 'unsafePerformIO' to create the references on demand. In +contrast, 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 two phases: evaluation and +finalisation. During evaluation, each signal affected is sampled at +the current point of time ('sample'), advanced by the desired time +('advance'), and both of these pieces of data are stored in its +reference. If the value of a signal is requested multiple times, the +sample is simply reused, and no further aging is performed. After +successfully sampling the top-level signal, the finalisation process +throws away the intermediate samples and marks the aged signals as the +current ones, ready to be sampled again. Evaluation is done by the +'signalValue' function, 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 Data.IORef +import System.IO.Unsafe + +-- * Implementation + +-- ** Some type synonyms + +{-| Time is continuous. Nothing fancy. -} + +type Time = Double + +type DTime = Double + +{-| Sinks are used when feeding input into peripheral-bound signals. -} + +type Sink a = a -> IO () + +-- ** The data structures behind signals + +{-| A signal is represented as a /transactional/ structural node. -} + +newtype Signal a = S (IORef (SignalTrans a)) + +{-| A node can have two states: stable (freshly created or finalised) +or mutating (in the process of aging). -} + +data SignalTrans a + -- | @Cur s@ is simply the signal @s@ + = Cur (SignalNode a) + -- | @Tra x s@ is an already sampled signal, where @x@ is the + -- current value and @s@ is the new version of the signal + | Tra a (SignalNode a) + +{-| The possible structures of a node are defined by the 'SignalNode' +type. Note that the @SNLx@ 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 + -- | @SNF f@: time function @f@ (absolute time) + | SNF (Time -> 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) + -- | @SNE s e ss@: latcher that starts out as @s@ and becomes the + -- current value of @ss@ at every moment when @e@ is true + | SNE (Signal a) (Signal Bool) (Signal (Signal a)) + -- | @SNR r@: opaque reference to connect peripherals + | SNR (IORef a) + -- | @SNL1 f@: @fmap f@ + | forall t . SNL1 (t -> a) (Signal t) + -- | @SNL2 f@: @liftA2 f@ + | forall t1 t2 . SNL2 (t1 -> t2 -> a) (Signal t1) (Signal t2) + -- | @SNL3 f@: @liftA3 f@ + | forall t1 t2 t3 . SNL3 (t1 -> t2 -> t3 -> a) (Signal t1) (Signal t2) (Signal t3) + -- | @SNL4 f@: @liftA4 f@ + | forall t1 t2 t3 t4 . SNL4 (t1 -> t2 -> t3 -> t4 -> a) (Signal t1) (Signal t2) (Signal t3) (Signal t4) + -- | @SNL5 f@: @liftA5 f@ + | forall t1 t2 t3 t4 t5 . SNL5 (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 = createSignal . SNK + -- | Point-wise application of a function and a data signal (like @ZipList@) + f@(S rf) <*> x@(S rx) = unsafePerformIO $ do + -- General fall-back case + c <- newIORef (Cur (SNA f x)) + + let opt s = writeIORef c (Cur 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 (return ())) $ do + Cur nf <- readIORef rf + + merged <- flip catch (const (return False)) $ do + -- Merging constant branches from the two sides + Cur nx <- readIORef rx + case (nf,nx) of + (SNK g,SNK y) -> debugLog "merge_00" $ opt (SNK (g y)) + (SNK g,SNL1 h y1) -> debugLog "merge_01" $ opt (SNL1 (g.h) y1) + (SNK g,SNL2 h y1 y2) -> debugLog "merge_02" $ opt (SNL2 (\y1 y2 -> g (h y1 y2)) y1 y2) + (SNK g,SNL3 h y1 y2 y3) -> debugLog "merge_03" $ opt (SNL3 (\y1 y2 y3 -> g (h y1 y2 y3)) y1 y2 y3) + (SNK g,SNL4 h y1 y2 y3 y4) -> debugLog "merge_04" $ opt (SNL4 (\y1 y2 y3 y4 -> g (h y1 y2 y3 y4)) y1 y2 y3 y4) + (SNK g,SNL5 h y1 y2 y3 y4 y5) -> debugLog "merge_05" $ opt (SNL5 (\y1 y2 y3 y4 y5 -> g (h y1 y2 y3 y4 y5)) y1 y2 y3 y4 y5) + (SNK g,_) -> debugLog "lift_1x" $ opt (SNL1 g x) + (SNL1 g x1,SNK y) -> debugLog "merge_10" $ opt (SNL1 (\x1 -> g x1 y) x1) + (SNL1 g x1,SNL1 h y1) -> debugLog "merge_11" $ opt (SNL2 (\x1 y1 -> g x1 (h y1)) x1 y1) + (SNL1 g x1,SNL2 h y1 y2) -> debugLog "merge_12" $ opt (SNL3 (\x1 y1 y2 -> g x1 (h y1 y2)) x1 y1 y2) + (SNL1 g x1,SNL3 h y1 y2 y3) -> debugLog "merge_13" $ opt (SNL4 (\x1 y1 y2 y3 -> g x1 (h y1 y2 y3)) x1 y1 y2 y3) + (SNL1 g x1,SNL4 h y1 y2 y3 y4) -> debugLog "merge_14" $ opt (SNL5 (\x1 y1 y2 y3 y4 -> g x1 (h y1 y2 y3 y4)) x1 y1 y2 y3 y4) + (SNL1 g x1,_) -> debugLog "lift_2x" $ opt (SNL2 g x1 x) + (SNL2 g x1 x2,SNK y) -> debugLog "merge_20" $ opt (SNL2 (\x1 x2 -> g x1 x2 y) x1 x2) + (SNL2 g x1 x2,SNL1 h y1) -> debugLog "merge_21" $ opt (SNL3 (\x1 x2 y1 -> g x1 x2 (h y1)) x1 x2 y1) + (SNL2 g x1 x2,SNL2 h y1 y2) -> debugLog "merge_22" $ opt (SNL4 (\x1 x2 y1 y2 -> g x1 x2 (h y1 y2)) x1 x2 y1 y2) + (SNL2 g x1 x2,SNL3 h y1 y2 y3) -> debugLog "merge_23" $ opt (SNL5 (\x1 x2 y1 y2 y3 -> g x1 x2 (h y1 y2 y3)) x1 x2 y1 y2 y3) + (SNL2 g x1 x2,_) -> debugLog "lift_3x" $ opt (SNL3 g x1 x2 x) + (SNL3 g x1 x2 x3,SNK y) -> debugLog "merge_30" $ opt (SNL3 (\x1 x2 x3 -> g x1 x2 x3 y) x1 x2 x3) + (SNL3 g x1 x2 x3,SNL1 h y1) -> debugLog "merge_31" $ opt (SNL4 (\x1 x2 x3 y1 -> g x1 x2 x3 (h y1)) x1 x2 x3 y1) + (SNL3 g x1 x2 x3,SNL2 h y1 y2) -> debugLog "merge_32" $ opt (SNL5 (\x1 x2 x3 y1 y2 -> g x1 x2 x3 (h y1 y2)) x1 x2 x3 y1 y2) + (SNL3 g x1 x2 x3,_) -> debugLog "lift_4x" $ opt (SNL4 g x1 x2 x3 x) + (SNL4 g x1 x2 x3 x4,SNK y) -> debugLog "merge_40" $ opt (SNL4 (\x1 x2 x3 x4 -> g x1 x2 x3 x4 y) x1 x2 x3 x4) + (SNL4 g x1 x2 x3 x4,SNL1 h y1) -> debugLog "merge_41" $ opt (SNL5 (\x1 x2 x3 x4 y1 -> g x1 x2 x3 x4 (h y1)) x1 x2 x3 x4 y1) + (SNL4 g x1 x2 x3 x4,_) -> debugLog "lift_5x" $ opt (SNL5 g x1 x2 x3 x4 x) + (SNL5 g x1 x2 x3 x4 x5,SNK y) -> debugLog "merge_50" $ opt (SNL5 (\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 (SNL1 g x) + SNL1 g x1 -> debugLog "lift_2" $ opt (SNL2 g x1 x) + SNL2 g x1 x2 -> debugLog "lift_3" $ opt (SNL3 g x1 x2 x) + SNL3 g x1 x2 x3 -> debugLog "lift_4" $ opt (SNL4 g x1 x2 x3 x) + SNL4 g x1 x2 x3 x4 -> debugLog "lift_5" $ opt (SNL5 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 to signals are physically the same. -} + +instance Eq (Signal a) where + S s1 == S s2 = s1 == s2 + +instance Num t => Num (Signal t) where + (+) = liftA2 (+) + (-) = liftA2 (-) + (*) = liftA2 (*) + signum = fmap signum + abs = fmap abs + negate = fmap negate + fromInteger = pure . fromInteger + +instance Fractional t => Fractional (Signal t) where + (/) = liftA2 (/) + recip = fmap recip + fromRational = pure . fromRational + +-- ** Internal functions to run the network + +{-| This function is really just a shorthand to create a reference to +a given node. -} + +createSignal :: SignalNode a -> Signal a +createSignal = S . unsafePerformIO . newIORef . Cur + +{-| Sampling and aging 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 + Cur s -> do -- 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 (Tra v undefined) + s' <- advance s dt + writeIORef r (Tra v s') + return v + Tra v _ -> return v + +{-| Finalising the aged signals for the next round. -} + +commit :: forall a . Signal a -> IO () +commit (S s) = do + t <- readIORef s + case t of + Tra _ s' -> do writeIORef s (Cur s') + -- TODO: branching can be trivially parallelised + case s' of + SNT s _ _ -> commit s + SNA sf sx -> commit sf >> commit sx + SNL1 _ s -> commit s + SNL2 _ s1 s2 -> commit s1 >> commit s2 + SNL3 _ s1 s2 s3 -> commit s1 >> commit s2 >> commit s3 + SNL4 _ s1 s2 s3 s4 -> commit s1 >> commit s2 >> commit s3 >> commit s4 + SNL5 _ s1 s2 s3 s4 s5 -> commit s1 >> commit s2 >> commit s3 >> commit s4 >> commit s5 + SNE s e ss -> commit s >> commit e >> commit ss + _ -> return () + _ -> return () + +{-| Aging the signal. Stateful signals have their state forced to +prevent building up big thunks, and the latcher also does its job +here. The other nodes are structurally static. -} + +advance :: SignalNode a -> DTime -> IO (SignalNode a) +advance (SNS x f) dt = x `seq` return (SNS (f dt x) f) +advance (SNT s x f) dt = x `seq` do t <- signalValue s dt + return (SNT s (f dt t x) f) +advance sw@(SNE _ e ss) dt = do b <- signalValue e dt + s' <- signalValue ss dt + if b + then return (SNE s' e ss) + else return sw +advance s _ = return s + +{-| Sampling the signal at the current moment. This is where static +nodes propagate changes to those they depend on. Note the latcher +rule ('SNE'): the signal is sampled before latching takes place, +therefore even if the change is instantaneous, its effect cannot be +observed at the moment of latching. This is needed to prevent +dependency loops and make recursive definitions involving latching +possible. The stateful signals 'SNS' and 'SNT' are similar, although +it is only the transfer function where it matters that the input +signal cannot affect the current output, only the next one. -} + +sample :: SignalNode a -> DTime -> IO a +sample (SNK x) _ = return x +sample (SNF f) _ = f <$> readIORef timeRef +sample (SNS x _) _ = return x +sample (SNT _ x _) _ = return x +sample (SNA sf sx) dt = signalValue sf dt <*> signalValue sx dt +sample (SNE s _ _) dt = signalValue s dt +sample (SNR r) _ = readIORef r +sample (SNL1 f s) dt = f <$> signalValue s dt +sample (SNL2 f s1 s2) dt = liftM2 f (signalValue s1 dt) (signalValue s2 dt) +sample (SNL3 f s1 s2 s3) dt = liftM3 f (signalValue s1 dt) (signalValue s2 dt) (signalValue s3 dt) +sample (SNL4 f s1 s2 s3 s4) dt = liftM4 f (signalValue s1 dt) (signalValue s2 dt) (signalValue s3 dt) (signalValue s4 dt) +sample (SNL5 f s1 s2 s3 s4 s5) dt = liftM5 f (signalValue s1 dt) (signalValue s2 dt) (signalValue s3 dt) (signalValue s4 dt) (signalValue s5 dt) + +{-| The actual variable that keeps track of global time. -} + +{-# NOINLINE timeRef #-} +timeRef :: IORef Time +timeRef = unsafePerformIO (newIORef 0) + +-- ** Userland primitives + +{-| Advancing the whole network that the given signal depends on by +the amount of time given in the second argument. Note that the shared +'time' signal is also advanced, so this function should only be used +for sampling the top level. -} + +superstep :: Signal a -- ^ the top-level signal + -> DTime -- ^ the amount of time to advance + -> IO a -- ^ the value of the signal before the update +superstep world dt = do + snapshot <- signalValue world dt + commit world + t <- readIORef timeRef + let t' = t+dt + writeIORef timeRef $! t' + return snapshot + +{-| The global time. -} + +{-# NOINLINE time #-} +time :: Signal Time +time = createSignal (SNR timeRef) + +{-| A pure time function. -} + +stateless :: (Time -> a) -- ^ the function to wrap + -> Signal a +stateless = createSignal . SNF + +{-| A pure stateful signal. -} + +stateful :: a -- ^ initial state + -> (DTime -> a -> a) -- ^ state transformation + -> Signal a +stateful x0 f = createSignal (SNS x0 f) + +{-| A stateful transfer function. The current input can only affect +the next output, i.e. there is an implicit delay. -} + +transfer :: a -- ^ initial state + -> (DTime -> t -> a -> a) -- ^ state updater function + -> Signal t -- ^ input signal + -> Signal a +transfer x0 f s = createSignal (SNT s x0 f) + +{-| Reactive signal that starts out as @s@ and can change its +behaviour to the one supplied in @ss@ whenever @e@ is true. The change +can only be observed in the next instant. -} + +latcher :: Signal a -- ^ @s@: initial behaviour + -> Signal Bool -- ^ @e@: latch control signal + -> Signal (Signal a) -- ^ @ss@: signal of potential future behaviours + -> Signal a +latcher s e ss = createSignal (SNE s e ss) + +{-| 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 (Cur (SNR ref)) + return (S snr,writeIORef ref) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2009, Patai Gergely +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/elerea.cabal b/elerea.cabal new file mode 100644 --- /dev/null +++ b/elerea.cabal @@ -0,0 +1,41 @@ +Name: elerea +Version: 0.1.0 +Cabal-Version: >= 1.2 +Synopsis: A minimalistic FRP library +Category: reactivity, FRP +Description: + + Elerea (Eventless reactivity) is a tiny continuous-time FRP + implementation without the notion of event-based switching and + sampling, with first-class signals (time-varying values). Reactivity + is provided through a latching mechanism where a signal changes its + behaviour as dictated by a boolean input signal. + . + Elerea provides an easy to use applicative interface, supports + recursive signals (a definition like @sine = integral 0 (integral 1 + (-sine))@ works without a hitch) and arbitrary external + input. Cycles are allowed by the implicit delay on stateful transfer + functions. For the time being it is not possible to create arbitrary + transfer functions without a delay, but this limitation can be + removed later. + . + This is a minimal library that defines only some basic primitives, + and you are advised to install @elerea-examples@ as well to get an + idea how to build non-trivial systems with it. The examples are + separated in order to minimise the dependencies of the core library. + +Author: Patai Gergely +Maintainer: Patai Gergely (patai@iit.bme.hu) +Copyright: (c) 2009, Patai Gergely +License: BSD3 +License-File: LICENSE +Stability: experimental +Build-Type: Simple + +Library + Exposed-Modules: + FRP.Elerea + FRP.Elerea.Internal + + Build-Depends: base + ghc-options: -Wall -O2