----------------------------------------------------------------------------------------- -- | -- Module : FRP.Yampa.Utilities -- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003 -- License : BSD-style (see the LICENSE file in the distribution) -- -- Maintainer : nilsson@cs.yale.edu -- Stability : provisional -- Portability : portable -- -- Derived utility definitions. -- -- ToDo: -- -- * Possibly add -- impulse :: VectorSpace a k => a -> Event a -- But to do that, we need access to Event, which we currently do not have. -- -- * The general arrow utilities should be moved to a module -- FRP.Yampa.Utilities. -- -- * I'm not sure structuring the Yampa \"core\" according to what is -- core functionality and what's not is all that useful. There are -- many cases where we want to implement combinators that fairly -- easily could be implemented in terms of others as primitives simply -- because we expect that that implementation is going to be much more -- efficient, and that the combinators are used sufficiently often to -- warrant doing this. E.g. 'switch' should be a primitive, even though -- it could be derived from 'pSwitch'. -- -- * Reconsider 'recur'. If an event source has an immediate occurrence, -- we'll get into a loop. For example: recur now. Maybe suppress -- initial occurrences? Initial occurrences are rather pointless in this -- case anyway. ----------------------------------------------------------------------------------------- module FRP.Yampa.Utilities ( -- Now defined in Control.Arrow -- General arrow utilities (^>>), -- :: Arrow a => (b -> c) -> a c d -> a b d (>>^), -- :: Arrow a => a b c -> (c -> d) -> a b d (^<<), -- :: Arrow a => (c -> d) -> a b c -> a b d (<<^), -- :: Arrow a => a c d -> (b -> c) -> a b d -- Liftings arr2, -- :: Arrow a => (b->c->d) -> a (b,c) d arr3, -- :: Arrow a => (b->c->d->e) -> a (b,c,d) e arr4, -- :: Arrow a => (b->c->d->e->f) -> a (b,c,d,e) f arr5, -- :: Arrow a => (b->c->d->e->f->g) -> a (b,c,d,e,f) g lift0, -- :: Arrow a => c -> a b c lift1, -- :: Arrow a => (c->d) -> (a b c->a b d) lift2, -- :: Arrow a => (c->d->e) -> (a b c->a b d->a b e) lift3, -- :: Arrow a => (c->d->e->f) -> (a b c-> ... ->a b f) lift4, -- :: Arrow a => (c->d->e->f->g) -> (a b c->...->a b g) lift5, -- :: Arrow a => (c->d->e->f->g->h)->(a b c->...a b h) -- Event sources snap, -- :: SF a (Event a) snapAfter, -- :: Time -> SF a (Event a) sample, -- :: Time -> SF a (Event a) recur, -- :: SF a (Event b) -> SF a (Event b) andThen, -- :: SF a (Event b)->SF a (Event b)->SF a (Event b) sampleWindow, -- :: Int -> Time -> SF a (Event [a]) -- Parallel composition/switchers with "zip" routing parZ, -- [SF a b] -> SF [a] [b] pSwitchZ, -- [SF a b] -> SF ([a],[b]) (Event c) -- -> ([SF a b] -> c -> SF [a] [b]) -> SF [a] [b] dpSwitchZ, -- [SF a b] -> SF ([a],[b]) (Event c) -- -> ([SF a b] -> c ->SF [a] [b]) -> SF [a] [b] rpSwitchZ, -- [SF a b] -> SF ([a], Event ([SF a b]->[SF a b])) [b] drpSwitchZ, -- [SF a b] -> SF ([a], Event ([SF a b]->[SF a b])) [b] -- Guards and automata-oriented combinators provided, -- :: (a -> Bool) -> SF a b -> SF a b -> SF a b -- Wave-form generation old_dHold, -- :: a -> SF (Event a) a dTrackAndHold, -- :: a -> SF (Maybe a) a -- Accumulators old_accumHold, -- :: a -> SF (Event (a -> a)) a old_dAccumHold, -- :: a -> SF (Event (a -> a)) a old_accumHoldBy, -- :: (b -> a -> b) -> b -> SF (Event a) b old_dAccumHoldBy, -- :: (b -> a -> b) -> b -> SF (Event a) b count, -- :: Integral b => SF (Event a) (Event b) -- Delays fby, -- :: b -> SF a b -> SF a b, infixr 0 -- Integrals impulseIntegral, -- :: VectorSpace a k => SF (a, Event a) a old_impulseIntegral -- :: VectorSpace a k => SF (a, Event a) a ) where import FRP.Yampa.Diagnostics import FRP.Yampa infixr 5 `andThen` --infixr 1 ^<<, ^>> --infixr 1 <<^, >>^ infixr 0 `fby` -- Now defined directly in Control.Arrow. -- But while using an old version of Arrows ... ------------------------------------------------------------------------------ -- General arrow utilities ------------------------------------------------------------------------------ {- (^>>) :: Arrow a => (b -> c) -> a c d -> a b d f ^>> a = arr f >>> a (>>^) :: Arrow a => a b c -> (c -> d) -> a b d a >>^ f = a >>> arr f (^<<) :: Arrow a => (c -> d) -> a b c -> a b d f ^<< a = arr f <<< a (<<^) :: Arrow a => a c d -> (b -> c) -> a b d a <<^ f = a <<< arr f -} ------------------------------------------------------------------------------ -- Liftings ------------------------------------------------------------------------------ arr2 :: Arrow a => (b -> c -> d) -> a (b, c) d arr2 = arr . uncurry arr3 :: Arrow a => (b -> c -> d -> e) -> a (b, c, d) e arr3 = arr . \h (b, c, d) -> h b c d arr4 :: Arrow a => (b -> c -> d -> e -> f) -> a (b, c, d, e) f arr4 = arr . \h (b, c, d, e) -> h b c d e arr5 :: Arrow a => (b -> c -> d -> e -> f -> g) -> a (b, c, d, e, f) g arr5 = arr . \h (b, c, d, e, f) -> h b c d e f lift0 :: Arrow a => c -> a b c lift0 c = arr (const c) lift1 :: Arrow a => (c -> d) -> (a b c -> a b d) lift1 f = \a -> a >>> arr f lift2 :: Arrow a => (c -> d -> e) -> (a b c -> a b d -> a b e) lift2 f = \a1 a2 -> a1 &&& a2 >>> arr2 f lift3 :: Arrow a => (c -> d -> e -> f) -> (a b c -> a b d -> a b e -> a b f) lift3 f = \a1 a2 a3 -> (lift2 f) a1 a2 &&& a3 >>> arr2 ($) lift4 :: Arrow a => (c->d->e->f->g) -> (a b c->a b d->a b e->a b f->a b g) lift4 f = \a1 a2 a3 a4 -> (lift3 f) a1 a2 a3 &&& a4 >>> arr2 ($) lift5 :: Arrow a => (c->d->e->f->g->h) -> (a b c->a b d->a b e->a b f->a b g->a b h) lift5 f = \a1 a2 a3 a4 a5 ->(lift4 f) a1 a2 a3 a4 &&& a5 >>> arr2 ($) ------------------------------------------------------------------------------ -- Event sources ------------------------------------------------------------------------------ -- 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 = switch (never &&& (identity &&& now () >>^ \(a, e) -> e `tag` a)) 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 t_ev = switch (never &&& (identity &&& after t_ev () >>^ \(a, e) -> e `tag` a)) now -- Sample a signal at regular intervals. sample :: Time -> SF a (Event a) sample p_ev = identity &&& repeatedly p_ev () >>^ \(a, e) -> e `tag` a -- 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 sfe = switch (never &&& sfe) $ \b -> Event b --> (recur (NoEvent-->sfe)) andThen :: SF a (Event b) -> SF a (Event b) -> SF a (Event b) sfe1 `andThen` sfe2 = dSwitch (sfe1 >>^ dup) (const sfe2) {- recur :: SF a (Event b) -> SF a (Event b) recur sfe = switch (never &&& sfe) recurAux where recurAux b = switch (now b &&& sfe) recurAux -} -- 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 wl q = identity &&& afterEachCat (repeat (q, ())) >>> arr (\(a, e) -> fmap (map (const a)) e) >>> accumBy updateWindow [] where updateWindow w as = drop (max (length w' - wl) 0) w' where w' = w ++ as ------------------------------------------------------------------------------ -- Parallel composition/switchers with "zip" routing ------------------------------------------------------------------------------ safeZip :: String -> [a] -> [b] -> [(a,b)] safeZip fn as bs = safeZip' as bs where safeZip' _ [] = [] safeZip' as (b:bs) = (head' as, b) : safeZip' (tail' as) bs head' [] = err head' (a:_) = a tail' [] = err tail' (_:as) = as err = usrErr "AFRPUtilities" fn "Input list too short." parZ :: [SF a b] -> SF [a] [b] parZ = par (safeZip "parZ") pSwitchZ :: [SF a b] -> SF ([a],[b]) (Event c) -> ([SF a b] -> c -> SF [a] [b]) -> SF [a] [b] pSwitchZ = pSwitch (safeZip "pSwitchZ") dpSwitchZ :: [SF a b] -> SF ([a],[b]) (Event c) -> ([SF a b] -> c ->SF [a] [b]) -> SF [a] [b] dpSwitchZ = dpSwitch (safeZip "dpSwitchZ") rpSwitchZ :: [SF a b] -> SF ([a], Event ([SF a b] -> [SF a b])) [b] rpSwitchZ = rpSwitch (safeZip "rpSwitchZ") drpSwitchZ :: [SF a b] -> SF ([a], Event ([SF a b] -> [SF a b])) [b] drpSwitchZ = drpSwitch (safeZip "drpSwitchZ") ------------------------------------------------------------------------------ -- Guards and automata-oriented combinators ------------------------------------------------------------------------------ -- Runs sft only when the predicate p is satisfied, otherwise runs sff. provided :: (a -> Bool) -> SF a b -> SF a b -> SF a b provided p sft sff = switch (constant undefined &&& snap) $ \a0 -> if p a0 then stt else stf where stt = switch (sft &&& (not . p ^>> edge)) (const stf) stf = switch (sff &&& (p ^>> edge)) (const stt) ------------------------------------------------------------------------------ -- Wave-form generation ------------------------------------------------------------------------------ -- Zero-order hold with delay. -- Identity: dHold a0 = hold a0 >>> iPre a0). old_dHold :: a -> SF (Event a) a old_dHold a0 = dSwitch (constant a0 &&& identity) dHold' where dHold' a = dSwitch (constant a &&& notYet) dHold' dTrackAndHold :: a -> SF (Maybe a) a dTrackAndHold a_init = trackAndHold a_init >>> iPre a_init ------------------------------------------------------------------------------ -- Accumulators ------------------------------------------------------------------------------ old_accumHold :: a -> SF (Event (a -> a)) a old_accumHold a_init = old_accum a_init >>> old_hold a_init old_dAccumHold :: a -> SF (Event (a -> a)) a old_dAccumHold a_init = old_accum a_init >>> old_dHold a_init old_accumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b old_accumHoldBy f b_init = old_accumBy f b_init >>> old_hold b_init old_dAccumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b old_dAccumHoldBy f b_init = old_accumBy f b_init >>> old_dHold b_init count :: Integral b => SF (Event a) (Event b) count = accumBy (\n _ -> n + 1) 0 ------------------------------------------------------------------------------ -- Delays ------------------------------------------------------------------------------ -- Lucid-Synchrone-like initialized delay (read "followed by"). fby :: b -> SF a b -> SF a b b0 `fby` sf = b0 --> sf >>> pre ------------------------------------------------------------------------------ -- Integrals ------------------------------------------------------------------------------ impulseIntegral :: VectorSpace a k => SF (a, Event a) a impulseIntegral = (integral *** accumHoldBy (^+^) zeroVector) >>^ uncurry (^+^) old_impulseIntegral :: VectorSpace a k => SF (a, Event a) a old_impulseIntegral = (integral *** old_accumHoldBy (^+^) zeroVector) >>^ uncurry (^+^)