Amsden's Time Flies AFRP

AFRP.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

module AFRP where

import           Control.Applicative
import qualified Control.Arrow as A
import           Control.Category
import           Control.Monad
import           Control.Monad.State
import           Data.Either
import           Data.Foldable (Foldable)
import qualified Data.Foldable as Foldable
import           Data.List
import           Data.Ord
import           Prelude hiding ((.), id)

infixr 3 ***
infixr 3 &&&

-- | A tool for introducing 'Arr' instances for general 'A.Arrow's
newtype Arrow p a b =
  Arrow { arr :: p a b }
  deriving ( Functor, Applicative, Monad
           , Category, A.Arrow
           , A.ArrowLoop, A.ArrowChoice
           , A.ArrowPlus, A.ArrowZero
           )

class Category p => Arr p x | p -> x where
  first     :: p a b -> p (a `x` c) (b `x` c)
  second    :: p a b -> p (c `x` a) (c `x` b)
  assoc     :: p ((a `x` b) `x` c) (a `x` (b `x` c))
  unassoc   :: p (a `x` (b `x` c)) ((a `x` b) `x` c)
  (***)     :: p a b -> p a' b' -> p (a `x` a') (b `x` b')
  f *** g = first f >>> second g

class Arr p x => ArrId p x u | x -> u where
  cancelL   :: p (u `x` a) a
  cancelR   :: p (a `x` u) a
  uncancelL :: p a (u `x` a)
  uncancelR :: p a (a `x` u)

instance Arr (->) (,) where
  first  f (a, c) = (f a, c)
  second f (c, a) = (c, f a)
  assoc   ((a, b), c) = (a, (b, c))
  unassoc (a, (b, c)) = ((a, b), c)
  (f *** g) (a, a') = (f a, g a')

instance ArrId (->) (,) () where
  cancelL (_, a)  = a
  cancelR (a, _)  = a
  uncancelL a     = ((), a)
  uncancelR a     = (a, ())

instance A.Arrow p => Arr (Arrow p) (,) where
  first   = A.first
  second  = A.second
  assoc   = A.arr assoc
  unassoc = A.arr unassoc

instance A.Arrow p => ArrId (Arrow p) (,) () where
  cancelL   = A.arr cancelL
  cancelR   = A.arr cancelR
  uncancelL = A.arr uncancelL
  uncancelR = A.arr uncancelR

class ArrId p x u => ArrDrop p x u where
  ignore :: p a u

instance ArrDrop (->) (,) () where
  ignore _ = ()

instance A.Arrow p => ArrDrop (Arrow p) (,) () where
  ignore = A.arr ignore

class Arr p x => ArrSwap p x where
  swap :: p (a `x` b) (b `x` a)

instance ArrSwap (->) (,) where
  swap (a, b) = (b, a)

instance A.Arrow p => ArrSwap (Arrow p) (,) where
  swap = A.arr swap

class Arr p x => ArrCopy p x where
  copy  :: p a (a `x` a)
  (&&&) :: p a b -> p a b' -> p a (b `x` b')
  f &&& g = copy >>> f *** g

instance ArrCopy (->) (,) where
  copy a = (a, a)
  (f &&& g) a = (f a, g a)

instance A.Arrow p => ArrCopy (Arrow p) (,) where
  copy = A.arr copy
  (&&&) = (A.&&&)

class Arr p x => ArrLoop p x where
  loop :: p (a `x` s) (b `x` s) -> p a b

instance ArrLoop (->) (,) where
  loop f b = let (c, d) = f (b, d) in c

instance A.ArrowLoop p => ArrLoop (Arrow p) (,) where
  loop = A.loop

--------------------------------------------------------------------------------

type Time = Double

infixl 1 ~>
infixl 1 *~>
infixl 2 *

-- A type-level product
data Z
data (*) :: * -> * -> *

-- Terminal classifiers for signals and events
data S a
data E a

-- Signal functions

data i ~> o =
  Sf { runSf :: Sample i -> (Sample o, i *~> o) }

