{-# LANGUAGE CPP        #-}
{-# LANGUAGE GADTs      #-}
{-# LANGUAGE Rank2Types #-}
-- |
-- Module      :  FRP.Yampa.EventS
-- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003
-- License     :  BSD-style (see the LICENSE file in the distribution)
--
-- Maintainer  :  ivan.perez@keera.co.uk
-- Stability   :  provisional
-- Portability :  non-portable (GHC extensions)
--
-- Event Signal Functions and SF combinators.
--
-- Events represent values that only exist instantaneously, at discrete points
-- in time. Examples include mouse clicks, zero-crosses of monotonic continuous
-- signals, and square waves.
--
-- For signals that carry events, there should be a limit in the number of
-- events we can observe in a time period, no matter how much we increase the
-- sampling frequency.


module FRP.Yampa.EventS (

    -- * Basic event sources
    never,              -- :: SF a (Event b)
    now,                -- :: b -> SF a (Event b)
    after,              -- :: Time -> b -> SF a (Event b)
    repeatedly,         -- :: Time -> b -> SF a (Event b)
    afterEach,          -- :: [(Time,b)] -> SF a (Event b)
    afterEachCat,       -- :: [(Time,b)] -> SF a (Event [b])
    delayEvent,         -- :: Time -> SF (Event a) (Event a)
    delayEventCat,      -- :: Time -> SF (Event a) (Event [a])
    edge,               -- :: SF Bool (Event ())
    iEdge,              -- :: Bool -> SF Bool (Event ())
    edgeTag,            -- :: a -> SF Bool (Event a)
    edgeJust,           -- :: SF (Maybe a) (Event a)
    edgeBy,             -- :: (a -> a -> Maybe b) -> a -> SF a (Event b)

    -- * Stateful event suppression
    notYet,             -- :: SF (Event a) (Event a)
    once,               -- :: SF (Event a) (Event a)
    takeEvents,         -- :: Int -> SF (Event a) (Event a)
    dropEvents,         -- :: Int -> SF (Event a) (Event a)

    -- * Hybrid SF combinators
    snap,               -- :: SF a (Event a)
    snapAfter,          -- :: Time -> SF a (Event a)
    sample,             -- :: Time -> SF a (Event a)
    sampleWindow,       -- :: Int -> Time -> SF a (Event [a])

    -- * Repetition and switching
    recur,              -- :: SF a (Event b) -> SF a (Event b)
    andThen             -- :: SF a (Event b) -> SF a (Event b) -> SF a (Event b)

) where

import Control.Arrow

import FRP.Yampa.InternalCore (SF(..), sfConst, Time, SF'(..))

import FRP.Yampa.Arrow
import FRP.Yampa.Basic
import FRP.Yampa.Diagnostics
import FRP.Yampa.Event
import FRP.Yampa.Hybrid
import FRP.Yampa.Scan
import FRP.Yampa.Switches

infixr 5 `andThen`

-- -- The event-processing function *could* accept the present NoEvent
-- -- output as an extra state argument. That would facilitate composition
-- -- of event-processing functions somewhat, but would presumably incur an
-- -- extra cost for the more common and simple case of non-composed event
-- -- processors.
--
-- sfEP :: (c -> a -> (c, b, b)) -> c -> b -> SF' (Event a) b
-- sfEP f c bne = sf
--     where
--         sf = SFEP (\_ ea -> case ea of
--                                  NoEvent -> (sf, bne)
--                                  Event a -> let
--                                                 (c', b, bne') = f c a
--                                             in
--                                                 (sfEP f c' bne', b))
--                   f
--                   c
--                   bne
--
--
-- -- epPrim is used to define hold, accum, and other event-processing
-- -- functions.
-- epPrim :: (c -> a -> (c, b, b)) -> c -> b -> SF (Event a) b
-- epPrim f c bne = SF {sfTF = tf0}
--     where
--         tf0 NoEvent   = (sfEP f c bne, bne)
--         tf0 (Event a) = let
--                             (c', b, bne') = f c a
--                         in
--                             (sfEP f c' bne', b)


-- -- !!! Maybe something like this?
-- -- !!! But one problem is that the invarying marking would be lost
-- -- !!! if the signal function is taken apart and re-constructed from
-- -- !!! the function description and subordinate signal function in
-- -- !!! cases like SFCpAXA.
-- sfMkInv :: SF a b -> SF a b
-- sfMkInv sf = SF {sfTF = ...}
--
--     sfMkInvAux :: SF' a b -> SF' a b
--     sfMkInvAux sf@(SFArr _ _) = sf
--     -- sfMkInvAux sf@(SFAcc _ _ _ _) = sf
--     sfMkInvAux sf@(SFEP _ _ _ _) = sf
--     sfMkInvAux sf@(SFCpAXA tf inv fd1 sf2 fd3)
--         | inv       = sf
--         | otherwise = SFCpAXA tf' True fd1 sf2 fd3
--         where
--             tf' = \dt a -> let (sf', b) = tf dt a in (sfMkInvAux sf', b)
--     sfMkInvAux sf@(SF' tf inv)
--         | inv       = sf
--         | otherwise = SF' tf' True
--             tf' =

------------------------------------------------------------------------------
-- Basic event sources
------------------------------------------------------------------------------

-- | Event source that never occurs.
{-# ANN never "HLint: ignore Use const" #-}
never :: SF a (Event b)
never :: SF a (Event b)
never = SF :: forall a b. (a -> Transition a b) -> SF a b
SF {sfTF :: a -> Transition a (Event b)
sfTF = \a
_ -> (SF' a (Event b)
forall a b. SF' a (Event b)
sfNever, Event b
forall a. Event a
NoEvent)}

sfNever :: SF' a (Event b)
sfNever :: SF' a (Event b)
sfNever = Event b -> SF' a (Event b)
forall b a. b -> SF' a b
sfConst 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 :: b -> SF a (Event b)
now :: b -> SF a (Event b)
now b
b0 = b -> Event b
forall a. a -> Event a
Event b
b0 Event b -> SF a (Event b) -> SF a (Event b)
forall b a. b -> SF a b -> SF a b
--> SF a (Event b)
forall a b. SF a (Event b)
never


-- | Event source with a single occurrence at or as soon after (local) time /q/
-- as possible.
after :: Time -- ^ The time /q/ after which the event should be produced
      -> b    -- ^ Value to produce at that time
      -> SF a (Event b)
after :: Time -> b -> SF a (Event b)
after Time
q b
x = [(Time, b)] -> SF a (Event b)
forall b a. [(Time, b)] -> SF a (Event b)
afterEach [(Time
q,b
x)]

-- | Event source with repeated occurrences with interval q.
-- Note: If the interval is too short w.r.t. the sampling intervals,
-- the result will be that events occur at every sample. However, no more
-- than one event results from any sampling interval, thus avoiding an
-- "event backlog" should sampling become more frequent at some later
-- point in time.

-- !!! 2005-03-30:  This is potentially a bit inefficient since we KNOW
-- !!! (at this level) that the SF is going to be invarying. But afterEach
-- !!! does NOT know this as the argument list may well be finite.
-- !!! We could use sfMkInv, but that's not without problems.
-- !!! We're probably better off specializing afterEachCat here.

repeatedly :: Time -> b -> SF a (Event b)
repeatedly :: Time -> b -> SF 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 a (Event b)
forall b a. [(Time, b)] -> SF a (Event b)
afterEach [(Time, b)]
qxs
               | Bool
otherwise = String -> String -> String -> SF a (Event b)
forall a. String -> String -> String -> a
usrErr String
"AFRP" String
"repeatedly" String
"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.
-- Question: Should positive periods except for the first one be required?
-- Note that periods of length 0 will always be skipped except for the first.
-- Right now, periods of length 0 is allowed on the grounds that no attempt
-- is made to forbid simultaneous events elsewhere.
{-
afterEach :: [(Time,b)] -> SF a (Event b)
afterEach [] = never
afterEach ((q,x):qxs)
    | q < 0     = usrErr "AFRP" "afterEach" "Negative period."
    | otherwise = SF {sfTF = tf0}
    where
        tf0 _ = if q <= 0 then
                    (scheduleNextEvent 0.0 qxs, Event x)
                else
                    (awaitNextEvent (-q) x qxs, NoEvent)

        scheduleNextEvent t [] = sfNever
        scheduleNextEvent t ((q,x):qxs)
            | q < 0     = usrErr "AFRP" "afterEach" "Negative period."
            | t' >= 0   = scheduleNextEvent t' qxs
            | otherwise = awaitNextEvent t' x qxs
            where
                t' = t - q
        awaitNextEvent t x qxs = SF' {sfTF' = tf}
            where
                tf dt _ | t' >= 0   = (scheduleNextEvent t' qxs, Event x)
                        | otherwise = (awaitNextEvent t' x qxs, NoEvent)
                    where
                        t' = t + dt
-}

-- | 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 :: [(Time,b)] -> SF a (Event b)
afterEach :: [(Time, b)] -> SF a (Event b)
afterEach [(Time, b)]
qxs = [(Time, b)] -> SF a (Event [b])
forall b a. [(Time, b)] -> SF a (Event [b])
afterEachCat [(Time, b)]
qxs SF a (Event [b]) -> SF (Event [b]) (Event b) -> SF 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) -> SF (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.

-- Guaranteed not to miss any events.
afterEachCat :: [(Time,b)] -> SF a (Event [b])
afterEachCat :: [(Time, b)] -> SF a (Event [b])
afterEachCat [] = SF a (Event [b])
forall a b. SF a (Event b)
never
afterEachCat ((Time
q,b
x):[(Time, b)]
qxs)
    | Time
q Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
0     = String -> String -> String -> SF a (Event [b])
forall a. String -> String -> String -> a
usrErr String
"AFRP" String
"afterEachCat" String
"Negative period."
    | Bool
otherwise = SF :: forall a b. (a -> Transition a b) -> SF a b
SF {sfTF :: a -> Transition a (Event [b])
sfTF = a -> Transition a (Event [b])
tf0}
    where
        tf0 :: a -> Transition a (Event [b])
tf0 a
_ = if Time
q Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
<= Time
0 then
                    Time -> [b] -> [(Time, b)] -> Transition a (Event [b])
forall a p.
Time -> [a] -> [(Time, a)] -> (SF' p (Event [a]), Event [a])
emitEventsScheduleNext Time
0.0 [b
x] [(Time, b)]
qxs
                else
                    (Time -> b -> [(Time, b)] -> SF' a (Event [b])
forall a p. Time -> a -> [(Time, a)] -> SF' p (Event [a])
awaitNextEvent (-Time
q) b
x [(Time, b)]
qxs, Event [b]
forall a. Event a
NoEvent)

        emitEventsScheduleNext :: Time -> [a] -> [(Time, a)] -> (SF' p (Event [a]), Event [a])
emitEventsScheduleNext Time
_ [a]
xs [] = (SF' p (Event [a])
forall a b. SF' a (Event b)
sfNever, [a] -> Event [a]
forall a. a -> Event a
Event ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
xs))
        emitEventsScheduleNext Time
t [a]
xs ((Time
q,a
x):[(Time, a)]
qxs)
            | Time
q Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
0     = String -> String -> String -> (SF' p (Event [a]), Event [a])
forall a. String -> String -> String -> a
usrErr String
"AFRP" String
"afterEachCat" String
"Negative period."
            | Time
t' Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Time
0   = Time -> [a] -> [(Time, a)] -> (SF' p (Event [a]), Event [a])
emitEventsScheduleNext Time
t' (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs) [(Time, a)]
qxs
            | Bool
otherwise = (Time -> a -> [(Time, a)] -> SF' p (Event [a])
awaitNextEvent Time
t' a
x [(Time, a)]
qxs, [a] -> Event [a]
forall a. a -> Event a
Event ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
xs))
            where
                t' :: Time
t' = Time
t Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
q
        awaitNextEvent :: Time -> a -> [(Time, a)] -> SF' p (Event [a])
awaitNextEvent Time
t a
x [(Time, a)]
qxs = (Time -> p -> (SF' p (Event [a]), Event [a])) -> SF' p (Event [a])
forall a b. (Time -> a -> Transition a b) -> SF' a b
SF' Time -> p -> (SF' p (Event [a]), Event [a])
tf -- False
            where
                tf :: Time -> p -> (SF' p (Event [a]), Event [a])
tf Time
dt p
_ | Time
t' Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Time
0   = Time -> [a] -> [(Time, a)] -> (SF' p (Event [a]), Event [a])
emitEventsScheduleNext Time
t' [a
x] [(Time, a)]
qxs
                        | Bool
otherwise = (Time -> a -> [(Time, a)] -> SF' p (Event [a])
awaitNextEvent Time
t' a
x [(Time, a)]
qxs, Event [a]
forall a. Event a
NoEvent)
                    where
                        t' :: Time
t' = Time
t Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
dt

-- | Delay for events. (Consider it a triggered after, hence /basic/.)

-- Can be implemented fairly cheaply as long as the events are sparse.
-- It is a question of rescheduling events for later. Not unlike "afterEach".
--
-- It is not exactly the case that delayEvent t = delay t NoEvent
-- since the rules for dropping/extrapolating samples are different.
-- A single event occurrence will never be duplicated.
-- If there is an event occurrence, one will be output as soon as
-- possible after the given delay time, but not necessarily that
-- one.  See delayEventCat.

delayEvent :: Time -> SF (Event a) (Event a)
delayEvent :: Time -> SF (Event a) (Event a)
delayEvent Time
q | Time
q Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
0     = String -> String -> String -> SF (Event a) (Event a)
forall a. String -> String -> String -> a
usrErr String
"AFRP" String
"delayEvent" String
"Negative delay."
             | Time
q Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
0    = SF (Event a) (Event a)
forall a. SF a a
identity
             | Bool
otherwise = Time -> SF (Event a) (Event [a])
forall a. Time -> SF (Event a) (Event [a])
delayEventCat Time
q SF (Event a) (Event [a])
-> SF (Event [a]) (Event a) -> SF (Event a) (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 [a] -> Event a) -> SF (Event [a]) (Event a)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (([a] -> a) -> Event [a] -> Event a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> a
forall a. [a] -> a
head)


-- There is no *guarantee* above that every event actually will be
-- rescheduled since the sampling frequency (temporarily) might drop.
-- The following interface would allow ALL scheduled events to occur
-- as soon as possible:
-- (Read "delay event and catenate events that occur so closely so as to be
-- inseparable".)
-- The events in the list are ordered temporally to the extent possible.

-- -- This version is too strict!
-- delayEventCat :: Time -> SF (Event a) (Event [a])
-- delayEventCat q | q < 0     = usrErr "AFRP" "delayEventCat" "Negative delay."
--                 | q == 0    = arr (fmap (:[]))
--                 | otherwise = SF {sfTF = tf0}
--   where
--       tf0 NoEvent   = (noPendingEvent, NoEvent)
--       tf0 (Event x) = (pendingEvents (-q) [] [] (-q) x, NoEvent)
--
--       noPendingEvent = SF' tf -- True
--           where
--               tf _ NoEvent   = (noPendingEvent, NoEvent)
--               tf _ (Event x) = (pendingEvents (-q) [] [] (-q) x, NoEvent)
--
--       -- t_next is the present time w.r.t. the next scheduled event.
--       -- t_last is the present time w.r.t. the last scheduled event.
--       -- In the event queues, events are associated with their time
--       -- w.r.t. to preceding event (positive).
--       pendingEvents t_last rqxs qxs t_next x = SF' tf -- True
--           where
--               tf dt NoEvent    = tf1 (t_last + dt) rqxs (t_next + dt)
--               tf dt (Event x') = tf1 (-q) ((q', x') : rqxs) t_next'
--                   where
--                       t_next' = t_next  + dt
--                       t_last' = t_last  + dt
--                       q'      = t_last' + q
--
--               tf1 t_last' rqxs' t_next'
--                   | t_next' >= 0 =
--                       emitEventsScheduleNext t_last' rqxs' qxs t_next' [x]
--                   | otherwise =
--                       (pendingEvents t_last' rqxs' qxs t_next' x, NoEvent)
--
--       -- t_next is the present time w.r.t. the *scheduled* time of the
--       -- event that is about to be emitted (i.e. >= 0).
--       -- The time associated with any event at the head of the event
--       -- queue is also given w.r.t. the event that is about to be emitted.
--       -- Thus, t_next - q' is the present time w.r.t. the event at the head
--       -- of the event queue.
--       emitEventsScheduleNext t_last [] [] t_next rxs =
--           (noPendingEvent, Event (reverse rxs))
--       emitEventsScheduleNext t_last rqxs [] t_next rxs =
--           emitEventsScheduleNext t_last [] (reverse rqxs) t_next rxs
--       emitEventsScheduleNext t_last rqxs ((q', x') : qxs') t_next rxs
--           | q' > t_next = (pendingEvents t_last rqxs qxs' (t_next - q') x',
--                            Event (reverse rxs))
--           | otherwise   = emitEventsScheduleNext t_last rqxs qxs' (t_next-q')
--                                                  (x' : rxs)

-- | Delay an event by a given delta and catenate events that occur so closely
-- so as to be /inseparable/.
delayEventCat :: Time -> SF (Event a) (Event [a])
delayEventCat :: Time -> SF (Event a) (Event [a])
delayEventCat Time
q | Time
q Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
0     = String -> String -> String -> SF (Event a) (Event [a])
forall a. String -> String -> String -> a
usrErr String
"AFRP" String
"delayEventCat" String
"Negative delay."
                | Time
q Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
0    = (Event a -> Event [a]) -> SF (Event a) (Event [a])
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((a -> [a]) -> Event a -> Event [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[]))
                | Bool
otherwise = SF :: forall a b. (a -> Transition a b) -> SF a b
SF {sfTF :: Event a -> Transition (Event a) (Event [a])
sfTF = Event a -> Transition (Event a) (Event [a])
tf0}
    where
        tf0 :: Event a -> Transition (Event a) (Event [a])
tf0 Event a
e = (case Event a
e of
                     Event a
NoEvent -> SF' (Event a) (Event [a])
noPendingEvent
                     Event a
x -> Time
-> [(Time, a)]
-> [(Time, a)]
-> Time
-> a
-> SF' (Event a) (Event [a])
pendingEvents (-Time
q) [] [] (-Time
q) a
x,
                 Event [a]
forall a. Event a
NoEvent)

        noPendingEvent :: SF' (Event a) (Event [a])
noPendingEvent = (Time -> Event a -> Transition (Event a) (Event [a]))
-> SF' (Event a) (Event [a])
forall a b. (Time -> a -> Transition a b) -> SF' a b
SF' Time -> Event a -> Transition (Event a) (Event [a])
tf -- True
            where
                tf :: Time -> Event a -> Transition (Event a) (Event [a])
tf Time
_ Event a
e = (case Event a
e of
                              Event a
NoEvent -> SF' (Event a) (Event [a])
noPendingEvent
                              Event a
x -> Time
-> [(Time, a)]
-> [(Time, a)]
-> Time
-> a
-> SF' (Event a) (Event [a])
pendingEvents (-Time
q) [] [] (-Time
q) a
x,
                          Event [a]
forall a. Event a
NoEvent)

        -- t_next is the present time w.r.t. the next scheduled event.
        -- t_last is the present time w.r.t. the last scheduled event.
        -- In the event queues, events are associated with their time
        -- w.r.t. to preceding event (positive).
        pendingEvents :: Time
-> [(Time, a)]
-> [(Time, a)]
-> Time
-> a
-> SF' (Event a) (Event [a])
pendingEvents Time
t_last [(Time, a)]
rqxs [(Time, a)]
qxs Time
t_next a
x = (Time -> Event a -> Transition (Event a) (Event [a]))
-> SF' (Event a) (Event [a])
forall a b. (Time -> a -> Transition a b) -> SF' a b
SF' Time -> Event a -> Transition (Event a) (Event [a])
tf -- True
            where
                tf :: Time -> Event a -> Transition (Event a) (Event [a])
tf Time
dt Event a
e
                    | Time
t_next' Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Time
0 =
                        Event a
-> Time
-> [(Time, a)]
-> [(Time, a)]
-> Time
-> [a]
-> Transition (Event a) (Event [a])
emitEventsScheduleNext Event a
e Time
t_last' [(Time, a)]
rqxs [(Time, a)]
qxs Time
t_next' [a
x]
                    | Bool
otherwise    =
                        (Time
-> [(Time, a)]
-> [(Time, a)]
-> Time
-> a
-> SF' (Event a) (Event [a])
pendingEvents Time
t_last'' [(Time, a)]
rqxs' [(Time, a)]
qxs Time
t_next' a
x, Event [a]
forall a. Event a
NoEvent)
                    where
                        t_next' :: Time
t_next' = Time
t_next  Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
dt
                        t_last' :: Time
t_last' = Time
t_last  Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
dt
                        (Time
t_last'', [(Time, a)]
rqxs') =
                            case Event a
e of
                                Event a
NoEvent  -> (Time
t_last', [(Time, a)]
rqxs)
                                Event a
x' -> (-Time
q, (Time
t_last'Time -> Time -> Time
forall a. Num a => a -> a -> a
+Time
q,a
x') (Time, a) -> [(Time, a)] -> [(Time, a)]
forall a. a -> [a] -> [a]
: [(Time, a)]
rqxs)

        -- t_next is the present time w.r.t. the *scheduled* time of the
        -- event that is about to be emitted (i.e. >= 0).
        -- The time associated with any event at the head of the event
        -- queue is also given w.r.t. the event that is about to be emitted.
        -- Thus, t_next - q' is the present time w.r.t. the event at the head
        -- of the event queue.
        emitEventsScheduleNext :: Event a
-> Time
-> [(Time, a)]
-> [(Time, a)]
-> Time
-> [a]
-> Transition (Event a) (Event [a])
emitEventsScheduleNext Event a
e Time
_ [] [] Time
_ [a]
rxs =
            (case Event a
e of
                 Event a
NoEvent -> SF' (Event a) (Event [a])
noPendingEvent
                 Event a
x -> Time
-> [(Time, a)]
-> [(Time, a)]
-> Time
-> a
-> SF' (Event a) (Event [a])
pendingEvents (-Time
q) [] [] (-Time
q) a
x,
             [a] -> Event [a]
forall a. a -> Event a
Event ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
rxs))
        emitEventsScheduleNext Event a
e Time
t_last [(Time, a)]
rqxs [] Time
t_next [a]
rxs =
            Event a
-> Time
-> [(Time, a)]
-> [(Time, a)]
-> Time
-> [a]
-> Transition (Event a) (Event [a])
emitEventsScheduleNext Event a
e Time
t_last [] ([(Time, a)] -> [(Time, a)]
forall a. [a] -> [a]
reverse [(Time, a)]
rqxs) Time
t_next [a]
rxs
        emitEventsScheduleNext Event a
e Time
t_last [(Time, a)]
rqxs ((Time
q', a
x') : [(Time, a)]
qxs') Time
t_next [a]
rxs
            | Time
q' Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
> Time
t_next = (case Event a
e of
                                 Event a
NoEvent ->
                                     Time
-> [(Time, a)]
-> [(Time, a)]
-> Time
-> a
-> SF' (Event a) (Event [a])
pendingEvents Time
t_last
                                                   [(Time, a)]
rqxs
                                                   [(Time, a)]
qxs'
                                                   (Time
t_next Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
q')
                                                   a
x'
                                 Event a
x'' ->
                                     Time
-> [(Time, a)]
-> [(Time, a)]
-> Time
-> a
-> SF' (Event a) (Event [a])
pendingEvents (-Time
q)
                                                   ((Time
t_lastTime -> Time -> Time
forall a. Num a => a -> a -> a
+Time
q, a
x'') (Time, a) -> [(Time, a)] -> [(Time, a)]
forall a. a -> [a] -> [a]
: [(Time, a)]
rqxs)
                                                   [(Time, a)]
qxs'
                                                   (Time
t_next Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
q')
                                                   a
x',
                             [a] -> Event [a]
forall a. a -> Event a
Event ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
rxs))
            | Bool
otherwise   = Event a
-> Time
-> [(Time, a)]
-> [(Time, a)]
-> Time
-> [a]
-> Transition (Event a) (Event [a])
emitEventsScheduleNext Event a
e
                                                   Time
t_last
                                                   [(Time, a)]
rqxs
                                                   [(Time, a)]
qxs'
                                                   (Time
t_next Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
q')
                                                   (a
x' a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
rxs)


-- | A rising edge detector. Useful for things like detecting key presses.
-- It is initialised as /up/, meaning that events occuring at time 0 will
-- not be detected.

-- Note that we initialize the loop with state set to True so that there
-- will not be an occurence at t0 in the logical time frame in which
-- this is started.
edge :: SF Bool (Event ())
edge :: SF Bool (Event ())
edge = Bool -> SF Bool (Event ())
iEdge Bool
True

-- | A rising edge detector that can be initialized as up ('True', meaning
--   that events occurring at time 0 will not be detected) or down
--   ('False', meaning that events ocurring at time 0 will be detected).
iEdge :: Bool -> SF Bool (Event ())
-- iEdge i = edgeBy (isBoolRaisingEdge ()) i
iEdge :: Bool -> SF Bool (Event ())
iEdge Bool
b = (Int -> Bool -> Maybe (Int, Event ()))
-> Int -> Event () -> SF Bool (Event ())
forall c a b. (c -> a -> Maybe (c, b)) -> c -> b -> SF a b
sscanPrim Int -> Bool -> Maybe (Int, Event ())
f (if Bool
b then Int
2 else Int
0) Event ()
forall a. Event a
NoEvent
    where
        f :: Int -> Bool -> Maybe (Int, Event ())
        f :: Int -> Bool -> Maybe (Int, Event ())
f Int
0 Bool
False = Maybe (Int, Event ())
forall a. Maybe a
Nothing
        f Int
0 Bool
True  = (Int, Event ()) -> Maybe (Int, Event ())
forall a. a -> Maybe a
Just (Int
1, () -> Event ()
forall a. a -> Event a
Event ())
        f Int
1 Bool
False = (Int, Event ()) -> Maybe (Int, Event ())
forall a. a -> Maybe a
Just (Int
0, Event ()
forall a. Event a
NoEvent)
        f Int
1 Bool
True  = (Int, Event ()) -> Maybe (Int, Event ())
forall a. a -> Maybe a
Just (Int
2, Event ()
forall a. Event a
NoEvent)
        f Int
2 Bool
False = (Int, Event ()) -> Maybe (Int, Event ())
forall a. a -> Maybe a
Just (Int
0, Event ()
forall a. Event a
NoEvent)
        f Int
2 Bool
True  = Maybe (Int, Event ())
forall a. Maybe a
Nothing
        f Int
_ Bool
_     = Maybe (Int, Event ())
forall a. HasCallStack => a
undefined

-- | Like 'edge', but parameterized on the tag value.
edgeTag :: a -> SF Bool (Event a)
-- edgeTag a = edgeBy (isBoolRaisingEdge a) True
edgeTag :: a -> SF Bool (Event a)
edgeTag a
a = SF Bool (Event ())
edge SF Bool (Event ()) -> SF (Event ()) (Event a) -> SF 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) -> SF (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)

-- Internal utility.
-- isBoolRaisingEdge :: a -> Bool -> Bool -> Maybe a
-- isBoolRaisingEdge _ False False = Nothing
-- isBoolRaisingEdge a False True  = Just a
-- isBoolRaisingEdge _ True  True  = Nothing
-- isBoolRaisingEdge _ True  False = Nothing

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

-- !!! 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 :: SF (Maybe a) (Event a)
edgeJust :: SF (Maybe a) (Event a)
edgeJust = (Maybe a -> Maybe a -> Maybe a)
-> Maybe a -> SF (Maybe a) (Event a)
forall a b. (a -> a -> Maybe b) -> a -> SF 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

-- | Edge detector parameterized on the edge detection function and initial
-- state, i.e., the previous input sample. The first argument to the
-- edge detection function is the previous sample, the second the current one.

-- !!! Is this broken!?! Does not disallow an edge condition that persists
-- !!! between consecutive samples. See discussion in ToDo list above.
-- !!! 2005-07-09: To be done.
edgeBy :: (a -> a -> Maybe b) -> a -> SF a (Event b)
edgeBy :: (a -> a -> Maybe b) -> a -> SF a (Event b)
edgeBy a -> a -> Maybe b
isEdge a
a_init = SF :: forall a b. (a -> Transition a b) -> SF a b
SF {sfTF :: a -> Transition a (Event b)
sfTF = a -> Transition a (Event b)
tf0}
    where
        tf0 :: a -> Transition a (Event b)
tf0 a
a0 = (a -> SF' a (Event b)
ebAux a
a0, Maybe b -> Event b
forall a. Maybe a -> Event a
maybeToEvent (a -> a -> Maybe b
isEdge a
a_init a
a0))

        ebAux :: a -> SF' a (Event b)
ebAux a
a_prev = (Time -> a -> Transition a (Event b)) -> SF' a (Event b)
forall a b. (Time -> a -> Transition a b) -> SF' a b
SF' Time -> a -> Transition a (Event b)
tf -- True
            where
                tf :: Time -> a -> Transition a (Event b)
tf Time
_ a
a = (a -> SF' a (Event b)
ebAux a
a, Maybe b -> Event b
forall a. Maybe a -> Event a
maybeToEvent (a -> a -> Maybe b
isEdge a
a_prev a
a))


------------------------------------------------------------------------------
-- Stateful event suppression
------------------------------------------------------------------------------

-- | Suppression of initial (at local time 0) event.
notYet :: SF (Event a) (Event a)
notYet :: SF (Event a) (Event a)
notYet = Event a -> SF (Event a) (Event a)
forall a. a -> SF a a
initially Event a
forall a. Event a
NoEvent


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


-- | Suppress all but the first n events.
takeEvents :: Int -> SF (Event a) (Event a)
takeEvents :: Int -> SF (Event a) (Event a)
takeEvents Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = SF (Event a) (Event a)
forall a b. SF a (Event b)
never
takeEvents Int
n = SF (Event a) (Event a, Event a)
-> (a -> SF (Event a) (Event a)) -> SF (Event a) (Event a)
forall a b c. SF a (b, Event c) -> (c -> SF a b) -> SF a b
dSwitch ((Event a -> (Event a, Event a)) -> SF (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 a. a -> (a, a)
dup) (SF (Event a) (Event a) -> a -> SF (Event a) (Event a)
forall a b. a -> b -> a
const (Event a
forall a. Event a
NoEvent Event a -> SF (Event a) (Event a) -> SF (Event a) (Event a)
forall a b. a -> SF a b -> SF a b
>-- Int -> SF (Event a) (Event a)
forall a. Int -> SF (Event a) (Event a)
takeEvents (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)))


{-
-- More complicated using "switch" that "dSwitch".
takeEvents :: Int -> SF (Event a) (Event a)
takeEvents 0       = never
takeEvents (n + 1) = switch (never &&& identity) (takeEvents' n)
    where
        takeEvents' 0       a = now a
        takeEvents' (n + 1) a = switch (now a &&& notYet) (takeEvents' n)
-}


-- | Suppress first n events.

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


-- ** Hybrid continuous-to-discrete SF combinators.

-- | Event source with a single occurrence at time 0. The value of the event is
-- obtained by sampling the input at that time.

-- (The outer "switch" ensures that the entire signal function will become
-- just "constant" once the sample has been taken.)
snap :: SF a (Event a)
snap :: SF a (Event a)
snap = SF a (Event a, Event a) -> (a -> SF a (Event a)) -> SF a (Event a)
forall a b c. SF a (b, Event c) -> (c -> SF a b) -> SF a b
switch (SF a (Event a)
forall a b. SF a (Event b)
never SF a (Event a) -> SF a (Event a) -> SF a (Event a, Event a)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (SF a a
forall a. SF a a
identity SF a a -> SF a (Event ()) -> SF a (a, Event ())
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& () -> SF a (Event ())
forall b a. b -> SF a (Event b)
now () SF a (a, Event ()) -> ((a, Event ()) -> Event a) -> SF a (Event a)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ \(a
a, Event ()
e) -> Event ()
e Event () -> a -> Event a
forall a b. Event a -> b -> Event b
`tag` a
a)) a -> SF a (Event a)
forall b a. b -> SF a (Event b)
now


-- | Event source with a single occurrence at or as soon after (local) time
-- @t_ev@ as possible. The value of the event is obtained by sampling the input
-- a that time.
snapAfter :: Time -> SF a (Event a)
snapAfter :: Time -> SF a (Event a)
snapAfter Time
t_ev = SF a (Event a, Event a) -> (a -> SF a (Event a)) -> SF a (Event a)
forall a b c. SF a (b, Event c) -> (c -> SF a b) -> SF a b
switch (SF a (Event a)
forall a b. SF a (Event b)
never
             SF a (Event a) -> SF a (Event a) -> SF a (Event a, Event a)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (SF a a
forall a. SF a a
identity
                  SF a a -> SF a (Event ()) -> SF a (a, Event ())
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Time -> () -> SF a (Event ())
forall b a. Time -> b -> SF a (Event b)
after Time
t_ev () SF a (a, Event ()) -> ((a, Event ()) -> Event a) -> SF a (Event a)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ \(a
a, Event ()
e) -> Event ()
e Event () -> a -> Event a
forall a b. Event a -> b -> Event b
`tag` a
a))
            a -> SF a (Event a)
forall b a. b -> SF a (Event b)
now


-- | Sample a signal at regular intervals.
sample :: Time -> SF a (Event a)
sample :: Time -> SF a (Event a)
sample Time
p_ev = SF a a
forall a. SF a a
identity SF a a -> SF a (Event ()) -> SF a (a, Event ())
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Time -> () -> SF a (Event ())
forall b a. Time -> b -> SF a (Event b)
repeatedly Time
p_ev () SF a (a, Event ()) -> ((a, Event ()) -> Event a) -> SF a (Event a)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ \(a
a, Event ()
e) -> Event ()
e Event () -> a -> Event a
forall a b. Event a -> b -> Event b
`tag` a
a

-- | Window sampling
--
-- First argument is the window length wl, second is the sampling interval t.
-- The output list should contain (min (truncate (T/t) wl)) samples, where
-- T is the time the signal function has been running. This requires some
-- care in case of sparse sampling. In case of sparse sampling, the
-- current input value is assumed to have been present at all points where
-- sampling was missed.
sampleWindow :: Int -> Time -> SF a (Event [a])
sampleWindow :: Int -> Time -> SF a (Event [a])
sampleWindow Int
wl Time
q =
    SF a a
forall a. SF a a
identity SF a a -> SF a (Event [()]) -> SF a (a, Event [()])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& [(Time, ())] -> SF a (Event [()])
forall b a. [(Time, b)] -> SF a (Event [b])
afterEachCat ((Time, ()) -> [(Time, ())]
forall a. a -> [a]
repeat (Time
q, ()))
    SF a (a, Event [()])
-> SF (a, Event [()]) (Event [a]) -> SF a (Event [a])
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((a, Event [()]) -> Event [a]) -> SF (a, Event [()]) (Event [a])
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\(a
a, Event [()]
e) -> ([()] -> [a]) -> Event [()] -> Event [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((() -> a) -> [()] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a -> () -> a
forall a b. a -> b -> a
const a
a)) Event [()]
e)
    SF (a, Event [()]) (Event [a])
-> SF (Event [a]) (Event [a]) -> SF (a, Event [()]) (Event [a])
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ([a] -> [a] -> [a]) -> [a] -> SF (Event [a]) (Event [a])
forall b a. (b -> a -> b) -> b -> SF (Event a) (Event b)
accumBy [a] -> [a] -> [a]
updateWindow []
    where
        updateWindow :: [a] -> [a] -> [a]
updateWindow [a]
w [a]
as = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
w' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
wl) Int
0) [a]
w'
            where w' :: [a]
w' = [a]
w [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
as

-- * Repetition and switching

-- | Makes an event source recurring by restarting it as soon as it has an
-- occurrence.

-- !!! What about event sources that have an instantaneous occurrence?
-- !!! E.g. recur (now ()).
-- !!! Or worse, what about recur identity? (or substitute identity for
-- !!! a more sensible definition that e.g. merges any incoming event
-- !!! with an internally generated one, for example)
-- !!! Possibly we should ignore instantaneous reoccurrences.
-- New definition:
recur :: SF a (Event b) -> SF a (Event b)
recur :: SF a (Event b) -> SF a (Event b)
recur SF a (Event b)
sfe = SF a (Event b, Event b) -> (b -> SF a (Event b)) -> SF a (Event b)
forall a b c. SF a (b, Event c) -> (c -> SF a b) -> SF a b
switch (SF a (Event b)
forall a b. SF a (Event b)
never SF a (Event b) -> SF a (Event b) -> SF a (Event b, Event b)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& SF a (Event b)
sfe) ((b -> SF a (Event b)) -> SF a (Event b))
-> (b -> SF a (Event b)) -> SF a (Event b)
forall a b. (a -> b) -> a -> b
$ \b
b -> b -> Event b
forall a. a -> Event a
Event b
b Event b -> SF a (Event b) -> SF a (Event b)
forall b a. b -> SF a b -> SF a b
--> (SF a (Event b) -> SF a (Event b)
forall a b. SF a (Event b) -> SF a (Event b)
recur (Event b
forall a. Event a
NoEventEvent b -> SF a (Event b) -> SF a (Event b)
forall b a. b -> SF a b -> SF a b
-->SF a (Event b)
sfe))

-- | Apply the first SF until it produces an event, and, afterwards, switch to
-- the second SF. This is just a convenience function, used to write what
-- sometimes is more understandable switch-based code.
andThen :: SF a (Event b) -> SF a (Event b) -> SF a (Event b)
SF a (Event b)
sfe1 andThen :: SF a (Event b) -> SF a (Event b) -> SF a (Event b)
`andThen` SF a (Event b)
sfe2 = SF a (Event b, Event b) -> (b -> SF a (Event b)) -> SF a (Event b)
forall a b c. SF a (b, Event c) -> (c -> SF a b) -> SF a b
dSwitch (SF a (Event b)
sfe1 SF a (Event b)
-> (Event b -> (Event b, Event b)) -> SF a (Event b, Event b)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ Event b -> (Event b, Event b)
forall a. a -> (a, a)
dup) (SF a (Event b) -> b -> SF a (Event b)
forall a b. a -> b -> a
const SF a (Event b)
sfe2)

{-
recur :: SF a (Event b) -> SF a (Event b)
recur sfe = switch (never &&& sfe) recurAux
    where
    recurAux b = switch (now b &&& sfe) recurAux
-}

-- Vim modeline
-- vim:set tabstop=8 expandtab: