{-# 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 :: (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) let ct :: SF m a (col b) ct = case Event c e of Event c c -> col (SF m a b) -> c -> SF m a (col b) sfCs col (SF m a b) sfs' c c Event c NoEvent -> 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. (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. MSF m a ((Time, a), Maybe a) senseFirst a -> MSF m a (Time, a) forall a. a -> MSF m a (Time, a) senseRest senseFirst :: MSF m a ((Time, a), Maybe a) senseFirst = m a -> MSF m a a forall (m :: * -> *) b a. Monad m => m b -> MSF m a b constM m a senseI MSF m a a -> MSF m a ((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 >>> ((a -> ((Time, a), Maybe a)) -> MSF m a ((Time, a), Maybe a) forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c arr ((a -> ((Time, a), Maybe a)) -> MSF m a ((Time, a), Maybe a)) -> (a -> ((Time, a), Maybe a)) -> MSF m a ((Time, a), Maybe a) forall a b. (a -> b) -> a -> b $ \a x -> ((Time 0, a x), a -> Maybe a forall a. a -> Maybe a Just a x)) 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)