instance Category (~>) where
  id = Sf (, id)
  Sf f2 . Sf f1 =
    Sf $ \a -> let (b, f1') = f1 a
                   (c, f2') = f2 b
               in (c, f2' . f1')

-- internal
static
  :: (Time -> Delta i -> (Delta o, [Occ o]))
  -> (Occ i -> [Occ o])
  -> (i *~> o)
static f g =
  z where z = Sfi (\dt del ->
                     let (del', occ) = f dt del
                     in (del', occ, z))
                  (\occ -> (g occ, z))

-- internal
manySfi :: (i *~> o)
        -> ([Occ i] -> ([Occ o], i *~> o))
manySfi = foldr go . ([],) where
  go occ (occs, f) = first (++ occs) (discrete f occ)

data i *~> o =
  Sfi { continuous :: Time -> Delta i -> (Delta o, [Occ o], i *~> o)
      , discrete   :: Occ i -> ([Occ o], i *~> o)
      }

instance Category (*~>) where
  id  = static (const (, [])) pure
  f2 . f1 = Sfi
    { continuous = \dt a ->
      let (b, ob, f1') = continuous f1 dt a
          (c, oc, f2') = continuous f2 dt b
          (moreOc, f2'') = manySfi f2' ob
      in (c, oc ++ moreOc, f2'' . f1')
    , discrete = \a ->
        let (bs, f1') = discrete f1 a
            (cs, f2') = manySfi f2 bs
        in (cs, f2' . f1')
    }

constant :: a -> (Z ~> S a)
constant a = Sf $ \_ -> (here a, static (\_ _ -> (here a, [])) (const []))

never :: Z ~> E a
never = Sf $ \_ -> (sampleEvt, neverLive)

neverLive :: Z *~> E a
neverLive = static (\_ _ -> (deltaAny, [])) (const [])

asap :: a -> (Z ~> E a)
asap a = Sf $ \_ -> (sampleEvt, asapLive) where
  asapLive = Sfi
    { continuous = \_ _ -> (deltaAny, [end a], neverLive)
    , discrete   = \_   -> ([], asapLive)
    }

after :: a -> Time -> (Z ~> E a)
after a t0 = Sf $ \_ -> (sampleEvt, afterLive t0) where
  afterLive t = Sfi
    { continuous = \dt _ ->
        if dt >= t
        then (deltaAny, [end a], neverLive)
        else (deltaAny, [     ], afterLive (t - dt))
    , discrete = \_ -> ([], afterLive t)
    }

pureS :: (a -> b) -> (S a ~> S b)
pureS f = Sf (\s -> (mapTree f coerceSampleF s, pureSLive)) where
  pureSLive = static (\_ d -> (mapTree f coerceDeltaF d, []))
                     (\_   -> [])

pureE :: (a -> b) -> (E a ~> E b)
pureE f = Sf (\_ -> (sampleEvt, pureELive)) where
  pureELive = static (\_ _ -> (deltaAny, []))
                     (\e -> [mapPath f e])

--------------------------------------------------------------------------------

instance Arr (~>) (*) where
  first f = Sf $ \s ->
    let (l, r)  = splitSample s
        (o, f') = runSf f l
    in (o & r, first f')
  second f = Sf $ \s ->
    let (l, r)  = splitSample s
        (o, f') = runSf f r
    in (l & o, second f')
  assoc = Sf $ \s ->
    let ((a, b), c) = first splitSample (splitSample s)
    in (a & (b & c), assoc)
  unassoc = Sf $ \s ->
    let (a, (b, c)) = second splitSample (splitSample s)
    in ((a & b) & c, unassoc)

instance Arr (*~>) (*) where
  first f = Sfi
    { continuous = \dt d ->
        let (a, c) = splitDelta d
            (b, occs, f') = continuous f dt a
        in (b & c, map left occs, first f')
    , discrete =
          splitPath
          (map left *** first <<< discrete f)
          (\e -> ([right e], first f))
    }
  second f = Sfi 
    { continuous = \dt d ->
        let (c, a) = splitDelta d
            (b, occs, f') = continuous f dt a
        in (c & b, map right occs, second f')
    , discrete =
          splitPath
          (\e -> ([left e], second f))
          (map right *** second <<< discrete f)
    }
  assoc = Sfi
    { continuous = \_ d ->
        let ((a, b), c) = first splitDelta (splitDelta d)
        in (a & (b & c), [], assoc)
    , discrete   = \e   -> ([assocPath e], assoc)
    }
  unassoc = Sfi
    { continuous = \_ d ->
        let (a, (b, c)) = second splitDelta (splitDelta d)
        in ((a & b) & c, [], unassoc)
    , discrete   = \e   -> ([unassocPath e], unassoc)
    }

instance ArrId (~>) (*) Z where
  cancelL   = Sf $ \s -> (snd (splitSample s), cancelL)
  cancelR   = Sf $ \s -> (fst (splitSample s), cancelR)
  uncancelL = Sf $ \s -> (sampleZ & s, uncancelL)
  uncancelR = Sf $ \s -> (s & sampleZ, uncancelR)

instance ArrId (*~>) (*) Z where
  cancelL =
    static
    (\_ d -> (snd (splitDelta d), []))
    (\(Rt e) -> [e])
  cancelR =
    static
    (\_ d -> (fst (splitDelta d), []))
    (\(Lt e) -> [e])
  uncancelL =
    static
    (\_ d -> (deltaAny & d, []))
    (\e -> [Rt e])
  uncancelR =
    static
    (\_ d -> (d & deltaAny, []))
    (\e -> [Lt e])

instance ArrCopy (~>) (*) where
  copy = Sf $ \a -> (a & a, copy)
  fl &&& fr = Sf $ \a ->
    let (lb, fl') = runSf fl a
        (rb, fr') = runSf fr a
    in (lb & rb, fl' &&& fr')

(/\/) :: [a] -> [a] -> [a]
as     /\/ []     = as
[]     /\/ bs     = bs
(a:as) /\/ (b:bs) = a : b : (as /\/ bs)

instance ArrCopy (*~>) (*) where
  copy =
    static
    (\_ d -> (d & d, []))
    (\e -> [Lt e, Rt e])
  fl &&& fr =
    Sfi { continuous = \dt d ->
            let (lb, loccs, fl') = continuous fl dt d
                (rb, roccs, fr') = continuous fr dt d
            in (lb & rb, map Lt loccs /\/ map Rt roccs, fl' &&& fr')
        , discrete = \e ->
            let (loccs, fl') = discrete fl e
                (roccs, fr') = discrete fr e
            in (map Lt loccs /\/ map Rt roccs, fl' &&& fr')
        }

instance ArrSwap (~>) (*) where
  swap = Sf $ \s ->
    let (l, r) = splitSample s
    in (r & l, swap)

instance ArrSwap (*~>) (*) where
  swap =
    static
    (\_ d -> let (l, r) = splitDelta d in (r & l, []))
    (\e   -> [splitPath Rt Lt e])

instance ArrDrop (~>) (*) Z where
  ignore = Sf (\_ -> (sampleZ, ignore))

instance ArrDrop (*~>) (*) Z where
  ignore = static (\_ _ -> (deltaAny, [])) (\_ -> [])

instance ArrLoop (~>) (*) where
  loop f = Sf $ \a -> let (bc, f') = runSf f (a & c)
                          (b, c)   = splitSample bc
                      in (b, loopLive deltaAny f')

loopLive :: Delta c -> (i * c *~> o * c) -> (i *~> o)
loopLive c f =
  Sfi { continuous = \dt i ->
          let (oc, os, f') = continuous f dt (i & c)
              (osi, osc)   = splitPaths os
              (osi', osc') = splitPaths folds
              (folds, f'') = manySfi f' (map right (osc ++ osc'))
              (o, c')      = splitDelta oc
          in (o, osi ++ osi', loopLive c' f'')
      , discrete   = \i ->
          let (ocs, f')    = discrete f (left i)
              (os, cs)     = splitPaths ocs
              (os', cs')   = splitPaths folds
              (folds, f'') = manySfi f' (map right (cs ++ cs'))
          in (os ++ os', loopLive c f'')
      }

switch :: (i ~> o * E (i ~> o)) -> (i ~> o)
switch f = Sf $ \s ->
  let (oe, f') = runSf f s
      (o, _e)  = splitSample oe
  in (o, switchLive s f')

switchLive :: Sample i -> (i *~> o * E (i ~> o)) -> (i *~> o)
switchLive s f =
  Sfi { continuous = \dt i ->
          let (oe, oevs, f') = continuous f dt i
              s'             = i |+ s
              (o, _)         = splitDelta oe
              (oev, evs)     = splitPaths oevs
          in case map pathValue evs of
            []       -> (o, oev, switchLive s' f')
            newf : _ ->
              let (newoe, newf') = runSf newf s'
              in (sampleDelta newoe, oev, newf')
      , discrete = \e ->
          let (oe, f') = discrete f e
              (os, es) = splitPaths oe
          in case map pathValue es of
            []       -> (os, switchLive s f')
            newf : _ -> (os, uncurry switchPause (runSf newf s))
      }

switchPause :: Sample o -> (i *~> o) -> (i *~> o)
switchPause o f =
  Sfi { continuous = \dt i -> let (o', e, f') = continuous f dt i
                              in (sampleDelta (o' |+ o), e, f')
      , discrete   = \e    -> let (e', f') = discrete f e
                              in (e', switchPause o f')
      }

switchGen :: (i ~> (o * E a))
          -> (a -> (i ~> o))
          -> (i ~> o)
switchGen sf f = switch (sf >>> second (pureE f))

rswitch :: (i ~> o)
        -> (i * E (i ~> o) ~> o)
rswitch sf = switch (first sf >>> second (pureE rswitch))

filterA :: Foldable f => (a -> f b) -> E a ~> E b
filterA f = Sf $ \_ -> (sampleEvt, filterALive) where
  filterALive =
    static (\_ _ -> (deltaAny, [])) (map end . Foldable.toList . f .pathValue)

accumulate :: Foldable f => (a -> b -> (f c, a)) -> a -> (E b ~> E c)
accumulate f = acc where
  acc a =
    switch $
    pureE (f a) >>>
    copy >>>
    first (pureE fst >>> filterA id) >>>
    second (pureE (acc . snd))

split :: E (Either a b) ~> (E a * E b)
split = copy
    >>> first  (filterA (either Just (const Nothing)))
    >>> second (filterA (either (const Nothing) Just))

--------------------------------------------------------------------------------

union :: E a * E a ~> E a
union = Sf (\_ -> (sampleEvt, unionLive)) where
  unionLive :: E a * E a *~> E a
  unionLive = static (\_ _ -> (deltaAny, [])) (splitPath pure pure)

combineSignals :: (a -> b -> c) -> (S a * S b ~> S c)
combineSignals f = Sf $ \s ->
  let (l, r) = (sampleValue *** sampleValue) (splitSample s)
  in (here (f l r), combineSignalsLive l r)
  where
    combineSignalsLive l0 r0 =
      Sfi { continuous = \_ d ->
              let (dl, dr) = splitDelta d
                  l        = maybe l0 id (deltaValue dl)
                  r        = maybe r0 id (deltaValue dr)
              in (here (f l r), [], combineSignalsLive l r)
          , discrete = const ([], combineSignalsLive l0 r0)
          }

capture :: (S a * E b) ~> E (a, b)
capture = Sf $ \s ->
  let (sa, _) = splitSample s
      a       = sampleValue sa
  in (sampleEvt, captureLive a)
  where
    captureLive :: a -> (S a * E b) *~> E (a, b)
    captureLive a0 =
      Sfi { continuous = \_ d ->
              let (dl, _) = splitDelta d
                  l       = deltaValue dl
              in case l of
                Just a  -> (deltaAny, [], captureLive a)
                Nothing -> (deltaAny, [], captureLive a0)
          , discrete = \e -> case e of
                Rt b -> ([end (a0, pathValue b)], captureLive a0)
          }

time :: Z ~> S Time
time = Sf $ \_ -> (here 0, timeLive 0) where
  timeLive t0 =
    Sfi { continuous = \dt _ ->
            let t1 = t0 + dt
            in (here t1, [], timeLive t1)
        , discrete = \_ -> ([], timeLive t0)
        }

addIncreasingBy :: (a -> a -> Ordering) -> a -> [a] -> [a]
addIncreasingBy (><) x = go where
  go l = case l of
    []     -> [x]
    a : as -> case x >< a of
      LT -> x : a : as
      EQ -> a : x : as
      GT -> a : go as

delay :: Time -> (E a * E Time) ~> E a
delay d0 = Sf $ \_ -> (sampleEvt, delayLive [] d0 0) where
  delayLive ::  [(Time, Occ (E a))] -> Time -> Time -> (E a * E Time *~> E a)
  delayLive buff del0 now =
    Sfi { continuous = \dt _ ->
            let now' = now + dt
                (goe, nogoe) = break (\(t, _) -> t >= now') buff
            in (deltaAny, map snd goe, delayLive nogoe del0 now')
        , discrete = \e ->
            let f' = case e of
                  Lt l ->
                    let buff' = addIncreasingBy (comparing fst)
                                (now + del0, l)
                                buff
                    in delayLive buff' del0 now
                  Rt r ->
                    delayLive buff (pathValue r) now
            in ([], f')
        }

-- class TimeIntegrate i where
--
-- The original paper used the above typeclass to generalize
-- integration. The major goal seems to have been that we desire a
-- Time-module instead of a mere numeric type, but we'll restrict it a
-- bit.

integrate :: S Double ~> S Double
integrate = Sf $ \s -> (here 0, integrateLive 0 (sampleValue s)) where
  integrateLive :: Double -> Double -> (S Double *~> S Double)
  integrateLive s0 v0 =
    Sfi { continuous = \dt d ->
            let v = maybe v0 id (deltaValue d)
                s = s0 + (v * dt)
            in (here s, [], integrateLive s v)
        , discrete = \_ -> ([], integrateLive s0 v0)
        }

--------------------------------------------------------------------------------

-- How can we generalize Tree, Path, Handler, etc
class HMonoid v where
  -- svZero :: v Z
  (&)    :: v l -> v r -> v (l * r)

--------------------------------------------------------------------------------

data Tree f s x a where
  Here :: a   -> Tree f s x (s a)
  Gone :: f a -> Tree f s x a
  Bin  :: Tree f s x l -> Tree f s x r -> Tree f s x (l `x` r)  

mapTree :: (a -> b) -> (f (s a) -> f (s b))
        -> Tree f s x (s a) -> Tree f s x (s b)
mapTree f g t = case t of
  Here a  -> Here (f a)
  Gone fa -> Gone (g fa)

mapTreeGone :: forall f g s x a . (forall t . f t -> g t) -> Tree f s x a -> Tree g s x a
mapTreeGone f = z where
  z :: forall t . Tree f s x t -> Tree g s x t
  z t = case t of
    Here a  -> Here a
    Gone fa -> Gone (f fa)
    Bin l r -> Bin (z l) (z r)

here :: a -> Tree f s x (s a)
here = Here

gone :: f a -> Tree f s x a
gone = Gone

instance HMonoid (Tree f s (*)) where
  l & r = Bin l r

data Path s x a where
  End :: a -> Path s x (s a)
  Lt  :: Path s x a -> Path s x (a `x` c)
  Rt  :: Path s x a -> Path s x (c `x` a)

assocPath :: Path s x ((a `x` b) `x` c) -> Path s x (a `x` (b `x` c))
assocPath p = case p of
  Lt (Lt (End a)) -> Lt (End a)
  Lt (Rt (End b)) -> Rt (Lt (End b))
  Rt (End c)      -> Rt (Rt (End c))

unassocPath :: Path s x (a `x` (b `x` c)) -> Path s x ((a `x` b) `x` c)
unassocPath p = case p of
  Lt (End a)      -> Lt (Lt (End a))
  Rt (Lt (End b)) -> Lt (Rt (End b))
  Rt (Rt (End c)) -> Rt (End c)

end :: a -> Path s x (s a)
end = End

left :: Path s x a -> Path s x (x a c)
left = Lt

right :: Path s x a -> Path s x (x c a)
right = Rt

mapPath :: (a -> b) -> Path s x (s a) -> Path s x (s b)
mapPath f (End a) = End (f a)

splitPath :: (Path s x  l        -> c)
          -> (Path s x        r  -> c)
          -> (Path s x (l `x` r) -> c)
splitPath l r p = case p of
  Lt p' -> l p'
  Rt p' -> r p'

splitPaths :: [Path s x (l `x` r)] -> ([Path s x l], [Path s x r])
splitPaths = partitionEithers . map (splitPath Left Right)

pathValue :: Path s x (s a) -> a
pathValue (End a) = a

type Sample = Tree SampleF S (*) 
type Delta  = Tree DeltaF  S (*) 
type Occ    = Path         E (*)

data SampleF a where
  SampleFE :: SampleF (E a)
  SampleFZ :: SampleF Z

sampleEvt :: Sample (E a)
sampleEvt = Gone SampleFE

sampleZ :: Sample Z
sampleZ = Gone SampleFZ

coerceSampleF :: SampleF (S a) -> SampleF (S b)
coerceSampleF = error "coerceSampleF called!"

sampleValue :: Sample (S a) -> a
sampleValue t = case t of
  Here a -> a

splitSample :: Sample (l * r) -> (Sample l, Sample r)
splitSample (Bin l r) = (l, r)

data DeltaF a where
  DeltaF_ :: DeltaF a

coerceDeltaF :: DeltaF a -> DeltaF b
coerceDeltaF _ = DeltaF_

deltaAny :: Delta a
deltaAny = Gone DeltaF_

deltaValue :: Delta (S a) -> Maybe a
deltaValue d = case d of
  Here a -> Just a
  _      -> Nothing

splitDelta :: Delta (l * r) -> (Delta l, Delta r)
splitDelta t = case t of
  Bin l r -> (l, r)
  Gone _  -> (deltaAny, deltaAny)

sampleDelta :: Sample i -> Delta i
sampleDelta = mapTreeGone (const DeltaF_)

(|+) :: Delta i -> Sample i -> Sample i
d |+ s = case (d, s) of
  (Gone DeltaF_, s') -> s'
  (Bin ld rd, Bin ls rs) -> Bin (ld |+ ls) (rd |+ rs)

--------------------------------------------------------------------------------

infixl 1 -|
data r -| v where
  HandlerZ :: r -| Z
  HandlerS :: (a -> r) -> (r -| S a)
  HandlerE :: (a -> r) -> (r -| E a)
  Handler2 :: (r -| a) -> (r -| b) -> (r -| a * b)

instance HMonoid ((-|) r) where
  (&) = Handler2

occurHandler :: (r -| v) -> (Occ v -> r)
occurHandler h o = case h of
  HandlerE f   -> case o of End a -> f a
  Handler2 f g -> case o of
    Lt a -> occurHandler f a
    Rt a -> occurHandler g a

deltaHandler :: (r -| v) -> (Delta v -> [r])
deltaHandler h d = case d of
  Gone DeltaF_ -> []
  Here a       -> case h of HandlerS f -> [f a]
  Bin l r      -> case h of Handler2 f g -> deltaHandler f l ++ deltaHandler g r

--------------------------------------------------------------------------------

type EIn = Path E (*)
type SIn = Path S (*)

sinDelta :: SIn v -> Delta v -> Delta v
sinDelta (End v) _         = here v
sinDelta (Lt  u) (Bin l r) = Bin (sinDelta u l) r
sinDelta (Rt  u) (Bin l r) = Bin l (sinDelta u r)
sinDelta (Lt  u) (Gone _)  = Bin (sinDelta u deltaAny) deltaAny
sinDelta (Rt  u) (Gone _)  = Bin deltaAny (sinDelta u deltaAny)

--------------------------------------------------------------------------------

data St m i o =
  St { stSf      :: i *~> o
     , stHandler :: m () -| o
     , stNow     :: Time
     , stDelta   :: Delta i
     }

newtype Eval i o m a =
  Eval (StateT (St m i o) m a)
  deriving ( Functor, Applicative, Monad, MonadIO )

instance MonadTrans (Eval i o) where
  lift = Eval . lift

buildSt :: (m () -| o)
        -> Sample i -> Time
        -> (i ~> o) -> St m i o
buildSt h s0 t0 f =
  St { stSf      = snd (runSf f s0)
     , stHandler = h
     , stNow     = t0
     , stDelta   = deltaAny
     }

runEval :: Eval i o m a -> St m i o -> m (a, St m i o)
runEval (Eval st) = runStateT st

push :: Monad m => EIn i -> Eval i o m ()
push i = Eval $ do
  st@(St {..}) <- get
  let (occs, f') = discrete stSf i
  lift $ mapM_ (occurHandler stHandler) occs
  put (st { stSf = f' })

update :: Monad m => SIn i -> Eval i o m ()
update i = Eval $ do
  st0@(St {..}) <- get
  put (st0 { stDelta = sinDelta i stDelta })

step :: Monad m => Time -> Eval i o m ()
step now = Eval $ do
  st0@(St {..}) <- get
  let dt = now - stNow
      (delta, occs, f') = continuous stSf dt stDelta
  lift $ do
    sequence_ (deltaHandler stHandler delta)
    mapM_     (occurHandler stHandler) occs
  put (st0 { stSf = f', stDelta = deltaAny, stNow = now })