{-# LANGUAGE Arrows     #-}
{-# LANGUAGE CPP        #-}
{-# LANGUAGE RankNTypes #-}
module FRP.BearRiver
  (module FRP.BearRiver, module X)
 where
-- This is an implementation of Yampa using our Monadic Stream Processing
-- library. We focus only on core Yampa. We will use this module later to
-- reimplement an example of a Yampa system.
--
-- While we may not introduce all the complexity of Yampa today (all kinds of
-- switches, etc.) our goal is to show that the approach is promising and that
-- there do not seem to exist any obvious limitations.

import           Control.Applicative
import           Control.Arrow                                  as X
import qualified Control.Category                               as Category
import           Control.Monad                                  (mapM)
import           Control.Monad.Random
import           Control.Monad.Trans.Maybe
import           Control.Monad.Trans.MSF                        hiding (switch)
import qualified Control.Monad.Trans.MSF                        as MSF
import           Control.Monad.Trans.MSF.Except                 as MSF hiding
                                                                        (switch)
import           Control.Monad.Trans.MSF.List                   (sequenceS,
                                                                 widthFirst)
import           Control.Monad.Trans.MSF.Random
import           Data.Functor.Identity
import           Data.Maybe
import           Data.MonadicStreamFunction                     as X hiding (reactimate,
                                                                      repeatedly,
                                                                      sum,
                                                                      switch,
                                                                      trace)
import qualified Data.MonadicStreamFunction                     as MSF
import           Data.MonadicStreamFunction.Instances.ArrowLoop
import           Data.MonadicStreamFunction.InternalCore
import           Data.Traversable                               as T
import           Data.VectorSpace                               as X

infixr 0 -->, -:>, >--, >=-

-- * Basic definitions

type Time  = Double

type DTime = Double

type SF m        = MSF (ClockInfo m)

type ClockInfo m = ReaderT DTime m

data Event a = Event a | NoEvent
 deriving (Event a -> Event a -> Bool
(Event a -> Event a -> Bool)
-> (Event a -> Event a -> Bool) -> Eq (Event a)
forall a. Eq a => Event a -> Event a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Event a -> Event a -> Bool
$c/= :: forall a. Eq a => Event a -> Event a -> Bool
== :: Event a -> Event a -> Bool
$c== :: forall a. Eq a => Event a -> Event a -> Bool
Eq, Int -> Event a -> ShowS
[Event a] -> ShowS
Event a -> String
(Int -> Event a -> ShowS)
-> (Event a -> String) -> ([Event a] -> ShowS) -> Show (Event a)
forall a. Show a => Int -> Event a -> ShowS
forall a. Show a => [Event a] -> ShowS
forall a. Show a => Event a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Event a] -> ShowS
$cshowList :: forall a. Show a => [Event a] -> ShowS
show :: Event a -> String
$cshow :: forall a. Show a => Event a -> String
showsPrec :: Int -> Event a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Event a -> ShowS
Show)

-- | The type 'Event' is isomorphic to 'Maybe'. The 'Functor' instance of
-- 'Event' is analogous to the 'Functo' instance of 'Maybe', where the given
-- function is applied to the value inside the 'Event', if any.
instance Functor Event where
  fmap :: (a -> b) -> Event a -> Event b
fmap a -> b
_ Event a
NoEvent   = Event b
forall a. Event a
NoEvent
  fmap a -> b
f (Event a
c) = b -> Event b
forall a. a -> Event a
Event (a -> b
f a
c)

-- | The type 'Event' is isomorphic to 'Maybe'. The 'Applicative' instance of
-- 'Event' is analogous to the 'Applicative' instance of 'Maybe', where the
-- lack of a value (i.e., 'NoEvent') causes '(<*>)' to produce no value
-- ('NoEvent').
instance Applicative Event where
  pure :: a -> Event a
pure = a -> Event a
forall a. a -> Event a
Event

  Event a -> b
f <*> :: Event (a -> b) -> Event a -> Event b
<*> Event a
x = b -> Event b
forall a. a -> Event a
Event (a -> b
f a
x)
  Event (a -> b)
_       <*> Event a
_       = Event b
forall a. Event a
NoEvent

-- | The type 'Event' is isomorphic to 'Maybe'. The 'Monad' instance of 'Event'
-- is analogous to the 'Monad' instance of 'Maybe', where the lack of a value
-- (i.e., 'NoEvent') causes bind to produce no value ('NoEvent').
instance Monad Event where
  return :: a -> Event a
return = a -> Event a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

  Event a
x >>= :: Event a -> (a -> Event b) -> Event b
>>= a -> Event b
f = a -> Event b
f a
x
  Event a
NoEvent >>= a -> Event b
_ = Event b
forall a. Event a
NoEvent

-- ** Lifting
arrPrim :: Monad m => (a -> b) -> SF m a b
arrPrim :: (a -> b) -> SF m a b
arrPrim = (a -> b) -> SF m a b
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr

arrEPrim :: Monad m => (Event a -> b) -> SF m (Event a) b
arrEPrim :: (Event a -> b) -> SF m (Event a) b
arrEPrim = (Event a -> b) -> SF m (Event a) b
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr

-- * Signal functions

-- ** Basic signal functions

identity :: Monad m => SF m a a
identity :: SF m a a
identity = SF m a a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
Category.id

constant :: Monad m => b -> SF m a b
constant :: b -> SF m a b
constant = (a -> b) -> SF m a b
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((a -> b) -> SF m a b) -> (b -> a -> b) -> b -> SF m a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a -> b
forall a b. a -> b -> a
const

localTime :: Monad m => SF m a Time
localTime :: SF m a Time
localTime = Time -> SF m a Time
forall (m :: * -> *) b a. Monad m => b -> SF m a b
constant Time
1.0 SF m a Time -> MSF (ClockInfo m) Time Time -> SF m a Time
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> MSF (ClockInfo m) Time Time
forall (m :: * -> *) a s. (Monad m, VectorSpace a s) => SF m a a
integral

time :: Monad m => SF m a Time
time :: SF m a Time
time = SF m a Time
forall (m :: * -> *) a. Monad m => SF m a Time
localTime

-- ** Initialization

-- | Initialization operator (cf. Lustre/Lucid Synchrone).
--
-- The output at time zero is the first argument, and from
-- that point on it behaves like the signal function passed as
-- second argument.
(-->) :: Monad m => b -> SF m a b -> SF m a b
b
b0 --> :: b -> SF m a b -> SF m a b
--> SF m a b
sf = SF m a b
sf SF m a b -> MSF (ClockInfo m) b b -> SF m a b
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> b -> MSF (ClockInfo m) b b
forall (m :: * -> *) a. Monad m => a -> SF m a a
replaceOnce b
b0

-- | Output pre-insert operator.
--
-- Insert a sample in the output, and from that point on, behave
-- like the given sf.
(-:>) :: Monad m => b -> SF m a b -> SF m a b
b
b -:> :: b -> SF m a b -> SF m a b
-:> SF m a b
sf = b -> SF m a b -> SF m a b
forall (m :: * -> *) b a. Monad m => b -> MSF m a b -> MSF m a b
iPost b
b SF m a b
sf

-- | Input initialization operator.
--
-- The input at time zero is the first argument, and from
-- that point on it behaves like the signal function passed as
-- second argument.
(>--) :: Monad m => a -> SF m a b -> SF m a b
a
a0 >-- :: a -> SF m a b -> SF m a b
>-- SF m a b
sf = a -> SF m a a
forall (m :: * -> *) a. Monad m => a -> SF m a a
replaceOnce a
a0 SF m a a -> SF m a b -> SF m a b
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> SF m a b
sf

(>=-) :: Monad m => (a -> a) -> SF m a b -> SF m a b
a -> a
f >=- :: (a -> a) -> SF m a b -> SF m a b
>=- SF m a b
sf = (a -> ClockInfo m (b, SF m a b)) -> SF m a b
forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF ((a -> ClockInfo m (b, SF m a b)) -> SF m a b)
-> (a -> ClockInfo m (b, SF m a b)) -> SF m a b
forall a b. (a -> b) -> a -> b
$ \a
a -> do
  (b
b, SF m a b
sf') <- SF m a b -> a -> ClockInfo m (b, SF m a b)
forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF SF m a b
sf (a -> a
f a
a)
  (b, SF m a b) -> ClockInfo m (b, SF m a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, SF m a b
sf')

initially :: Monad m => a -> SF m a a
initially :: a -> SF m a a
initially = (a -> SF m a a -> SF m a a
forall (m :: * -> *) b a. Monad m => b -> SF m a b -> SF m a b
--> SF m a a
forall (m :: * -> *) a. Monad m => SF m a a
identity)

-- * Simple, stateful signal processing
sscan :: Monad m => (b -> a -> b) -> b -> SF m a b
sscan :: (b -> a -> b) -> b -> SF m a b
sscan b -> a -> b
f b
b_init = b -> MSF (ClockInfo m) (a, b) (b, b) -> SF m a b
forall (m :: * -> *) c a b.
Monad m =>
c -> MSF m (a, c) (b, c) -> MSF m a b
feedback b
b_init MSF (ClockInfo m) (a, b) (b, b)
forall a. a
u
  where u :: a
u = a
forall a. HasCallStack => a
undefined -- (arr f >>^ dup)

sscanPrim :: Monad m => (c -> a -> Maybe (c, b)) -> c -> b -> SF m a b
sscanPrim :: (c -> a -> Maybe (c, b)) -> c -> b -> SF m a b
sscanPrim c -> a -> Maybe (c, b)
f c
c_init b
b_init = (a -> ClockInfo m (b, SF m a b)) -> SF m a b
forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF ((a -> ClockInfo m (b, SF m a b)) -> SF m a b)
-> (a -> ClockInfo m (b, SF m a b)) -> SF m a b
forall a b. (a -> b) -> a -> b
$ \a
a -> do
  let o :: Maybe (c, b)
o = c -> a -> Maybe (c, b)
f c
c_init a
a
  case Maybe (c, b)
o of
    Maybe (c, b)
Nothing       -> (b, SF m a b) -> ClockInfo m (b, SF m a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b_init, (c -> a -> Maybe (c, b)) -> c -> b -> SF m a b
forall (m :: * -> *) c a b.
Monad m =>
(c -> a -> Maybe (c, b)) -> c -> b -> SF m a b
sscanPrim c -> a -> Maybe (c, b)
f c
c_init b
b_init)
    Just (c
c', b
b') -> (b, SF m a b) -> ClockInfo m (b, SF m a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b',     (c -> a -> Maybe (c, b)) -> c -> b -> SF m a b
forall (m :: * -> *) c a b.
Monad m =>
(c -> a -> Maybe (c, b)) -> c -> b -> SF m a b
sscanPrim c -> a -> Maybe (c, b)
f c
c' b
b')


-- | Event source that never occurs.
never :: Monad m => SF m a (Event b)
never :: SF m a (Event b)
never = Event b -> SF m a (Event b)
forall (m :: * -> *) b a. Monad m => b -> SF m a b
constant Event b
forall a. Event a
NoEvent

-- | Event source with a single occurrence at time 0. The value of the event
-- is given by the function argument.
now :: Monad m => b -> SF m a (Event b)
now :: b -> SF m a (Event b)
now b
b0 = b -> Event b
forall a. a -> Event a
Event b
b0 Event b -> SF m a (Event b) -> SF m a (Event b)
forall (m :: * -> *) b a. Monad m => b -> SF m a b -> SF m a b
--> SF m a (Event b)
forall (m :: * -> *) a b. Monad m => SF m a (Event b)
never

after :: Monad m
      => Time -- ^ The time /q/ after which the event should be produced
      -> b    -- ^ Value to produce at that time
      -> SF m a (Event b)
after :: Time -> b -> SF m a (Event b)
after Time
q b
x = Time
-> MSF (ReaderT Time m) (a, Time) (Event b, Time)
-> SF m a (Event b)
forall (m :: * -> *) c a b.
Monad m =>
c -> MSF m (a, c) (b, c) -> MSF m a b
feedback Time
q MSF (ReaderT Time m) (a, Time) (Event b, Time)
forall a. MSF (ReaderT Time m) (a, Time) (Event b, Time)
go
 where go :: MSF (ReaderT Time m) (a, Time) (Event b, Time)
go = ((a, Time)
 -> ReaderT
      Time
      m
      ((Event b, Time), MSF (ReaderT Time m) (a, Time) (Event b, Time)))
-> MSF (ReaderT Time m) (a, Time) (Event b, Time)
forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF (((a, Time)
  -> ReaderT
       Time
       m
       ((Event b, Time), MSF (ReaderT Time m) (a, Time) (Event b, Time)))
 -> MSF (ReaderT Time m) (a, Time) (Event b, Time))
-> ((a, Time)
    -> ReaderT
         Time
         m
         ((Event b, Time), MSF (ReaderT Time m) (a, Time) (Event b, Time)))
-> MSF (ReaderT Time m) (a, Time) (Event b, Time)
forall a b. (a -> b) -> a -> b
$ \(a
_, Time
t) -> do
              Time
dt <- ReaderT Time m Time
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
              let t' :: Time
t' = Time
t Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
dt
                  e :: Event b
e  = if Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
> Time
0 Bool -> Bool -> Bool
&& Time
t' Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
0 then b -> Event b
forall a. a -> Event a
Event b
x else Event b
forall a. Event a
NoEvent
                  ct :: MSF (ReaderT Time m) (a, Time) (Event b, Time)
ct = if Time
t' Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
0 then (Event b, Time) -> MSF (ReaderT Time m) (a, Time) (Event b, Time)
forall (m :: * -> *) b a. Monad m => b -> SF m a b
constant (Event b
forall a. Event a
NoEvent, Time
t') else MSF (ReaderT Time m) (a, Time) (Event b, Time)
go
              ((Event b, Time), MSF (ReaderT Time m) (a, Time) (Event b, Time))
-> ReaderT
     Time
     m
     ((Event b, Time), MSF (ReaderT Time m) (a, Time) (Event b, Time))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Event b
e, Time
t'), MSF (ReaderT Time m) (a, Time) (Event b, Time)
ct)

repeatedly :: Monad m => Time -> b -> SF m a (Event b)
repeatedly :: Time -> b -> SF m a (Event b)
repeatedly Time
q b
x
    | Time
q Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
> Time
0     = [(Time, b)] -> SF m a (Event b)
forall (m :: * -> *) b a.
Monad m =>
[(Time, b)] -> SF m a (Event b)
afterEach [(Time, b)]
qxs
    | Bool
otherwise = String -> SF m a (Event b)
forall a. HasCallStack => String -> a
error String
"bearriver: repeatedly: Non-positive period."
  where
    qxs :: [(Time, b)]
qxs = (Time
q,b
x)(Time, b) -> [(Time, b)] -> [(Time, b)]
forall a. a -> [a] -> [a]
:[(Time, b)]
qxs

-- | Event source with consecutive occurrences at the given intervals.
-- Should more than one event be scheduled to occur in any sampling interval,
-- only the first will in fact occur to avoid an event backlog.

-- After all, after, repeatedly etc. are defined in terms of afterEach.
afterEach :: Monad m => [(Time,b)] -> SF m a (Event b)
afterEach :: [(Time, b)] -> SF m a (Event b)
afterEach [(Time, b)]
qxs = [(Time, b)] -> SF m a (Event [b])
forall (m :: * -> *) b a.
Monad m =>
[(Time, b)] -> SF m a (Event [b])
afterEachCat [(Time, b)]
qxs SF m a (Event [b])
-> MSF (ClockInfo m) (Event [b]) (Event b) -> SF m a (Event b)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Event [b] -> Event b) -> MSF (ClockInfo m) (Event [b]) (Event b)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (([b] -> b) -> Event [b] -> Event b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [b] -> b
forall a. [a] -> a
head)

-- | Event source with consecutive occurrences at the given intervals.
-- Should more than one event be scheduled to occur in any sampling interval,
-- the output list will contain all events produced during that interval.
afterEachCat :: Monad m => [(Time,b)] -> SF m a (Event [b])
afterEachCat :: [(Time, b)] -> SF m a (Event [b])
afterEachCat = Time -> [(Time, b)] -> SF m a (Event [b])
forall (m :: * -> *) b a.
Monad m =>
Time -> [(Time, b)] -> SF m a (Event [b])
afterEachCat' Time
0
  where
    afterEachCat' :: Monad m => Time -> [(Time,b)] -> SF m a (Event [b])
    afterEachCat' :: Time -> [(Time, b)] -> SF m a (Event [b])
afterEachCat' Time
_ []  = SF m a (Event [b])
forall (m :: * -> *) a b. Monad m => SF m a (Event b)
never
    afterEachCat' Time
t [(Time, b)]
qxs = (a -> ReaderT Time m (Event [b], SF m a (Event [b])))
-> SF m a (Event [b])
forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF ((a -> ReaderT Time m (Event [b], SF m a (Event [b])))
 -> SF m a (Event [b]))
-> (a -> ReaderT Time m (Event [b], SF m a (Event [b])))
-> SF m a (Event [b])
forall a b. (a -> b) -> a -> b
$ \a
_ -> do
      Time
dt <- ReaderT Time m Time
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
      let t' :: Time
t' = Time
t Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
dt
          ([(Time, b)]
qxsNow, [(Time, b)]
qxsLater) = ((Time, b) -> Bool) -> [(Time, b)] -> ([(Time, b)], [(Time, b)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\(Time, b)
p -> (Time, b) -> Time
forall a b. (a, b) -> a
fst (Time, b)
p Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
<= Time
t') [(Time, b)]
qxs
          ev :: Event [b]
ev = if [(Time, b)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Time, b)]
qxsNow then Event [b]
forall a. Event a
NoEvent else [b] -> Event [b]
forall a. a -> Event a
Event (((Time, b) -> b) -> [(Time, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (Time, b) -> b
forall a b. (a, b) -> b
snd [(Time, b)]
qxsNow)
      (Event [b], SF m a (Event [b]))
-> ReaderT Time m (Event [b], SF m a (Event [b]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Event [b]
ev, Time -> [(Time, b)] -> SF m a (Event [b])
forall (m :: * -> *) b a.
Monad m =>
Time -> [(Time, b)] -> SF m a (Event [b])
afterEachCat' Time
t' [(Time, b)]
qxsLater)


-- * Events

-- | Apply an 'MSF' to every input. Freezes temporarily if the input is
-- 'NoEvent', and continues as soon as an 'Event' is received.
mapEventS :: Monad m => MSF m a b -> MSF m (Event a) (Event b)
mapEventS :: MSF m a b -> MSF m (Event a) (Event b)
mapEventS MSF m a b
msf = proc Event a
eventA -> case Event a
eventA of
  Event a
a -> (b -> Event b) -> MSF m b (Event b)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr b -> Event b
forall a. a -> Event a
Event MSF m b (Event b) -> MSF m a b -> MSF m a (Event b)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< MSF m a b
msf -< a
a
  Event a
NoEvent -> MSF m (Event b) (Event b)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA           -< Event b
forall a. Event a
NoEvent

-- ** Relation to other types

eventToMaybe :: Event a -> Maybe a
eventToMaybe = Maybe a -> (a -> Maybe a) -> Event a -> Maybe a
forall a b. a -> (b -> a) -> Event b -> a
event Maybe a
forall a. Maybe a
Nothing a -> Maybe a
forall a. a -> Maybe a
Just

boolToEvent :: Bool -> Event ()
boolToEvent :: Bool -> Event ()
boolToEvent Bool
True  = () -> Event ()
forall a. a -> Event a
Event ()
boolToEvent Bool
False = Event ()
forall a. Event a
NoEvent

-- * Hybrid SF m combinators

edge :: Monad m => SF m Bool (Event ())
edge :: SF m Bool (Event ())
edge = Bool -> SF m Bool (Event ())
forall (m :: * -> *). Monad m => Bool -> SF m Bool (Event ())
edgeFrom Bool
True

iEdge :: Monad m => Bool -> SF m Bool (Event ())
iEdge :: Bool -> SF m Bool (Event ())
iEdge = Bool -> SF m Bool (Event ())
forall (m :: * -> *). Monad m => Bool -> SF m Bool (Event ())
edgeFrom

-- | Like 'edge', but parameterized on the tag value.
--
-- From Yampa
edgeTag :: Monad m => a -> SF m Bool (Event a)
edgeTag :: a -> SF m Bool (Event a)
edgeTag a
a = SF m Bool (Event ())
forall (m :: * -> *). Monad m => SF m Bool (Event ())
edge SF m Bool (Event ())
-> MSF (ClockInfo m) (Event ()) (Event a) -> SF m Bool (Event a)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Event () -> Event a) -> MSF (ClockInfo m) (Event ()) (Event a)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Event () -> a -> Event a
forall a b. Event a -> b -> Event b
`tag` a
a)

-- | Edge detector particularized for detecting transtitions
--   on a 'Maybe' signal from 'Nothing' to 'Just'.
--
-- From Yampa

-- !!! 2005-07-09: To be done or eliminated
-- !!! Maybe could be kept as is, but could be easy to implement directly
-- !!! in terms of sscan?
edgeJust :: Monad m => SF m (Maybe a) (Event a)
edgeJust :: SF m (Maybe a) (Event a)
edgeJust = (Maybe a -> Maybe a -> Maybe a)
-> Maybe a -> SF m (Maybe a) (Event a)
forall (m :: * -> *) a b.
Monad m =>
(a -> a -> Maybe b) -> a -> SF m a (Event b)
edgeBy Maybe a -> Maybe a -> Maybe a
forall a a. Maybe a -> Maybe a -> Maybe a
isJustEdge (a -> Maybe a
forall a. a -> Maybe a
Just a
forall a. HasCallStack => a
undefined)
    where
        isJustEdge :: Maybe a -> Maybe a -> Maybe a
isJustEdge Maybe a
Nothing  Maybe a
Nothing     = Maybe a
forall a. Maybe a
Nothing
        isJustEdge Maybe a
Nothing  ma :: Maybe a
ma@(Just a
_) = Maybe a
ma
        isJustEdge (Just a
_) (Just a
_)    = Maybe a
forall a. Maybe a
Nothing
        isJustEdge (Just a
_) Maybe a
Nothing     = Maybe a
forall a. Maybe a
Nothing

edgeBy :: Monad m => (a -> a -> Maybe b) -> a -> SF m a (Event b)
edgeBy :: (a -> a -> Maybe b) -> a -> SF m a (Event b)
edgeBy a -> a -> Maybe b
isEdge a
a_prev = (a -> ClockInfo m (Event b, SF m a (Event b))) -> SF m a (Event b)
forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF ((a -> ClockInfo m (Event b, SF m a (Event b)))
 -> SF m a (Event b))
-> (a -> ClockInfo m (Event b, SF m a (Event b)))
-> SF m a (Event b)
forall a b. (a -> b) -> a -> b
$ \a
a ->
  (Event b, SF m a (Event b))
-> ClockInfo m (Event b, SF m a (Event b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe b -> Event b
forall a. Maybe a -> Event a
maybeToEvent (a -> a -> Maybe b
isEdge a
a_prev a
a), (a -> a -> Maybe b) -> a -> SF m a (Event b)
forall (m :: * -> *) a b.
Monad m =>
(a -> a -> Maybe b) -> a -> SF m a (Event b)
edgeBy a -> a -> Maybe b
isEdge a
a)

maybeToEvent :: Maybe a -> Event a
maybeToEvent :: Maybe a -> Event a
maybeToEvent = Event a -> (a -> Event a) -> Maybe a -> Event a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Event a
forall a. Event a
NoEvent a -> Event a
forall a. a -> Event a
Event

edgeFrom :: Monad m => Bool -> SF m Bool (Event())
edgeFrom :: Bool -> SF m Bool (Event ())
edgeFrom Bool
prev = (Bool -> ClockInfo m (Event (), SF m Bool (Event ())))
-> SF m Bool (Event ())
forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF ((Bool -> ClockInfo m (Event (), SF m Bool (Event ())))
 -> SF m Bool (Event ()))
-> (Bool -> ClockInfo m (Event (), SF m Bool (Event ())))
-> SF m Bool (Event ())
forall a b. (a -> b) -> a -> b
$ \Bool
a -> do
  let res :: Event ()
res | Bool
prev      = Event ()
forall a. Event a
NoEvent
          | Bool
a         = () -> Event ()
forall a. a -> Event a
Event ()
          | Bool
otherwise = Event ()
forall a. Event a
NoEvent
      ct :: SF m Bool (Event ())
ct  = Bool -> SF m Bool (Event ())
forall (m :: * -> *). Monad m => Bool -> SF m Bool (Event ())
edgeFrom Bool
a
  (Event (), SF m Bool (Event ()))
-> ClockInfo m (Event (), SF m Bool (Event ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Event ()
res, SF m Bool (Event ())
ct)

-- * Stateful event suppression

-- | Suppression of initial (at local time 0) event.
notYet :: Monad m => SF m (Event a) (Event a)
notYet :: SF m (Event a) (Event a)
notYet = Bool
-> MSF (ClockInfo m) (Event a, Bool) (Event a, Bool)
-> SF m (Event a) (Event a)
forall (m :: * -> *) c a b.
Monad m =>
c -> MSF m (a, c) (b, c) -> MSF m a b
feedback Bool
False (MSF (ClockInfo m) (Event a, Bool) (Event a, Bool)
 -> SF m (Event a) (Event a))
-> MSF (ClockInfo m) (Event a, Bool) (Event a, Bool)
-> SF m (Event a) (Event a)
forall a b. (a -> b) -> a -> b
$ ((Event a, Bool) -> (Event a, Bool))
-> MSF (ClockInfo m) (Event a, Bool) (Event a, Bool)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\(Event a
e,Bool
c) ->
  if Bool
c then (Event a
e, Bool
True) else (Event a
forall a. Event a
NoEvent, Bool
True))

-- | Suppress all but the first event.
once :: Monad m => SF m (Event a) (Event a)
once :: SF m (Event a) (Event a)
once = Int -> SF m (Event a) (Event a)
forall (m :: * -> *) a. Monad m => Int -> SF m (Event a) (Event a)
takeEvents Int
1

-- | Suppress all but the first n events.
takeEvents :: Monad m => Int -> SF m (Event a) (Event a)
takeEvents :: Int -> SF m (Event a) (Event a)
takeEvents Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = SF m (Event a) (Event a)
forall (m :: * -> *) a b. Monad m => SF m a (Event b)
never
takeEvents Int
n = SF m (Event a) (Event a, Event a)
-> (a -> SF m (Event a) (Event a)) -> SF m (Event a) (Event a)
forall (m :: * -> *) a b c.
Monad m =>
SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b
dSwitch ((Event a -> (Event a, Event a))
-> SF m (Event a) (Event a, Event a)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Event a -> (Event a, Event a)
forall b. b -> (b, b)
dup) (SF m (Event a) (Event a) -> a -> SF m (Event a) (Event a)
forall a b. a -> b -> a
const (Event a
forall a. Event a
NoEvent Event a -> SF m (Event a) (Event a) -> SF m (Event a) (Event a)
forall (m :: * -> *) a b. Monad m => a -> SF m a b -> SF m a b
>-- Int -> SF m (Event a) (Event a)
forall (m :: * -> *) a. Monad m => Int -> SF m (Event a) (Event a)
takeEvents (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)))

-- | Suppress first n events.

-- Here dSwitch or switch does not really matter.
dropEvents :: Monad m => Int -> SF m (Event a) (Event a)
dropEvents :: Int -> SF m (Event a) (Event a)
dropEvents Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0  = SF m (Event a) (Event a)
forall (m :: * -> *) a. Monad m => SF m a a
identity
dropEvents Int
n = SF m (Event a) (Event a, Event a)
-> (a -> SF m (Event a) (Event a)) -> SF m (Event a) (Event a)
forall (m :: * -> *) a b c.
Monad m =>
SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b
dSwitch (SF m (Event a) (Event a)
forall (m :: * -> *) a b. Monad m => SF m a (Event b)
never SF m (Event a) (Event a)
-> SF m (Event a) (Event a) -> SF m (Event a) (Event a, Event a)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& SF m (Event a) (Event a)
forall (m :: * -> *) a. Monad m => SF m a a
identity)
                             (SF m (Event a) (Event a) -> a -> SF m (Event a) (Event a)
forall a b. a -> b -> a
const (Event a
forall a. Event a
NoEvent Event a -> SF m (Event a) (Event a) -> SF m (Event a) (Event a)
forall (m :: * -> *) a b. Monad m => a -> SF m a b -> SF m a b
>-- Int -> SF m (Event a) (Event a)
forall (m :: * -> *) a. Monad m => Int -> SF m (Event a) (Event a)
dropEvents (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)))

-- * Pointwise functions on events

noEvent :: Event a
noEvent :: Event a
noEvent = Event a
forall a. Event a
NoEvent

-- | Suppress any event in the first component of a pair.
noEventFst :: (Event a, b) -> (Event c, b)
noEventFst :: (Event a, b) -> (Event c, b)
noEventFst (Event a
_, b
b) = (Event c
forall a. Event a
NoEvent, b
b)


-- | Suppress any event in the second component of a pair.
noEventSnd :: (a, Event b) -> (a, Event c)
noEventSnd :: (a, Event b) -> (a, Event c)
noEventSnd (a
a, Event b
_) = (a
a, Event c
forall a. Event a
NoEvent)

event :: a -> (b -> a) -> Event b -> a
event :: a -> (b -> a) -> Event b -> a
event a
_ b -> a
f (Event b
x) = b -> a
f b
x
event a
x b -> a
_ Event b
NoEvent   = a
x

fromEvent :: Event p -> p
fromEvent (Event p
x) = p
x
fromEvent Event p
_         = String -> p
forall a. HasCallStack => String -> a
error String
"fromEvent NoEvent"

isEvent :: Event a -> Bool
isEvent (Event a
_) = Bool
True
isEvent Event a
_         = Bool
False

isNoEvent :: Event a -> Bool
isNoEvent (Event a
_) = Bool
False
isNoEvent Event a
_         = Bool
True

tag :: Event a -> b -> Event b
tag :: Event a -> b -> Event b
tag Event a
NoEvent   b
_ = Event b
forall a. Event a
NoEvent
tag (Event a
_) b
b = b -> Event b
forall a. a -> Event a
Event b
b

-- | Tags an (occurring) event with a value ("replacing" the old value). Same
-- as 'tag' with the arguments swapped.
--
-- Applicative-based definition:
-- tagWith = (<$)
tagWith :: b -> Event a -> Event b
tagWith :: b -> Event a -> Event b
tagWith = (Event a -> b -> Event b) -> b -> Event a -> Event b
forall a b c. (a -> b -> c) -> b -> a -> c
flip Event a -> b -> Event b
forall a b. Event a -> b -> Event b
tag

-- | Attaches an extra value to the value of an occurring event.
attach :: Event a -> b -> Event (a, b)
Event a
e attach :: Event a -> b -> Event (a, b)
`attach` b
b = (a -> (a, b)) -> Event a -> Event (a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
a -> (a
a, b
b)) Event a
e

-- | Left-biased event merge (always prefer left event, if present).
lMerge :: Event a -> Event a -> Event a
lMerge :: Event a -> Event a -> Event a
lMerge = (a -> a -> a) -> Event a -> Event a -> Event a
forall a. (a -> a -> a) -> Event a -> Event a -> Event a
mergeBy (\a
e1 a
_ -> a
e1)

-- | Right-biased event merge (always prefer right event, if present).
rMerge :: Event a -> Event a -> Event a
rMerge :: Event a -> Event a -> Event a
rMerge = (Event a -> Event a -> Event a) -> Event a -> Event a -> Event a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Event a -> Event a -> Event a
forall a. Event a -> Event a -> Event a
lMerge

merge :: Event a -> Event a -> Event a
merge :: Event a -> Event a -> Event a
merge = (a -> a -> a) -> Event a -> Event a -> Event a
forall a. (a -> a -> a) -> Event a -> Event a -> Event a
mergeBy ((a -> a -> a) -> Event a -> Event a -> Event a)
-> (a -> a -> a) -> Event a -> Event a -> Event a
forall a b. (a -> b) -> a -> b
$ String -> a -> a -> a
forall a. HasCallStack => String -> a
error String
"Bearriver: merge: Simultaneous event occurrence."

mergeBy :: (a -> a -> a) -> Event a -> Event a -> Event a
mergeBy :: (a -> a -> a) -> Event a -> Event a -> Event a
mergeBy a -> a -> a
_       Event a
NoEvent      Event a
NoEvent      = Event a
forall a. Event a
NoEvent
mergeBy a -> a -> a
_       le :: Event a
le@(Event a
_) Event a
NoEvent      = Event a
le
mergeBy a -> a -> a
_       Event a
NoEvent      re :: Event a
re@(Event a
_) = Event a
re
mergeBy a -> a -> a
resolve (Event a
l)    (Event a
r)    = a -> Event a
forall a. a -> Event a
Event (a -> a -> a
resolve a
l a
r)

-- | A generic event merge-map utility that maps event occurrences,
-- merging the results. The first three arguments are mapping functions,
-- the third of which will only be used when both events are present.
-- Therefore, 'mergeBy' = 'mapMerge' 'id' 'id'
--
-- Applicative-based definition:
-- mapMerge lf rf lrf le re = (f <$> le <*> re) <|> (lf <$> le) <|> (rf <$> re)
mapMerge :: (a -> c) -> (b -> c) -> (a -> b -> c)
            -> Event a -> Event b -> Event c
mapMerge :: (a -> c)
-> (b -> c) -> (a -> b -> c) -> Event a -> Event b -> Event c
mapMerge a -> c
_  b -> c
_  a -> b -> c
_   Event a
NoEvent   Event b
NoEvent   = Event c
forall a. Event a
NoEvent
mapMerge a -> c
lf b -> c
_  a -> b -> c
_   (Event a
l) Event b
NoEvent   = c -> Event c
forall a. a -> Event a
Event (a -> c
lf a
l)
mapMerge a -> c
_  b -> c
rf a -> b -> c
_   Event a
NoEvent   (Event b
r) = c -> Event c
forall a. a -> Event a
Event (b -> c
rf b
r)
mapMerge a -> c
_  b -> c
_  a -> b -> c
lrf (Event a
l) (Event b
r) = c -> Event c
forall a. a -> Event a
Event (a -> b -> c
lrf a
l b
r)

-- | Merge a list of events; foremost event has priority.
--
-- Foldable-based definition:
-- mergeEvents :: Foldable t => t (Event a) -> Event a
-- mergeEvents =  asum
mergeEvents :: [Event a] -> Event a
mergeEvents :: [Event a] -> Event a
mergeEvents = (Event a -> Event a -> Event a) -> Event a -> [Event a] -> Event a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Event a -> Event a -> Event a
forall a. Event a -> Event a -> Event a
lMerge Event a
forall a. Event a
NoEvent

-- | Collect simultaneous event occurrences; no event if none.
--
-- Traverable-based definition:
-- catEvents :: Foldable t => t (Event a) -> Event (t a)
-- carEvents e  = if (null e) then NoEvent else (sequenceA e)
catEvents :: [Event a] -> Event [a]
catEvents :: [Event a] -> Event [a]
catEvents [Event a]
eas = case [ a
a | Event a
a <- [Event a]
eas ] of
                    [] -> Event [a]
forall a. Event a
NoEvent
                    [a]
as -> [a] -> Event [a]
forall a. a -> Event a
Event [a]
as

-- | Join (conjunction) of two events. Only produces an event
-- if both events exist.
--
-- Applicative-based definition:
-- joinE = liftA2 (,)
joinE :: Event a -> Event b -> Event (a,b)
joinE :: Event a -> Event b -> Event (a, b)
joinE Event a
NoEvent   Event b
_         = Event (a, b)
forall a. Event a
NoEvent
joinE Event a
_         Event b
NoEvent   = Event (a, b)
forall a. Event a
NoEvent
joinE (Event a
l) (Event b
r) = (a, b) -> Event (a, b)
forall a. a -> Event a
Event (a
l,b
r)

-- | Split event carrying pairs into two events.
splitE :: Event (a,b) -> (Event a, Event b)
splitE :: Event (a, b) -> (Event a, Event b)
splitE Event (a, b)
NoEvent       = (Event a
forall a. Event a
NoEvent, Event b
forall a. Event a
NoEvent)
splitE (Event (a
a,b
b)) = (a -> Event a
forall a. a -> Event a
Event a
a, b -> Event b
forall a. a -> Event a
Event b
b)

------------------------------------------------------------------------------
-- Event filtering
------------------------------------------------------------------------------

-- | Filter out events that don't satisfy some predicate.
filterE :: (a -> Bool) -> Event a -> Event a
filterE :: (a -> Bool) -> Event a -> Event a
filterE a -> Bool
p e :: Event a
e@(Event a
a) = if a -> Bool
p a
a then Event a
e else Event a
forall a. Event a
NoEvent
filterE a -> Bool
_ Event a
NoEvent     = Event a
forall a. Event a
NoEvent


-- | Combined event mapping and filtering. Note: since 'Event' is a 'Functor',
-- see 'fmap' for a simpler version of this function with no filtering.
mapFilterE :: (a -> Maybe b) -> Event a -> Event b
mapFilterE :: (a -> Maybe b) -> Event a -> Event b
mapFilterE a -> Maybe b
_ Event a
NoEvent   = Event b
forall a. Event a
NoEvent
mapFilterE a -> Maybe b
f (Event a
a) = case a -> Maybe b
f a
a of
                            Maybe b
Nothing -> Event b
forall a. Event a
NoEvent
                            Just b
b  -> b -> Event b
forall a. a -> Event a
Event b
b


-- | Enable/disable event occurences based on an external condition.
gate :: Event a -> Bool -> Event a
Event a
_ gate :: Event a -> Bool -> Event a
`gate` Bool
False = Event a
forall a. Event a
NoEvent
Event a
e `gate` Bool
True  = Event a
e

-- * Switching

-- ** Basic switchers

switch :: Monad m => SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b
switch :: SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b
switch SF m a (b, Event c)
sf c -> SF m a b
sfC = (a -> ClockInfo m (b, SF m a b)) -> SF m a b
forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF ((a -> ClockInfo m (b, SF m a b)) -> SF m a b)
-> (a -> ClockInfo m (b, SF m a b)) -> SF m a b
forall a b. (a -> b) -> a -> b
$ \a
a -> do
  ((b, Event c)
o, SF m a (b, Event c)
ct) <- SF m a (b, Event c)
-> a -> ClockInfo m ((b, Event c), SF m a (b, Event c))
forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF SF m a (b, Event c)
sf a
a
  case (b, Event c)
o of
    (b
_, Event c
c) -> (Time -> Time)
-> ClockInfo m (b, SF m a b) -> ClockInfo m (b, SF m a b)
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local (Time -> Time -> Time
forall a b. a -> b -> a
const Time
0) (SF m a b -> a -> ClockInfo m (b, SF m a b)
forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF (c -> SF m a b
sfC c
c) a
a)
    (b
b, Event c
NoEvent) -> (b, SF m a b) -> ClockInfo m (b, SF m a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b
forall (m :: * -> *) a b c.
Monad m =>
SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b
switch SF m a (b, Event c)
ct c -> SF m a b
sfC)

dSwitch ::  Monad m => SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b
dSwitch :: SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b
dSwitch SF m a (b, Event c)
sf c -> SF m a b
sfC = (a -> ClockInfo m (b, SF m a b)) -> SF m a b
forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF ((a -> ClockInfo m (b, SF m a b)) -> SF m a b)
-> (a -> ClockInfo m (b, SF m a b)) -> SF m a b
forall a b. (a -> b) -> a -> b
$ \a
a -> do
  ((b, Event c)
o, SF m a (b, Event c)
ct) <- SF m a (b, Event c)
-> a -> ClockInfo m ((b, Event c), SF m a (b, Event c))
forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF SF m a (b, Event c)
sf a
a
  case (b, Event c)
o of
    (b
b, Event c
c) -> do (b
_,SF m a b
ct') <- (Time -> Time)
-> ClockInfo m (b, SF m a b) -> ClockInfo m (b, SF m a b)
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local (Time -> Time -> Time
forall a b. a -> b -> a
const Time
0) (SF m a b -> a -> ClockInfo m (b, SF m a b)
forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF (c -> SF m a b
sfC c
c) a
a)
                       (b, SF m a b) -> ClockInfo m (b, SF m a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, SF m a b
ct')
    (b
b, Event c
NoEvent) -> (b, SF m a b) -> ClockInfo m (b, SF m a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b
forall (m :: * -> *) a b c.
Monad m =>
SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b
dSwitch SF m a (b, Event c)
ct c -> SF m a b
sfC)


-- * Parallel composition and switching

-- ** Parallel composition and switching over collections with broadcasting

#if MIN_VERSION_base(4,8,0)
parB :: (Monad m) => [SF m a b] -> SF m a [b]
#else
parB :: (Functor m, Monad m) => [SF m a b] -> SF m a [b]
#endif
parB :: [SF m a b] -> SF m a [b]
parB = MSF (ListT (ClockInfo m)) a b -> SF m a [b]
forall (m :: * -> *) a b.
(Functor m, Monad m) =>
MSF (ListT m) a b -> MSF m a [b]
widthFirst (MSF (ListT (ClockInfo m)) a b -> SF m a [b])
-> ([SF m a b] -> MSF (ListT (ClockInfo m)) a b)
-> [SF m a b]
-> SF m a [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SF m a b] -> MSF (ListT (ClockInfo m)) a b
forall (m :: * -> *) a b.
Monad m =>
[MSF m a b] -> MSF (ListT m) a b
sequenceS

dpSwitchB :: (Functor m, Monad m , Traversable col)
          => col (SF m a b) -> SF m (a, col b) (Event c) -> (col (SF m a b) -> c -> SF m a (col b))
          -> SF m a (col b)
dpSwitchB :: col (SF m a b)
-> SF m (a, col b) (Event c)
-> (col (SF m a b) -> c -> SF m a (col b))
-> SF m a (col b)
dpSwitchB col (SF m a b)
sfs SF m (a, col b) (Event c)
sfF col (SF m a b) -> c -> SF m a (col b)
sfCs = (a -> ClockInfo m (col b, SF m a (col b))) -> SF m a (col b)
forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF ((a -> ClockInfo m (col b, SF m a (col b))) -> SF m a (col b))
-> (a -> ClockInfo m (col b, SF m a (col b))) -> SF m a (col b)
forall a b. (a -> b) -> a -> b
$ \a
a -> do
  col (b, SF m a b)
res <- (SF m a b -> ClockInfo m (b, SF m a b))
-> col (SF m a b) -> ClockInfo m (col (b, SF m a b))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM (SF m a b -> a -> ClockInfo m (b, SF m a b)
forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
`unMSF` a
a) col (SF m a b)
sfs
  let bs :: col b
bs   = ((b, SF m a b) -> b) -> col (b, SF m a b) -> col b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, SF m a b) -> b
forall a b. (a, b) -> a
fst col (b, SF m a b)
res
      sfs' :: col (SF m a b)
sfs' = ((b, SF m a b) -> SF m a b) -> col (b, SF m a b) -> col (SF m a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, SF m a b) -> SF m a b
forall a b. (a, b) -> b
snd col (b, SF m a b)
res
  (Event c
e,SF m (a, col b) (Event c)
sfF') <- SF m (a, col b) (Event c)
-> (a, col b) -> ClockInfo m (Event c, SF m (a, col b) (Event c))
forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF SF m (a, col b) (Event c)
sfF (a
a, col b
bs)
  SF m a (col b)
ct <- case Event c
e of
          Event c
c -> (col b, SF m a (col b)) -> SF m a (col b)
forall a b. (a, b) -> b
snd ((col b, SF m a (col b)) -> SF m a (col b))
-> ClockInfo m (col b, SF m a (col b))
-> ClockInfo m (SF m a (col b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SF m a (col b) -> a -> ClockInfo m (col b, SF m a (col b))
forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF (col (SF m a b) -> c -> SF m a (col b)
sfCs col (SF m a b)
sfs c
c) a
a
          Event c
NoEvent -> SF m a (col b) -> ClockInfo m (SF m a (col b))
forall (m :: * -> *) a. Monad m => a -> m a
return (col (SF m a b)
-> SF m (a, col b) (Event c)
-> (col (SF m a b) -> c -> SF m a (col b))
-> SF m a (col b)
forall (m :: * -> *) (col :: * -> *) a b c.
(Functor m, Monad m, Traversable col) =>
col (SF m a b)
-> SF m (a, col b) (Event c)
-> (col (SF m a b) -> c -> SF m a (col b))
-> SF m a (col b)
dpSwitchB col (SF m a b)
sfs' SF m (a, col b) (Event c)
sfF' col (SF m a b) -> c -> SF m a (col b)
sfCs)
  (col b, SF m a (col b)) -> ClockInfo m (col b, SF m a (col b))
forall (m :: * -> *) a. Monad m => a -> m a
return (col b
bs, SF m a (col b)
ct)

-- ** Parallel composition over collections

parC :: Monad m => SF m a b -> SF m [a] [b]
parC :: SF m a b -> SF m [a] [b]
parC SF m a b
sf = SF m a b -> SF m [a] [b]
forall (m :: * -> *) a b. Monad m => SF m a b -> SF m [a] [b]
parC0 SF m a b
sf
  where
    parC0 :: Monad m => SF m a b -> SF m [a] [b]
    parC0 :: SF m a b -> SF m [a] [b]
parC0 SF m a b
sf0 = ([a] -> ClockInfo m ([b], SF m [a] [b])) -> SF m [a] [b]
forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF (([a] -> ClockInfo m ([b], SF m [a] [b])) -> SF m [a] [b])
-> ([a] -> ClockInfo m ([b], SF m [a] [b])) -> SF m [a] [b]
forall a b. (a -> b) -> a -> b
$ \[a]
as -> do
      [(b, SF m a b)]
os <- ((a, SF m a b) -> ClockInfo m (b, SF m a b))
-> [(a, SF m a b)] -> ClockInfo m [(b, SF m a b)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM (\(a
a,SF m a b
sf) -> SF m a b -> a -> ClockInfo m (b, SF m a b)
forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF SF m a b
sf a
a) ([(a, SF m a b)] -> ClockInfo m [(b, SF m a b)])
-> [(a, SF m a b)] -> ClockInfo m [(b, SF m a b)]
forall a b. (a -> b) -> a -> b
$ [a] -> [SF m a b] -> [(a, SF m a b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
as (Int -> SF m a b -> [SF m a b]
forall a. Int -> a -> [a]
replicate ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
as) SF m a b
sf0)
      let bs :: [b]
bs  = ((b, SF m a b) -> b) -> [(b, SF m a b)] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, SF m a b) -> b
forall a b. (a, b) -> a
fst [(b, SF m a b)]
os
          cts :: [SF m a b]
cts = ((b, SF m a b) -> SF m a b) -> [(b, SF m a b)] -> [SF m a b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, SF m a b) -> SF m a b
forall a b. (a, b) -> b
snd [(b, SF m a b)]
os
      ([b], SF m [a] [b]) -> ClockInfo m ([b], SF m [a] [b])
forall (m :: * -> *) a. Monad m => a -> m a
return ([b]
bs, [SF m a b] -> SF m [a] [b]
forall (m :: * -> *) a b. Monad m => [SF m a b] -> SF m [a] [b]
parC' [SF m a b]
cts)

    parC' :: Monad m => [SF m a b] -> SF m [a] [b]
    parC' :: [SF m a b] -> SF m [a] [b]
parC' [SF m a b]
sfs = ([a] -> ClockInfo m ([b], SF m [a] [b])) -> SF m [a] [b]
forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF (([a] -> ClockInfo m ([b], SF m [a] [b])) -> SF m [a] [b])
-> ([a] -> ClockInfo m ([b], SF m [a] [b])) -> SF m [a] [b]
forall a b. (a -> b) -> a -> b
$ \[a]
as -> do
      [(b, SF m a b)]
os <- ((a, SF m a b) -> ClockInfo m (b, SF m a b))
-> [(a, SF m a b)] -> ClockInfo m [(b, SF m a b)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM (\(a
a,SF m a b
sf) -> SF m a b -> a -> ClockInfo m (b, SF m a b)
forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF SF m a b
sf a
a) ([(a, SF m a b)] -> ClockInfo m [(b, SF m a b)])
-> [(a, SF m a b)] -> ClockInfo m [(b, SF m a b)]
forall a b. (a -> b) -> a -> b
$ [a] -> [SF m a b] -> [(a, SF m a b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
as [SF m a b]
sfs
      let bs :: [b]
bs  = ((b, SF m a b) -> b) -> [(b, SF m a b)] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, SF m a b) -> b
forall a b. (a, b) -> a
fst [(b, SF m a b)]
os
          cts :: [SF m a b]
cts = ((b, SF m a b) -> SF m a b) -> [(b, SF m a b)] -> [SF m a b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, SF m a b) -> SF m a b
forall a b. (a, b) -> b
snd [(b, SF m a b)]
os
      ([b], SF m [a] [b]) -> ClockInfo m ([b], SF m [a] [b])
forall (m :: * -> *) a. Monad m => a -> m a
return ([b]
bs, [SF m a b] -> SF m [a] [b]
forall (m :: * -> *) a b. Monad m => [SF m a b] -> SF m [a] [b]
parC' [SF m a b]
cts)

-- * Discrete to continuous-time signal functions

-- ** Wave-form generation

hold :: Monad m => a -> SF m (Event a) a
hold :: a -> SF m (Event a) a
hold a
a = a -> MSF (ClockInfo m) (Event a, a) (a, a) -> SF m (Event a) a
forall (m :: * -> *) c a b.
Monad m =>
c -> MSF m (a, c) (b, c) -> MSF m a b
feedback a
a (MSF (ClockInfo m) (Event a, a) (a, a) -> SF m (Event a) a)
-> MSF (ClockInfo m) (Event a, a) (a, a) -> SF m (Event a) a
forall a b. (a -> b) -> a -> b
$ ((Event a, a) -> (a, a)) -> MSF (ClockInfo m) (Event a, a) (a, a)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (((Event a, a) -> (a, a)) -> MSF (ClockInfo m) (Event a, a) (a, a))
-> ((Event a, a) -> (a, a))
-> MSF (ClockInfo m) (Event a, a) (a, a)
forall a b. (a -> b) -> a -> b
$ \(Event a
e,a
a') ->
    a -> (a, a)
forall b. b -> (b, b)
dup (a -> (a -> a) -> Event a -> a
forall a b. a -> (b -> a) -> Event b -> a
event a
a' a -> a
forall a. a -> a
id Event a
e)
  where
    dup :: b -> (b, b)
dup b
x = (b
x,b
x)

-- ** Accumulators

-- | Accumulator parameterized by the accumulation function.
accumBy :: Monad m => (b -> a -> b) -> b -> SF m (Event a) (Event b)
accumBy :: (b -> a -> b) -> b -> SF m (Event a) (Event b)
accumBy b -> a -> b
f b
b = MSF (ClockInfo m) a b -> SF m (Event a) (Event b)
forall (m :: * -> *) a b.
Monad m =>
MSF m a b -> MSF m (Event a) (Event b)
mapEventS (MSF (ClockInfo m) a b -> SF m (Event a) (Event b))
-> MSF (ClockInfo m) a b -> SF m (Event a) (Event b)
forall a b. (a -> b) -> a -> b
$ (a -> b -> b) -> b -> MSF (ClockInfo m) a b
forall (m :: * -> *) a s.
Monad m =>
(a -> s -> s) -> s -> MSF m a s
accumulateWith ((b -> a -> b) -> a -> b -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> a -> b
f) b
b

accumHoldBy :: Monad m => (b -> a -> b) -> b -> SF m (Event a) b
accumHoldBy :: (b -> a -> b) -> b -> SF m (Event a) b
accumHoldBy b -> a -> b
f b
b = b -> MSF (ClockInfo m) (Event a, b) (b, b) -> SF m (Event a) b
forall (m :: * -> *) c a b.
Monad m =>
c -> MSF m (a, c) (b, c) -> MSF m a b
feedback b
b (MSF (ClockInfo m) (Event a, b) (b, b) -> SF m (Event a) b)
-> MSF (ClockInfo m) (Event a, b) (b, b) -> SF m (Event a) b
forall a b. (a -> b) -> a -> b
$ ((Event a, b) -> (b, b)) -> MSF (ClockInfo m) (Event a, b) (b, b)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (((Event a, b) -> (b, b)) -> MSF (ClockInfo m) (Event a, b) (b, b))
-> ((Event a, b) -> (b, b))
-> MSF (ClockInfo m) (Event a, b) (b, b)
forall a b. (a -> b) -> a -> b
$ \(Event a
a, b
b') ->
  let b'' :: b
b'' = b -> (a -> b) -> Event a -> b
forall a b. a -> (b -> a) -> Event b -> a
event b
b' (b -> a -> b
f b
b') Event a
a
  in (b
b'', b
b'')

-- * State keeping combinators

-- ** Loops with guaranteed well-defined feedback
loopPre :: Monad m => c -> SF m (a, c) (b, c) -> SF m a b
loopPre :: c -> SF m (a, c) (b, c) -> SF m a b
loopPre = c -> SF m (a, c) (b, c) -> SF m a b
forall (m :: * -> *) c a b.
Monad m =>
c -> MSF m (a, c) (b, c) -> MSF m a b
feedback

-- * Integration and differentiation

integral :: (Monad m, VectorSpace a s) => SF m a a
integral :: SF m a a
integral = a -> SF m a a
forall (m :: * -> *) a s.
(Monad m, VectorSpace a s) =>
a -> SF m a a
integralFrom a
forall v a. VectorSpace v a => v
zeroVector

integralFrom :: (Monad m, VectorSpace a s) => a -> SF m a a
integralFrom :: a -> SF m a a
integralFrom a
a0 = proc a
a -> do
  Time
dt <- ReaderT Time m Time -> MSF (ReaderT Time m) () Time
forall (m :: * -> *) b a. Monad m => m b -> MSF m a b
constM ReaderT Time m Time
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask         -< ()
  (a -> a -> a) -> a -> SF m a a
forall (m :: * -> *) a s.
Monad m =>
(a -> s -> s) -> s -> MSF m a s
accumulateWith a -> a -> a
forall v a. VectorSpace v a => v -> v -> v
(^+^) a
a0 -< Time -> s
forall a b. (Real a, Fractional b) => a -> b
realToFrac Time
dt s -> a -> a
forall v a. VectorSpace v a => a -> v -> v
*^ a
a

derivative :: (Monad m, VectorSpace a s) => SF m a a
derivative :: SF m a a
derivative = a -> SF m a a
forall (m :: * -> *) a s.
(Monad m, VectorSpace a s) =>
a -> SF m a a
derivativeFrom a
forall v a. VectorSpace v a => v
zeroVector

derivativeFrom :: (Monad m, VectorSpace a s) => a -> SF m a a
derivativeFrom :: a -> SF m a a
derivativeFrom a
a0 = proc a
a -> do
  Time
dt   <- ReaderT Time m Time -> MSF (ReaderT Time m) () Time
forall (m :: * -> *) b a. Monad m => m b -> MSF m a b
constM ReaderT Time m Time
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask   -< ()
  a
aOld <- a -> SF m a a
forall (m :: * -> *) a. Monad m => a -> MSF m a a
MSF.iPre a
a0 -< a
a
  SF m a a
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA             -< (a
a a -> a -> a
forall v a. VectorSpace v a => v -> v -> v
^-^ a
aOld) a -> s -> a
forall v a. VectorSpace v a => v -> a -> v
^/ Time -> s
forall a b. (Real a, Fractional b) => a -> b
realToFrac Time
dt

-- NOTE: BUG in this function, it needs two a's but we
-- can only provide one
iterFrom :: Monad m => (a -> a -> DTime -> b -> b) -> b -> SF m a b
iterFrom :: (a -> a -> Time -> b -> b) -> b -> SF m a b
iterFrom a -> a -> Time -> b -> b
f b
b = (a -> ReaderT Time m (b, SF m a b)) -> SF m a b
forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF ((a -> ReaderT Time m (b, SF m a b)) -> SF m a b)
-> (a -> ReaderT Time m (b, SF m a b)) -> SF m a b
forall a b. (a -> b) -> a -> b
$ \a
a -> do
  Time
dt <- ReaderT Time m Time
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  let b' :: b
b' = a -> a -> Time -> b -> b
f a
a a
a Time
dt b
b
  (b, SF m a b) -> ReaderT Time m (b, SF m a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, (a -> a -> Time -> b -> b) -> b -> SF m a b
forall (m :: * -> *) a b.
Monad m =>
(a -> a -> Time -> b -> b) -> b -> SF m a b
iterFrom a -> a -> Time -> b -> b
f b
b')

-- * Noise (random signal) sources and stochastic event sources

occasionally :: MonadRandom m
             => Time -- ^ The time /q/ after which the event should be produced on average
             -> b    -- ^ Value to produce at time of event
             -> SF m a (Event b)
occasionally :: Time -> b -> SF m a (Event b)
occasionally Time
tAvg b
b
  | Time
tAvg Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
<= Time
0 = String -> SF m a (Event b)
forall a. HasCallStack => String -> a
error String
"bearriver: Non-positive average interval in occasionally."
  | Bool
otherwise = proc a
_ -> do
      Time
r   <- (Time, Time) -> MSF (ClockInfo m) () Time
forall (m :: * -> *) b a.
(MonadRandom m, Random b) =>
(b, b) -> MSF m a b
getRandomRS (Time
0, Time
1) -< ()
      Time
dt  <- MSF (ClockInfo m) () Time
forall (m :: * -> *) a. Monad m => SF m a Time
timeDelta          -< ()
      let p :: Time
p = Time
1 Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time -> Time
forall a. Floating a => a -> a
exp (-(Time
dt Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Time
tAvg))
      MSF (ClockInfo m) (Event b) (Event b)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< if Time
r Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
p then b -> Event b
forall a. a -> Event a
Event b
b else Event b
forall a. Event a
NoEvent
 where
  timeDelta :: Monad m => SF m a DTime
  timeDelta :: SF m a Time
timeDelta = ReaderT Time m Time -> SF m a Time
forall (m :: * -> *) b a. Monad m => m b -> MSF m a b
constM ReaderT Time m Time
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask

-- * Execution/simulation

-- ** Reactimation

reactimate :: Monad m => m a -> (Bool -> m (DTime, Maybe a)) -> (Bool -> b -> m Bool) -> SF Identity a b -> m ()
reactimate :: m a
-> (Bool -> m (Time, Maybe a))
-> (Bool -> b -> m Bool)
-> SF Identity a b
-> m ()
reactimate m a
senseI Bool -> m (Time, Maybe a)
sense Bool -> b -> m Bool
actuate SF Identity a b
sf = do
  -- runMaybeT $ MSF.reactimate $ liftMSFTrans (senseSF >>> sfIO) >>> actuateSF
  MSF m () Bool -> m ()
forall (m :: * -> *). Monad m => MSF m () Bool -> m ()
MSF.reactimateB (MSF m () Bool -> m ()) -> MSF m () Bool -> m ()
forall a b. (a -> b) -> a -> b
$ MSF m () (Time, a)
forall a. MSF m a (Time, a)
senseSF MSF m () (Time, a) -> MSF m (Time, a) Bool -> MSF m () Bool
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> MSF m (Time, a) b
sfIO MSF m (Time, a) b -> MSF m b Bool -> MSF m (Time, a) Bool
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> MSF m b Bool
actuateSF
  () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
 where sfIO :: MSF m (Time, a) b
sfIO        = (forall c. Identity c -> m c)
-> MSF Identity (Time, a) b -> MSF m (Time, a) b
forall (m2 :: * -> *) (m1 :: * -> *) a b.
(Monad m2, Monad m1) =>
(forall c. m1 c -> m2 c) -> MSF m1 a b -> MSF m2 a b
morphS (c -> m c
forall (m :: * -> *) a. Monad m => a -> m a
return(c -> m c) -> (Identity c -> c) -> Identity c -> m c
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Identity c -> c
forall a. Identity a -> a
runIdentity) (SF Identity a b -> MSF Identity (Time, a) b
forall (m :: * -> *) r a b.
Monad m =>
MSF (ReaderT r m) a b -> MSF m (r, a) b
runReaderS SF Identity a b
sf)

       -- Sense
       senseSF :: MSF m a (Time, a)
senseSF     = MSF m a ((Time, a), Maybe a)
-> (a -> MSF m a (Time, a)) -> MSF m a (Time, a)
forall (m :: * -> *) a b c.
Monad m =>
MSF m a (b, Maybe c) -> (c -> MSF m a b) -> MSF m a b
MSF.switch MSF m a ((Time, a), Maybe a)
forall a a. MSF m a ((Time, a), Maybe a)
senseFirst a -> MSF m a (Time, a)
forall a. a -> MSF m a (Time, a)
senseRest

       -- Sense: First sample
       senseFirst :: MSF m a ((Time, a), Maybe a)
senseFirst = MSF m a Bool
forall a. MSF m a Bool
ftp MSF m a Bool
-> MSF m Bool ((Time, a), Maybe a) -> MSF m a ((Time, a), Maybe a)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Bool -> m ((Time, a), Maybe a)) -> MSF m Bool ((Time, a), Maybe a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> MSF m a b
arrM Bool -> m ((Time, a), Maybe a)
forall a a. Num a => Bool -> m ((a, a), Maybe a)
senseOnce

       -- senseOnce :: Bool -> SF m () a
       senseOnce :: Bool -> m ((a, a), Maybe a)
senseOnce Bool
True  = m a
senseI m a -> (a -> m ((a, a), Maybe a)) -> m ((a, a), Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> ((a, a), Maybe a) -> m ((a, a), Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a
0, a
x), Maybe a
forall a. Maybe a
Nothing)
       senseOnce Bool
False = ((a, a), Maybe a) -> m ((a, a), Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a
0, a
forall a. HasCallStack => a
undefined), a -> Maybe a
forall a. a -> Maybe a
Just a
forall a. HasCallStack => a
undefined)

       -- First time point: outputs True at the first sample, and False after
       -- that. Conceptually this is like True --> constant False
       -- ftp :: Monad m => SF m a Bool
       ftp :: MSF m a Bool
ftp = Bool -> MSF m (a, Bool) (Bool, Bool) -> MSF m a Bool
forall (m :: * -> *) c a b.
Monad m =>
c -> MSF m (a, c) (b, c) -> MSF m a b
feedback Bool
True (MSF m (a, Bool) (Bool, Bool) -> MSF m a Bool)
-> MSF m (a, Bool) (Bool, Bool) -> MSF m a Bool
forall a b. (a -> b) -> a -> b
$ ((a, Bool) -> (Bool, Bool)) -> MSF m (a, Bool) (Bool, Bool)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (((a, Bool) -> (Bool, Bool)) -> MSF m (a, Bool) (Bool, Bool))
-> ((a, Bool) -> (Bool, Bool)) -> MSF m (a, Bool) (Bool, Bool)
forall a b. (a -> b) -> a -> b
$ \(a
_, Bool
x) -> (Bool
x, Bool
False)

       -- Sense: Remaining samples
       senseRest :: a -> MSF m a (Time, a)
senseRest a
a = m (Time, Maybe a) -> MSF m a (Time, Maybe a)
forall (m :: * -> *) b a. Monad m => m b -> MSF m a b
constM (Bool -> m (Time, Maybe a)
sense Bool
True) MSF m a (Time, Maybe a)
-> MSF m (Time, Maybe a) (Time, a) -> MSF m a (Time, a)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Time -> Time) -> MSF m Time Time
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Time -> Time
forall a. a -> a
id MSF m Time Time
-> MSF m (Maybe a) a -> MSF m (Time, Maybe a) (Time, a)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** a -> MSF m (Maybe a) a
forall (m :: * -> *) a. Monad m => a -> MSF m (Maybe a) a
keepLast a
a)

       keepLast :: Monad m => a -> MSF m (Maybe a) a
       keepLast :: a -> MSF m (Maybe a) a
keepLast a
a = (Maybe a -> m (a, MSF m (Maybe a) a)) -> MSF m (Maybe a) a
forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF ((Maybe a -> m (a, MSF m (Maybe a) a)) -> MSF m (Maybe a) a)
-> (Maybe a -> m (a, MSF m (Maybe a) a)) -> MSF m (Maybe a) a
forall a b. (a -> b) -> a -> b
$ \Maybe a
ma -> let a' :: a
a' = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
a Maybe a
ma in a
a' a -> m (a, MSF m (Maybe a) a) -> m (a, MSF m (Maybe a) a)
`seq` (a, MSF m (Maybe a) a) -> m (a, MSF m (Maybe a) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a', a -> MSF m (Maybe a) a
forall (m :: * -> *) a. Monad m => a -> MSF m (Maybe a) a
keepLast a
a')

       -- Consume/render
       -- actuateSF :: MSF IO b ()
       -- actuateSF    = arr (\x -> (True, x)) >>> liftMSF (lift . uncurry actuate) >>> exitIf
       actuateSF :: MSF m b Bool
actuateSF    = (b -> (Bool, b)) -> MSF m b (Bool, b)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\b
x -> (Bool
True, b
x)) MSF m b (Bool, b) -> MSF m (Bool, b) Bool -> MSF m b Bool
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Bool, b) -> m Bool) -> MSF m (Bool, b) Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> MSF m a b
arrM ((Bool -> b -> m Bool) -> (Bool, b) -> m Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Bool -> b -> m Bool
actuate)

-- * Debugging / Step by step simulation

-- | Evaluate an SF, and return an output and an initialized SF.
--
--   /WARN/: Do not use this function for standard simulation. This function is
--   intended only for debugging/testing. Apart from being potentially slower
--   and consuming more memory, it also breaks the FRP abstraction by making
--   samples discrete and step based.
evalAtZero :: SF Identity a b -> a -> (b, SF Identity a b)
evalAtZero :: SF Identity a b -> a -> (b, SF Identity a b)
evalAtZero SF Identity a b
sf a
a = Identity (b, SF Identity a b) -> (b, SF Identity a b)
forall a. Identity a -> a
runIdentity (Identity (b, SF Identity a b) -> (b, SF Identity a b))
-> Identity (b, SF Identity a b) -> (b, SF Identity a b)
forall a b. (a -> b) -> a -> b
$ ReaderT Time Identity (b, SF Identity a b)
-> Time -> Identity (b, SF Identity a b)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (SF Identity a b -> a -> ReaderT Time Identity (b, SF Identity a b)
forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF SF Identity a b
sf a
a) Time
0

-- | Evaluate an initialized SF, and return an output and a continuation.
--
--   /WARN/: Do not use this function for standard simulation. This function is
--   intended only for debugging/testing. Apart from being potentially slower
--   and consuming more memory, it also breaks the FRP abstraction by making
--   samples discrete and step based.
evalAt :: SF Identity a b -> DTime -> a -> (b, SF Identity a b)
evalAt :: SF Identity a b -> Time -> a -> (b, SF Identity a b)
evalAt SF Identity a b
sf Time
dt a
a = Identity (b, SF Identity a b) -> (b, SF Identity a b)
forall a. Identity a -> a
runIdentity (Identity (b, SF Identity a b) -> (b, SF Identity a b))
-> Identity (b, SF Identity a b) -> (b, SF Identity a b)
forall a b. (a -> b) -> a -> b
$ ReaderT Time Identity (b, SF Identity a b)
-> Time -> Identity (b, SF Identity a b)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (SF Identity a b -> a -> ReaderT Time Identity (b, SF Identity a b)
forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF SF Identity a b
sf a
a) Time
dt

-- | Given a signal function and time delta, it moves the signal function into
--   the future, returning a new uninitialized SF and the initial output.
--
--   While the input sample refers to the present, the time delta refers to the
--   future (or to the time between the current sample and the next sample).
--
--   /WARN/: Do not use this function for standard simulation. This function is
--   intended only for debugging/testing. Apart from being potentially slower
--   and consuming more memory, it also breaks the FRP abstraction by making
--   samples discrete and step based.
--
evalFuture :: SF Identity a b -> a -> DTime -> (b, SF Identity a b)
evalFuture :: SF Identity a b -> a -> Time -> (b, SF Identity a b)
evalFuture SF Identity a b
sf = (Time -> a -> (b, SF Identity a b))
-> a -> Time -> (b, SF Identity a b)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SF Identity a b -> Time -> a -> (b, SF Identity a b)
forall a b. SF Identity a b -> Time -> a -> (b, SF Identity a b)
evalAt SF Identity a b
sf)

-- * Auxiliary functions

-- ** Event handling
replaceOnce :: Monad m => a -> SF m a a
replaceOnce :: a -> SF m a a
replaceOnce a
a = SF m a (a, Event ()) -> (() -> SF m a a) -> SF m a a
forall (m :: * -> *) a b c.
Monad m =>
SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b
dSwitch ((a -> (a, Event ())) -> SF m a (a, Event ())
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((a -> (a, Event ())) -> SF m a (a, Event ()))
-> (a -> (a, Event ())) -> SF m a (a, Event ())
forall a b. (a -> b) -> a -> b
$ (a, Event ()) -> a -> (a, Event ())
forall a b. a -> b -> a
const (a
a, () -> Event ()
forall a. a -> Event a
Event ())) (SF m a a -> () -> SF m a a
forall a b. a -> b -> a
const (SF m a a -> () -> SF m a a) -> SF m a a -> () -> SF m a a
forall a b. (a -> b) -> a -> b
$ (a -> a) -> SF m a a
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a -> a
forall a. a -> a
id)

-- ** Tuples
dup :: b -> (b, b)
dup  b
x     = (b
x,b
x)