diff --git a/FRP/Yampa.hs b/FRP/Yampa.hs new file mode 100644 --- /dev/null +++ b/FRP/Yampa.hs @@ -0,0 +1,3314 @@ +{-# LANGUAGE GADTs, Rank2Types, CPP #-} +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa +-- 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 : non-portable (GHC extensions) +-- +-- New version using GADTs. +-- +-- ToDo: +-- +-- * Specialize def. of repeatedly. Could have an impact on invaders. +-- +-- * New defs for accs using SFAcc +-- +-- * Make sure opt worked: e.g. +-- +-- > repeatedly >>> count >>> arr (fmap sqr) +-- +-- * Introduce SFAccHld. +-- +-- * See if possible to unify AccHld wity Acc??? They are so close. +-- +-- * Introduce SScan. BUT KEEP IN MIND: Most if not all opts would +-- have been possible without GADTs??? +-- +-- * Look into pairs. At least pairing of SScan ought to be interesting. +-- +-- * Would be nice if we could get rid of first & second with impunity +-- thanks to Id optimizations. That's a clear win, with or without +-- an explicit pair combinator. +-- +-- * delayEventCat is a bit complicated ... +-- +-- +-- Random ideas: +-- +-- * What if one used rules to optimize +-- - (arr :: SF a ()) to (constant ()) +-- - (arr :: SF a a) to identity +-- But inspection of invader source code seem to indicate that +-- these are not very common cases at all. +-- +-- * It would be nice if it was possible to come up with opt. rules +-- that are invariant of how signal function expressions are +-- parenthesized. Right now, we have e.g. +-- arr f >>> (constant c >>> sf) +-- being optimized to +-- cpAuxA1 f (cpAuxC1 c sf) +-- whereas it clearly should be possible to optimize to just +-- cpAuxC1 c sf +-- What if we didn't use SF' but +-- SFComp :: -> SF' a b -> SF' b c -> SF' a c +-- ??? +-- +-- * The transition function would still be optimized in (pretty much) +-- the current way, but it would still be possible to look "inside" +-- composed signal functions for lost optimization opts. +-- Seems to me this could be done without too much extra effort/no dupl. +-- work. +-- E.g. new cpAux, the general case: +-- +-- @ +-- cpAux sf1 sf2 = SFComp tf sf1 sf2 +-- where +-- tf dt a = (cpAux sf1' sf2', c) +-- where +-- (sf1', b) = (sfTF' sf1) dt a +-- (sf2', c) = (sfTF' sf2) dt b +-- @ +-- +-- * The ONLY change was changing the constructor from SF' to SFComp and +-- adding sf1 and sf2 to the constructor app.! +-- +-- * An optimized case: +-- cpAuxC1 b sf1 sf2 = SFComp tf sf1 sf2 +-- So cpAuxC1 gets an extra arg, and we change the constructor. +-- But how to exploit without writing 1000s of rules??? +-- Maybe define predicates on SFComp to see if the first or second +-- sf are "interesting", and if so, make "reassociate" and make a +-- recursive call? E.g. we're in the arr case, and the first sf is another +-- arr, so we'd like to combine the two. +-- +-- * It would also be intersting, then, to know when to STOP playing this +-- game, due to the overhead involved. +-- +-- * Why don't we have a "SWITCH" constructor that indicates that the +-- structure will change, and thus that it is worthwile to keep +-- looking for opt. opportunities, whereas a plain "SF'" would +-- indicate that things NEVER are going to change, and thus we can just +-- as well give up? +----------------------------------------------------------------------------------------- + +module FRP.Yampa ( +-- Re-exported module, classes, and types + module Control.Arrow, + module FRP.Yampa.VectorSpace, + RandomGen(..), + Random(..), + +-- Reverse function composition and arrow plumbing aids + ( # ), -- :: (a -> b) -> (b -> c) -> (a -> c), infixl 9 + dup, -- :: a -> (a,a) + swap, -- :: (a,b) -> (b,a) + +-- Main types + Time, -- [s] Both for time w.r.t. some reference and intervals. + --SF, -- Signal Function. + Event(..), -- Events; conceptually similar to Maybe (but abstract). + +-- Temporray! + SF(..), sfTF', SF'(..), + +-- Main instances + -- SF is an instance of Arrow and ArrowLoop. Method instances: + -- arr :: (a -> b) -> SF a b + -- (>>>) :: SF a b -> SF b c -> SF a c + -- (<<<) :: SF b c -> SF a b -> SF a c + -- first :: SF a b -> SF (a,c) (b,c) + -- second :: SF a b -> SF (c,a) (c,b) + -- (***) :: SF a b -> SF a' b' -> SF (a,a') (b,b') + -- (&&&) :: SF a b -> SF a b' -> SF a (b,b') + -- returnA :: SF a a + -- loop :: SF (a,c) (b,c) -> SF a b + + -- Event is an instance of Functor, Eq, and Ord. Some method instances: + -- fmap :: (a -> b) -> Event a -> Event b + -- (==) :: Event a -> Event a -> Bool + -- (<=) :: Event a -> Event a -> Bool + +-- For optimization + arrPrim, arrEPrim, + +-- Basic signal functions + identity, -- :: SF a a + constant, -- :: b -> SF a b + localTime, -- :: SF a Time + time, -- :: SF a Time, Other name for localTime. + +-- Initialization + (-->), -- :: b -> SF a b -> SF a b, infixr 0 + (>--), -- :: a -> SF a b -> SF a b, infixr 0 + (-=>), -- :: (b -> b) -> SF a b -> SF a b infixr 0 + (>=-), -- :: (a -> a) -> SF a b -> SF a b infixr 0 + initially, -- :: a -> SF a a + +-- Simple, stateful signal processing + sscan, -- :: (b -> a -> b) -> b -> SF a b + sscanPrim, -- :: (c -> a -> Maybe (c, b)) -> c -> b -> SF a b + +-- 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) + +-- Basic switchers + switch, dSwitch, -- :: SF a (b, Event c) -> (c -> SF a b) -> SF a b + rSwitch, drSwitch, -- :: SF a b -> SF (a,Event (SF a b)) b + kSwitch, dkSwitch, -- :: SF a b + -- -> SF (a,b) (Event c) + -- -> (SF a b -> c -> SF a b) + -- -> SF a b + +-- Parallel composition and switching over collections with broadcasting + parB, -- :: Functor col => col (SF a b) -> SF a (col b) + pSwitchB,dpSwitchB, -- :: Functor col => + -- col (SF a b) + -- -> SF (a, col b) (Event c) + -- -> (col (SF a b) -> c -> SF a (col b)) + -- -> SF a (col b) + rpSwitchB,drpSwitchB,-- :: Functor col => + -- col (SF a b) + -- -> SF (a, Event (col (SF a b)->col (SF a b))) + -- (col b) + +-- Parallel composition and switching over collections with general routing + par, -- Functor col => + -- (forall sf . (a -> col sf -> col (b, sf))) + -- -> col (SF b c) + -- -> SF a (col c) + pSwitch, dpSwitch, -- pSwitch :: Functor col => + -- (forall sf . (a -> col sf -> col (b, sf))) + -- -> col (SF b c) + -- -> SF (a, col c) (Event d) + -- -> (col (SF b c) -> d -> SF a (col c)) + -- -> SF a (col c) + rpSwitch,drpSwitch, -- Functor col => + -- (forall sf . (a -> col sf -> col (b, sf))) + -- -> col (SF b c) + -- -> SF (a, Event (col (SF b c) -> col (SF b c))) + -- (col c) + +-- Wave-form generation + old_hold, -- :: a -> SF (Event a) a + hold, -- :: a -> SF (Event a) a + dHold, -- :: a -> SF (Event a) a + trackAndHold, -- :: a -> SF (Maybe a) a + +-- Accumulators + old_accum, -- :: a -> SF (Event (a -> a)) (Event a) + old_accumBy, -- :: (b -> a -> b) -> b -> SF (Event a) (Event b) + old_accumFilter, -- :: (c -> a -> (c, Maybe b)) -> c + accum, -- :: a -> SF (Event (a -> a)) (Event a) + accumHold, -- :: a -> SF (Event (a -> a)) a + dAccumHold, -- :: a -> SF (Event (a -> a)) a + accumBy, -- :: (b -> a -> b) -> b -> SF (Event a) (Event b) + accumHoldBy, -- :: (b -> a -> b) -> b -> SF (Event a) b + dAccumHoldBy, -- :: (b -> a -> b) -> b -> SF (Event a) b + accumFilter, -- :: (c -> a -> (c, Maybe b)) -> c + -- -> SF (Event a) (Event b) + +-- Delays + old_pre, old_iPre, + pre, -- :: SF a a + iPre, -- :: a -> SF a a + +-- Timed delays + delay, -- :: Time -> a -> SF a a + +-- Integration and differentiation + integral, -- :: VectorSpace a s => SF a a + + derivative, -- :: VectorSpace a s => SF a a -- Crude! + imIntegral, -- :: VectorSpace a s => a -> SF a a + +-- Loops with guaranteed well-defined feedback + loopPre, -- :: c -> SF (a,c) (b,c) -> SF a b + loopIntegral, -- :: VectorSpace c s => SF (a,c) (b,c) -> SF a b + +-- Pointwise functions on events + noEvent, -- :: Event a + noEventFst, -- :: (Event a, b) -> (Event c, b) + noEventSnd, -- :: (a, Event b) -> (a, Event c) + event, -- :: a -> (b -> a) -> Event b -> a + fromEvent, -- :: Event a -> a + isEvent, -- :: Event a -> Bool + isNoEvent, -- :: Event a -> Bool + tag, -- :: Event a -> b -> Event b, infixl 8 + tagWith, -- :: b -> Event a -> Event b, + attach, -- :: Event a -> b -> Event (a, b), infixl 8 + lMerge, -- :: Event a -> Event a -> Event a, infixl 6 + rMerge, -- :: Event a -> Event a -> Event a, infixl 6 + merge, -- :: Event a -> Event a -> Event a, infixl 6 + mergeBy, -- :: (a -> a -> a) -> Event a -> Event a -> Event a + mapMerge, -- :: (a -> c) -> (b -> c) -> (a -> b -> c) + -- -> Event a -> Event b -> Event c + mergeEvents, -- :: [Event a] -> Event a + catEvents, -- :: [Event a] -> Event [a] + joinE, -- :: Event a -> Event b -> Event (a,b),infixl 7 + splitE, -- :: Event (a,b) -> (Event a, Event b) + filterE, -- :: (a -> Bool) -> Event a -> Event a + mapFilterE, -- :: (a -> Maybe b) -> Event a -> Event b + gate, -- :: Event a -> Bool -> Event a, infixl 8 + +-- Noise (random signal) sources and stochastic event sources + noise, -- :: noise :: (RandomGen g, Random b) => + -- g -> SF a b + noiseR, -- :: noise :: (RandomGen g, Random b) => + -- (b,b) -> g -> SF a b + occasionally, -- :: RandomGen g => g -> Time -> b -> SF a (Event b) + +-- Reactimation + reactimate, -- :: IO a + -- -> (Bool -> IO (DTime, Maybe a)) + -- -> (Bool -> b -> IO Bool) + -- -> SF a b + -- -> IO () + ReactHandle, + reactInit, -- IO a -- init + -- -> (ReactHandle a b -> Bool -> b -> IO Bool) -- actuate + -- -> SF a b + -- -> IO (ReactHandle a b) +-- process a single input sample: + react, -- ReactHandle a b + -- -> (DTime,Maybe a) + -- -> IO Bool + +-- Embedding (tentative: will be revisited) + DTime, -- [s] Sampling interval, always > 0. + embed, -- :: SF a b -> (a, [(DTime, Maybe a)]) -> [b] + embedSynch, -- :: SF a b -> (a, [(DTime, Maybe a)]) -> SF Double b + deltaEncode, -- :: Eq a => DTime -> [a] -> (a, [(DTime, Maybe a)]) + deltaEncodeBy -- :: (a -> a -> Bool) -> DTime -> [a] + -- -> (a, [(DTime, Maybe a)]) + +) where + +import Control.Monad (unless) +import System.Random (RandomGen(..), Random(..)) + +#if __GLASGOW_HASKELL__ >= 610 +import qualified Control.Category (Category(..)) +#else +#endif + +import Control.Arrow +import FRP.Yampa.Diagnostics +import FRP.Yampa.Miscellany (( # ), dup, swap) +import FRP.Yampa.Event +import FRP.Yampa.VectorSpace + +import Data.IORef + +infixr 0 -->, >--, -=>, >=- + +------------------------------------------------------------------------------ +-- Basic type definitions with associated utilities +------------------------------------------------------------------------------ + +-- The time type is really a bit boguous, since, as time passes, the minimal +-- interval between two consecutive floating-point-represented time points +-- increases. A better approach might be to pick a reasonable resolution +-- and represent time and time intervals by Integer (giving the number of +-- "ticks"). +-- +-- That might also improve the timing of time-based event sources. +-- One might actually pick the overall resolution in reactimate, +-- to be passed down, possibly in the form of a global parameter +-- record, to all signal functions on initialization. (I think only +-- switch would need to remember the record, since it is the only place +-- where signal functions get started. So it wouldn't cost all that much. + +-- Time is used both for time intervals (duration), and time w.r.t. some +-- agreed reference point in time. Conceptually, Time = R, i.e. time can be 0 +-- or even negative. +type Time = Double -- [s] + + +-- DTime is the time type for lengths of sample intervals. Conceptually, +-- DTime = R+ = { x in R | x > 0 }. Don't assume Time and DTime have the +-- same representation. + +type DTime = Double -- [s] + + +-- Representation of signal function in initial state. +-- (Naming: "TF" stands for Transition Function.) + +data SF a b = SF {sfTF :: a -> Transition a b} + + +-- Representation of signal function in "running" state. +-- +-- Possibly better design for Inv. +-- Problem: tension between on the one hand making use of the +-- invariant property, and on the other keeping track of how something +-- has been constructed (SFCpAXA, in particular). +-- Idea: Add a boolean field to SFCpAXA and SF' that classifies +-- a signal function as being invarying. +-- A function sfIsInv computes to True for SFArr, SFAcc (and SFSScan, +-- possibly more), extracts the field in other cases. +-- +-- Motivation for using a function (Event a -> b) in SFArrE +-- rather than (a -> Event b) or (a -> b) or even (Event a -> Event b). +-- The result type should be just "b" as opposed to "Event b" for +-- increased flexibility (e.g. matching "routing functions"). +-- When the result type actually IS (Event b), and this fact is +-- exploitable, we'll be in a context where is it clear that +-- this is a fact, so we don't lose anything. +-- Since the idea is that the function is only going to be applied +-- when the there is an event, one could imagine the input type +-- just "a". But that's not the type of function we're given, +-- so it would have to be "massaged" a bit (precomposing with Event) +-- to fit. This will gain nothing, and potentially we will lose if +-- we actually need to recover the original function. +-- In fact, we sometimes really need to recover the original function +-- (e.g. currently in switch), and to do it correctly (also handling +-- NoEvent), we'd have to work quite hard introducing further +-- inefficiencies. +-- Summary: Make use of what we are given and only wrap things up later +-- when it is clear whatthe need is going to be, thus avoiding costly +-- "unwrapping". + +-- GADTs needed in particular for SFEP, but also e.g. SFSScan +-- exploits them since there are more type vars than in the type con. +-- But one could use existentials for those. + + +data SF' a b where + SFArr :: !(DTime -> a -> Transition a b) -> !(FunDesc a b) -> SF' a b + -- The b is intentionally unstrict as the initial output sometimes + -- is undefined (e.g. when defining pre). In any case, it isn't + -- necessarily used and should thus not be forced. + SFSScan :: !(DTime -> a -> Transition a b) + -> !(c -> a -> Maybe (c, b)) -> !c -> b + -> SF' a b + SFEP :: !(DTime -> Event a -> Transition (Event a) b) + -> !(c -> a -> (c, b, b)) -> !c -> b + -> SF' (Event a) b + SFCpAXA :: !(DTime -> a -> Transition a d) + -> !(FunDesc a b) -> !(SF' b c) -> !(FunDesc c d) + -> SF' a d + -- SFPair :: ... + SF' :: !(DTime -> a -> Transition a b) -> SF' a b + +-- A transition is a pair of the next state (in the form of a signal +-- function) and the output at the present time step. + +type Transition a b = (SF' a b, b) + + +sfTF' :: SF' a b -> (DTime -> a -> Transition a b) +sfTF' (SFArr tf _) = tf +sfTF' (SFSScan tf _ _ _) = tf +sfTF' (SFEP tf _ _ _) = tf +sfTF' (SFCpAXA tf _ _ _) = tf +sfTF' (SF' tf) = tf + + +-- !!! 2005-06-30 +-- Unclear why, but the isInv mechanism seems to do more +-- harm than good. +-- Disable completely and see what happens. +{- +sfIsInv :: SF' a b -> Bool +-- sfIsInv _ = False +sfIsInv (SFArr _ _) = True +-- sfIsInv (SFAcc _ _ _ _) = True +sfIsInv (SFEP _ _ _ _) = True +-- sfIsInv (SFSScan ...) = True +sfIsInv (SFCpAXA _ inv _ _ _) = inv +sfIsInv (SF' _ inv) = inv +-} + +-- "Smart" constructors. The corresponding "raw" constructors should not +-- be used directly for construction. + +sfArr :: FunDesc a b -> SF' a b +sfArr FDI = sfId +sfArr (FDC b) = sfConst b +sfArr (FDE f fne) = sfArrE f fne +sfArr (FDG f) = sfArrG f + + +sfId :: SF' a a +sfId = sf + where + sf = SFArr (\_ a -> (sf, a)) FDI + + +sfConst :: b -> SF' a b +sfConst b = sf + where + sf = SFArr (\_ _ -> (sf, b)) (FDC b) + + +sfNever :: SF' a (Event b) +sfNever = sfConst NoEvent + + +-- Assumption: fne = f NoEvent +sfArrE :: (Event a -> b) -> b -> SF' (Event a) b +sfArrE f fne = sf + where + sf = SFArr (\_ ea -> (sf, case ea of NoEvent -> fne ; _ -> f ea)) + (FDE f fne) + +sfArrG :: (a -> b) -> SF' a b +sfArrG f = sf + where + sf = SFArr (\_ a -> (sf, f a)) (FDG f) + + +sfSScan :: (c -> a -> Maybe (c, b)) -> c -> b -> SF' a b +sfSScan f c b = sf + where + sf = SFSScan tf f c b + tf _ a = case f c a of + Nothing -> (sf, b) + Just (c', b') -> (sfSScan f c' b', b') + +sscanPrim :: (c -> a -> Maybe (c, b)) -> c -> b -> SF a b +sscanPrim f c_init b_init = SF {sfTF = tf0} + where + tf0 a0 = case f c_init a0 of + Nothing -> (sfSScan f c_init b_init, b_init) + Just (c', b') -> (sfSScan f c' b', b') + + +-- 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' = + +-} + +-- Motivation for event-processing function type +-- (alternative would be function of type a->b plus ensuring that it +-- only ever gets invoked on events): +-- * Now we need to be consistent with other kinds of arrows. +-- * We still want to be able to get hold of the original function. +-- 2005-02-30: OK, for FDE, invarant is that the field of type b = +-- f NoEvent. + +data FunDesc a b where + FDI :: FunDesc a a -- Identity function + FDC :: b -> FunDesc a b -- Constant function + FDE :: (Event a -> b) -> b -> FunDesc (Event a) b -- Event-processing fun + FDG :: (a -> b) -> FunDesc a b -- General function + +fdFun :: FunDesc a b -> (a -> b) +fdFun FDI = id +fdFun (FDC b) = const b +fdFun (FDE f _) = f +fdFun (FDG f) = f + +fdComp :: FunDesc a b -> FunDesc b c -> FunDesc a c +fdComp FDI fd2 = fd2 +fdComp fd1 FDI = fd1 +fdComp (FDC b) fd2 = FDC ((fdFun fd2) b) +fdComp _ (FDC c) = FDC c +-- Hardly worth the effort? +-- 2005-03-30: No, not only not worth the effort as the only thing saved +-- would be an application of f2. Also wrong since current invariant does +-- not imply that f1ne = NoEvent. Moreover, we cannot really adopt that +-- invariant as it is not totally impossible for a user to create a function +-- that breaks it. +-- fdComp (FDE f1 f1ne) (FDE f2 f2ne) = +-- FDE (f2 . f1) (vfyNoEvent (f1 NoEvent) f2ne) +fdComp (FDE f1 f1ne) fd2 = FDE (f2 . f1) (f2 f1ne) + where + f2 = fdFun fd2 +fdComp (FDG f1) (FDE f2 f2ne) = FDG f + where + f a = case f1 a of + NoEvent -> f2ne + f1a -> f2 f1a +fdComp (FDG f1) fd2 = FDG (fdFun fd2 . f1) + + +fdPar :: FunDesc a b -> FunDesc c d -> FunDesc (a,c) (b,d) +fdPar FDI FDI = FDI +fdPar FDI (FDC d) = FDG (\(~(a, _)) -> (a, d)) +fdPar FDI fd2 = FDG (\(~(a, c)) -> (a, (fdFun fd2) c)) +fdPar (FDC b) FDI = FDG (\(~(_, c)) -> (b, c)) +fdPar (FDC b) (FDC d) = FDC (b, d) +fdPar (FDC b) fd2 = FDG (\(~(_, c)) -> (b, (fdFun fd2) c)) +fdPar fd1 fd2 = FDG (\(~(a, c)) -> ((fdFun fd1) a, (fdFun fd2) c)) + + +fdFanOut :: FunDesc a b -> FunDesc a c -> FunDesc a (b,c) +fdFanOut FDI FDI = FDG dup +fdFanOut FDI (FDC c) = FDG (\a -> (a, c)) +fdFanOut FDI fd2 = FDG (\a -> (a, (fdFun fd2) a)) +fdFanOut (FDC b) FDI = FDG (\a -> (b, a)) +fdFanOut (FDC b) (FDC c) = FDC (b, c) +fdFanOut (FDC b) fd2 = FDG (\a -> (b, (fdFun fd2) a)) +fdFanOut (FDE f1 f1ne) (FDE f2 f2ne) = FDE f1f2 f1f2ne + where + f1f2 NoEvent = f1f2ne + f1f2 ea@(Event _) = (f1 ea, f2 ea) + + f1f2ne = (f1ne, f2ne) +fdFanOut fd1 fd2 = + FDG (\a -> ((fdFun fd1) a, (fdFun fd2) a)) + + +-- Verifies that the first argument is NoEvent. Returns the value of the +-- second argument that is the case. Raises an error otherwise. +-- Used to check that functions on events do not map NoEvent to Event +-- wherever that assumption is exploited. +vfyNoEv :: Event a -> b -> b +vfyNoEv NoEvent b = b +vfyNoEv _ _ = usrErr "AFRP" "vfyNoEv" "Assertion failed: Functions on events must not map NoEvent to Event." + + +-- Freezes a "running" signal function, i.e., turns it into a continuation in +-- the form of a plain signal function. +freeze :: SF' a b -> DTime -> SF a b +freeze sf dt = SF {sfTF = (sfTF' sf) dt} + + +freezeCol :: Functor col => col (SF' a b) -> DTime -> col (SF a b) +freezeCol sfs dt = fmap (flip freeze dt) sfs + + +------------------------------------------------------------------------------ +-- Arrow instance and implementation +------------------------------------------------------------------------------ +#if __GLASGOW_HASKELL__ >= 610 +instance Control.Category.Category SF where + (.) = flip compPrim + id = SF $ \x -> (sfId,x) +#else +#endif + +instance Arrow SF where + arr = arrPrim + first = firstPrim + second = secondPrim + (***) = parSplitPrim + (&&&) = parFanOutPrim +#if __GLASGOW_HASKELL__ >= 610 +#else + (>>>) = compPrim +#endif + + +-- Lifting. +{-# NOINLINE arrPrim #-} +arrPrim :: (a -> b) -> SF a b +arrPrim f = SF {sfTF = \a -> (sfArrG f, f a)} + + +{-# RULES "arrPrim/arrEPrim" arrPrim = arrEPrim #-} + +arrEPrim :: (Event a -> b) -> SF (Event a) b +arrEPrim f = SF {sfTF = \a -> (sfArrE f (f NoEvent), f a)} + + +-- Composition. +-- The definition exploits the following identities: +-- sf >>> identity = sf -- New +-- identity >>> sf = sf -- New +-- sf >>> constant c = constant c +-- constant c >>> arr f = constant (f c) +-- arr f >>> arr g = arr (g . f) +-- +-- !!! Notes/Questions: +-- !!! How do we know that the optimizations terminate? +-- !!! Probably by some kind of size argument on the SF tree. +-- !!! E.g. (Hopefully) all compPrim optimizations are such that +-- !!! the number of compose nodes decrease. +-- !!! Should verify this! +-- +-- !!! There is a tension between using SFInv to signal to superior +-- !!! signal functions that the subordinate signal function will not +-- !!! change form, and using SFCpAXA to allow fusion in the context +-- !!! of some suitable superior signal function. +compPrim :: SF a b -> SF b c -> SF a c +compPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0} + where + tf0 a0 = (cpXX sf1 sf2, c0) + where + (sf1, b0) = tf10 a0 + (sf2, c0) = tf20 b0 + +-- The following defs are not local to compPrim because cpAXA needs to be +-- called from parSplitPrim. +-- Naming convention: cp where and is one of: +-- X - arbitrary signal function +-- A - arbitrary pure arrow +-- C - constant arrow +-- E - event-processing arrow +-- G - arrow known not to be identity, constant (C) or +-- event-processing (E). + +cpXX :: SF' a b -> SF' b c -> SF' a c +cpXX (SFArr _ fd1) sf2 = cpAX fd1 sf2 +cpXX sf1 (SFArr _ fd2) = cpXA sf1 fd2 +{- +-- !!! 2005-07-07: Too strict. +-- !!! But the question is if it is worth to define pre in terms of sscan ... +-- !!! It is slower than the simplest possible pre, and the kind of coding +-- !!! required to ensure that the laziness props of the second SF are +-- !!! preserved might just slow things down further ... +cpXX (SFSScan _ f1 s1 b) (SFSScan _ f2 s2 c) = + sfSScan f (s1, b, s2, c) c + where + f (s1, b, s2, c) a = + case f1 s1 a of + Nothing -> + case f2 s2 b of + Nothing -> Nothing + Just (s2', c') -> Just ((s1, b, s2', c'), c') + Just (s1', b') -> + case f2 s2 b' of + Nothing -> Just ((s1', b', s2, c), c) + Just (s2', c') -> Just ((s1', b', s2', c'), c') +-} +-- !!! 2005-07-07: Indeed, this is a bit slower than the code above (14%). +-- !!! But both are better than not composing (35% faster and 26% faster)! +cpXX (SFSScan _ f1 s1 b) (SFSScan _ f2 s2 c) = + sfSScan f (s1, b, s2, c) c + where + f (s1, b, s2, c) a = + let + (u, s1', b') = case f1 s1 a of + Nothing -> (True, s1, b) + Just (s1',b') -> (False, s1', b') + in + case f2 s2 b' of + Nothing | u -> Nothing + | otherwise -> Just ((s1', b', s2, c), c) + Just (s2', c') -> Just ((s1', b', s2', c'), c') +cpXX (SFSScan _ f1 s1 eb) (SFEP _ f2 s2 cne) = + sfSScan f (s1, eb, s2, cne) cne + where + f (s1, eb, s2, cne) a = + case f1 s1 a of + Nothing -> + case eb of + NoEvent -> Nothing + Event b -> + let (s2', c, cne') = f2 s2 b + in + Just ((s1, eb, s2', cne'), c) + Just (s1', eb') -> + case eb' of + NoEvent -> Just ((s1', eb', s2, cne), cne) + Event b -> + let (s2', c, cne') = f2 s2 b + in + Just ((s1', eb', s2', cne'), c) +-- !!! 2005-07-09: This seems to yield only a VERY marginal speedup +-- !!! without seq. With seq, substantial speedup! +cpXX (SFEP _ f1 s1 bne) (SFSScan _ f2 s2 c) = + sfSScan f (s1, bne, s2, c) c + where + f (s1, bne, s2, c) ea = + let (u, s1', b', bne') = case ea of + NoEvent -> (True, s1, bne, bne) + Event a -> + let (s1', b, bne') = f1 s1 a + in + (False, s1', b, bne') + in + case f2 s2 b' of + Nothing | u -> Nothing + | otherwise -> Just (seq s1' (s1', bne', s2, c), c) + Just (s2', c') -> Just (seq s1' (s1', bne', s2', c'), c') +-- The function "f" is invoked whenever an event is to be processed. It then +-- computes the output, the new state, and the new NoEvent output. +-- However, when sequencing event processors, the ones in the latter +-- part of the chain may not get invoked since previous ones may +-- decide not to "fire". But a "new" NoEvent output still has to be +-- produced, i.e. the old one retained. Since it cannot be computed by +-- invoking the last event-processing function in the chain, it has to +-- be remembered. Since the composite event-processing function remains +-- constant/unchanged, the NoEvent output has to be part of the state. +-- An alternarive would be to make the event-processing function take an +-- extra argument. But that is likely to make the simple case more +-- expensive. See note at sfEP. +cpXX (SFEP _ f1 s1 bne) (SFEP _ f2 s2 cne) = + sfEP f (s1, s2, cne) (vfyNoEv bne cne) + where + f (s1, s2, cne) a = + case f1 s1 a of + (s1', NoEvent, NoEvent) -> ((s1', s2, cne), cne, cne) + (s1', Event b, NoEvent) -> + let (s2', c, cne') = f2 s2 b in ((s1', s2', cne'), c, cne') + _ -> usrErr "AFRP" "cpXX" "Assertion failed: Functions on events must not map NoEvent to Event." +-- !!! 2005-06-28: Why isn't SFCpAXA (FDC ...) checked for? +-- !!! No invariant rules that out, and it would allow to drop the +-- !!! event processor ... Does that happen elsewhere? +cpXX sf1@(SFEP _ _ _ _) (SFCpAXA _ (FDE f21 f21ne) sf22 fd23) = + cpXX (cpXE sf1 f21 f21ne) (cpXA sf22 fd23) +-- f21 will (hopefully) be invoked less frequently if merged with the +-- event processor. +cpXX sf1@(SFEP _ _ _ _) (SFCpAXA _ (FDG f21) sf22 fd23) = + cpXX (cpXG sf1 f21) (cpXA sf22 fd23) +-- Only functions whose domain is known to be Event can be merged +-- from the left with event processors. +cpXX (SFCpAXA _ fd11 sf12 (FDE f13 f13ne)) sf2@(SFEP _ _ _ _) = + cpXX (cpAX fd11 sf12) (cpEX f13 f13ne sf2) +-- !!! Other cases to look out for: +-- !!! any sf >>> SFCpAXA = SFCpAXA if first arr is const. +-- !!! But the following will presumably not work due to type restrictions. +-- !!! Need to reconstruct sf2 I think. +-- cpXX sf1 sf2@(SFCpAXA _ _ (FDC b) sf22 fd23) = sf2 +cpXX (SFCpAXA _ fd11 sf12 fd13) (SFCpAXA _ fd21 sf22 fd23) = + -- Termination: The first argument to cpXX is no larger than + -- the current first argument, and the second is smaller. + cpAXA fd11 (cpXX (cpXA sf12 (fdComp fd13 fd21)) sf22) fd23 +-- !!! 2005-06-27: The if below accounts for a significant slowdown. +-- !!! One would really like a cheme where opts only take place +-- !!! after a structural change ... +-- cpXX sf1 sf2 = cpXXInv sf1 sf2 +-- cpXX sf1 sf2 = cpXXAux sf1 sf2 +cpXX sf1 sf2 = SF' tf -- False + -- if sfIsInv sf1 && sfIsInv sf2 then cpXXInv sf1 sf2 else SF' tf False + where + tf dt a = (cpXX sf1' sf2', c) + where + (sf1', b) = (sfTF' sf1) dt a + (sf2', c) = (sfTF' sf2) dt b + + +{- +cpXXAux sf1@(SF' _ _) sf2@(SF' _ _) = SF' tf False + where + tf dt a = (cpXXAux sf1' sf2', c) + where + (sf1', b) = (sfTF' sf1) dt a + (sf2', c) = (sfTF' sf2) dt b +cpXXAux sf1 sf2 = SF' tf False + where + tf dt a = (cpXXAux sf1' sf2', c) + where + (sf1', b) = (sfTF' sf1) dt a + (sf2', c) = (sfTF' sf2) dt b +-} + +{- +cpXXAux sf1 sf2 | unsimplifiable sf1 sf2 = SF' tf False + | otherwise = cpXX sf1 sf2 + where + tf dt a = (cpXXAux sf1' sf2', c) + where + (sf1', b) = (sfTF' sf1) dt a + (sf2', c) = (sfTF' sf2) dt b + + unsimplifiable sf1@(SF' _ _) sf2@(SF' _ _) = True + unsimplifiable sf1 sf2 = True +-} + +{- +-- wrong ... +cpXXAux sf1@(SF' _ False) sf2 = SF' tf False +cpXXAux sf1@(SFCpAXA _ False _ _ _) sf2 = SF' tf False +cpXXAux sf1 sf2@(SF' _ False) = SF' tf False +cpXXAux sf1 sf2@(SFCpAXA _ False _ _ _) = SF' tf False +cpXXAux sf1 sf2 = + if sfIsInv sf1 && sfIsInv sf2 then cpXXInv sf1 sf2 else SF' tf False + where + tf dt a = (cpXXAux sf1' sf2', c) + where + (sf1', b) = (sfTF' sf1) dt a + (sf2', c) = (sfTF' sf2) dt b +-} + +{- +cpXXInv sf1 sf2 = SF' tf True + where + tf dt a = sf1 `seq` sf2 `seq` (cpXXInv sf1' sf2', c) + where + (sf1', b) = (sfTF' sf1) dt a + (sf2', c) = (sfTF' sf2) dt b +-} + +-- !!! No. We need local defs. Keep fd1 and fd2. Extract f1 and f2 +-- !!! once and fo all. Get rid of FDI and FDC at the top level. +-- !!! First local def. analyse sf2. SFArr, SFAcc etc. tf in +-- !!! recursive case just make use of f1 and f3. +-- !!! if sf2 is SFInv, that's delegated to a second local +-- !!! recursive def. that does not analyse sf2. + +cpAXA :: FunDesc a b -> SF' b c -> FunDesc c d -> SF' a d +-- Termination: cpAX/cpXA, via cpCX, cpEX etc. only call cpAXA if sf2 +-- is SFCpAXA, and then on the embedded sf and hence on a smaller arg. +cpAXA FDI sf2 fd3 = cpXA sf2 fd3 +cpAXA fd1 sf2 FDI = cpAX fd1 sf2 +cpAXA (FDC b) sf2 fd3 = cpCXA b sf2 fd3 +cpAXA _ _ (FDC d) = sfConst d +cpAXA fd1 sf2 fd3 = + cpAXAAux fd1 (fdFun fd1) fd3 (fdFun fd3) sf2 + where + -- Really: cpAXAAux :: SF' b c -> SF' a d + -- Note: Event cases are not optimized (EXA etc.) + cpAXAAux :: FunDesc a b -> (a -> b) -> FunDesc c d -> (c -> d) + -> SF' b c -> SF' a d + cpAXAAux fd1 _ fd3 _ (SFArr _ fd2) = + sfArr (fdComp (fdComp fd1 fd2) fd3) + cpAXAAux fd1 _ fd3 _ sf2@(SFSScan _ _ _ _) = + cpAX fd1 (cpXA sf2 fd3) + cpAXAAux fd1 _ fd3 _ sf2@(SFEP _ _ _ _) = + cpAX fd1 (cpXA sf2 fd3) + cpAXAAux fd1 _ fd3 _ (SFCpAXA _ fd21 sf22 fd23) = + cpAXA (fdComp fd1 fd21) sf22 (fdComp fd23 fd3) + cpAXAAux fd1 f1 fd3 f3 sf2 = SFCpAXA tf fd1 sf2 fd3 +{- + if sfIsInv sf2 then + cpAXAInv fd1 f1 fd3 f3 sf2 + else + SFCpAXA tf False fd1 sf2 fd3 +-} + where + tf dt a = (cpAXAAux fd1 f1 fd3 f3 sf2', f3 c) + where + (sf2', c) = (sfTF' sf2) dt (f1 a) + +{- + cpAXAInv fd1 f1 fd3 f3 sf2 = SFCpAXA tf True fd1 sf2 fd3 + where + tf dt a = sf2 `seq` (cpAXAInv fd1 f1 fd3 f3 sf2', f3 c) + where + (sf2', c) = (sfTF' sf2) dt (f1 a) +-} + +cpAX :: FunDesc a b -> SF' b c -> SF' a c +cpAX FDI sf2 = sf2 +cpAX (FDC b) sf2 = cpCX b sf2 +cpAX (FDE f1 f1ne) sf2 = cpEX f1 f1ne sf2 +cpAX (FDG f1) sf2 = cpGX f1 sf2 + +cpXA :: SF' a b -> FunDesc b c -> SF' a c +cpXA sf1 FDI = sf1 +cpXA _ (FDC c) = sfConst c +cpXA sf1 (FDE f2 f2ne) = cpXE sf1 f2 f2ne +cpXA sf1 (FDG f2) = cpXG sf1 f2 + +-- Don't forget that the remaining signal function, if it is +-- SF', later could turn into something else, like SFId. +cpCX :: b -> SF' b c -> SF' a c +cpCX b (SFArr _ fd2) = sfConst ((fdFun fd2) b) +-- 2005-07-01: If we were serious about the semantics of sscan being required +-- to be independent of the sampling interval, I guess one could argue for a +-- fixed-point computation here ... Or maybe not. +-- cpCX b (SFSScan _ _ _ _) = sfConst +cpCX b (SFSScan _ f s c) = sfSScan (\s _ -> f s b) s c +cpCX b (SFEP _ _ _ cne) = sfConst (vfyNoEv b cne) +cpCX b (SFCpAXA _ fd21 sf22 fd23) = + cpCXA ((fdFun fd21) b) sf22 fd23 +cpCX b sf2 = SFCpAXA tf (FDC b) sf2 FDI +{- + if sfIsInv sf2 then + cpCXInv b sf2 + else + SFCpAXA tf False (FDC b) sf2 FDI +-} + where + tf dt _ = (cpCX b sf2', c) + where + (sf2', c) = (sfTF' sf2) dt b + + +{- +cpCXInv b sf2 = SFCpAXA tf True (FDC b) sf2 FDI + where + tf dt _ = sf2 `seq` (cpCXInv b sf2', c) + where + (sf2', c) = (sfTF' sf2) dt b +-} + + +cpCXA :: b -> SF' b c -> FunDesc c d -> SF' a d +cpCXA b sf2 FDI = cpCX b sf2 +cpCXA _ _ (FDC c) = sfConst c +cpCXA b sf2 fd3 = cpCXAAux (FDC b) b fd3 (fdFun fd3) sf2 + where + -- fd1 = FDC b + -- f3 = fdFun fd3 + + -- Really: SF' b c -> SF' a d + cpCXAAux :: FunDesc a b -> b -> FunDesc c d -> (c -> d) + -> SF' b c -> SF' a d + cpCXAAux _ b _ f3 (SFArr _ fd2) = sfConst (f3 ((fdFun fd2) b)) + cpCXAAux _ b _ f3 (SFSScan _ f s c) = sfSScan f' s (f3 c) + where + f' s _ = case f s b of + Nothing -> Nothing + Just (s', c') -> Just (s', f3 c') + cpCXAAux _ b _ f3 (SFEP _ _ _ cne) = sfConst (f3 (vfyNoEv b cne)) + cpCXAAux _ b fd3 _ (SFCpAXA _ fd21 sf22 fd23) = + cpCXA ((fdFun fd21) b) sf22 (fdComp fd23 fd3) + cpCXAAux fd1 b fd3 f3 sf2 = SFCpAXA tf fd1 sf2 fd3 +{- + if sfIsInv sf2 then + cpCXAInv fd1 b fd3 f3 sf2 + else + SFCpAXA tf False fd1 sf2 fd3 +-} + where + tf dt _ = (cpCXAAux fd1 b fd3 f3 sf2', f3 c) + where + (sf2', c) = (sfTF' sf2) dt b + +{- + -- For some reason, seq on sf2' in tf is faster than making + -- cpCXAInv strict in sf2 by seq-ing on the top level (which would + -- be similar to pattern matching on sf2). + cpCXAInv fd1 b fd3 f3 sf2 = SFCpAXA tf True fd1 sf2 fd3 + where + tf dt _ = sf2 `seq` (cpCXAInv fd1 b fd3 f3 sf2', f3 c) + where + (sf2', c) = (sfTF' sf2) dt b +-} + + +cpGX :: (a -> b) -> SF' b c -> SF' a c +cpGX f1 sf2 = cpGXAux (FDG f1) f1 sf2 + where + cpGXAux :: FunDesc a b -> (a -> b) -> SF' b c -> SF' a c + cpGXAux fd1 _ (SFArr _ fd2) = sfArr (fdComp fd1 fd2) + -- We actually do know that (fdComp (FDG f1) fd21) is going to + -- result in an FDG. So we *could* call a cpGXA here. But the + -- price is "inlining" of part of fdComp. + cpGXAux _ f1 (SFSScan _ f s c) = sfSScan (\s a -> f s (f1 a)) s c + -- We really shouldn't see an EP here, as that would mean + -- an arrow INTRODUCING events ... + cpGXAux fd1 _ (SFCpAXA _ fd21 sf22 fd23) = + cpAXA (fdComp fd1 fd21) sf22 fd23 + cpGXAux fd1 f1 sf2 = SFCpAXA tf fd1 sf2 FDI +{- + if sfIsInv sf2 then + cpGXInv fd1 f1 sf2 + else + SFCpAXA tf False fd1 sf2 FDI +-} + where + tf dt a = (cpGXAux fd1 f1 sf2', c) + where + (sf2', c) = (sfTF' sf2) dt (f1 a) + +{- + cpGXInv fd1 f1 sf2 = SFCpAXA tf True fd1 sf2 FDI + where + tf dt a = sf2 `seq` (cpGXInv fd1 f1 sf2', c) + where + (sf2', c) = (sfTF' sf2) dt (f1 a) +-} + + +cpXG :: SF' a b -> (b -> c) -> SF' a c +cpXG sf1 f2 = cpXGAux (FDG f2) f2 sf1 + where + -- Really: cpXGAux :: SF' a b -> SF' a c + cpXGAux :: FunDesc b c -> (b -> c) -> SF' a b -> SF' a c + cpXGAux fd2 _ (SFArr _ fd1) = sfArr (fdComp fd1 fd2) + cpXGAux _ f2 (SFSScan _ f s b) = sfSScan f' s (f2 b) + where + f' s a = case f s a of + Nothing -> Nothing + Just (s', b') -> Just (s', f2 b') + cpXGAux _ f2 (SFEP _ f1 s bne) = sfEP f s (f2 bne) + where + f s a = let (s', b, bne') = f1 s a in (s', f2 b, f2 bne') + cpXGAux fd2 _ (SFCpAXA _ fd11 sf12 fd22) = + cpAXA fd11 sf12 (fdComp fd22 fd2) + cpXGAux fd2 f2 sf1 = SFCpAXA tf FDI sf1 fd2 +{- + if sfIsInv sf1 then + cpXGInv fd2 f2 sf1 + else + SFCpAXA tf False FDI sf1 fd2 +-} + where + tf dt a = (cpXGAux fd2 f2 sf1', f2 b) + where + (sf1', b) = (sfTF' sf1) dt a + +{- + cpXGInv fd2 f2 sf1 = SFCpAXA tf True FDI sf1 fd2 + where + tf dt a = (cpXGInv fd2 f2 sf1', f2 b) + where + (sf1', b) = (sfTF' sf1) dt a +-} + +cpEX :: (Event a -> b) -> b -> SF' b c -> SF' (Event a) c +cpEX f1 f1ne sf2 = cpEXAux (FDE f1 f1ne) f1 f1ne sf2 + where + cpEXAux :: FunDesc (Event a) b -> (Event a -> b) -> b + -> SF' b c -> SF' (Event a) c + cpEXAux fd1 _ _ (SFArr _ fd2) = sfArr (fdComp fd1 fd2) + cpEXAux _ f1 _ (SFSScan _ f s c) = sfSScan (\s a -> f s (f1 a)) s c + -- We must not capture cne in the f closure since cne can change! + -- See cpXX the SFEP/SFEP case for a similar situation. However, + -- FDE represent a state-less signal function, so *its* NoEvent + -- value never changes. Hence we only need to verify that it is + -- NoEvent once. + cpEXAux _ f1 f1ne (SFEP _ f2 s cne) = + sfEP f (s, cne) (vfyNoEv f1ne cne) + where + f scne@(s, cne) a = + case (f1 (Event a)) of + NoEvent -> (scne, cne, cne) + Event b -> + let (s', c, cne') = f2 s b in ((s', cne'), c, cne') + cpEXAux fd1 _ _ (SFCpAXA _ fd21 sf22 fd23) = + cpAXA (fdComp fd1 fd21) sf22 fd23 + -- The rationale for the following is that the case analysis + -- is typically not going to be more expensive than applying + -- the function and possibly a bit cheaper. Thus if events + -- are sparse, we might win, and if not, we don't loose to + -- much. + cpEXAux fd1 f1 f1ne sf2 = SFCpAXA tf fd1 sf2 FDI +{- + if sfIsInv sf2 then + cpEXInv fd1 f1 f1ne sf2 + else + SFCpAXA tf False fd1 sf2 FDI +-} + where + tf dt ea = (cpEXAux fd1 f1 f1ne sf2', c) + where + (sf2', c) = + case ea of + NoEvent -> (sfTF' sf2) dt f1ne + _ -> (sfTF' sf2) dt (f1 ea) + +{- + cpEXInv fd1 f1 f1ne sf2 = SFCpAXA tf True fd1 sf2 FDI + where + tf dt ea = sf2 `seq` (cpEXInv fd1 f1 f1ne sf2', c) + where + (sf2', c) = + case ea of + NoEvent -> (sfTF' sf2) dt f1ne + _ -> (sfTF' sf2) dt (f1 ea) +-} + +cpXE :: SF' a (Event b) -> (Event b -> c) -> c -> SF' a c +cpXE sf1 f2 f2ne = cpXEAux (FDE f2 f2ne) f2 f2ne sf1 + where + cpXEAux :: FunDesc (Event b) c -> (Event b -> c) -> c + -> SF' a (Event b) -> SF' a c + cpXEAux fd2 _ _ (SFArr _ fd1) = sfArr (fdComp fd1 fd2) + cpXEAux _ f2 f2ne (SFSScan _ f s eb) = sfSScan f' s (f2 eb) + where + f' s a = case f s a of + Nothing -> Nothing + Just (s', NoEvent) -> Just (s', f2ne) + Just (s', eb') -> Just (s', f2 eb') + cpXEAux _ f2 f2ne (SFEP _ f1 s ebne) = + sfEP f s (vfyNoEv ebne f2ne) + where + f s a = + case f1 s a of + (s', NoEvent, NoEvent) -> (s', f2ne, f2ne) + (s', eb, NoEvent) -> (s', f2 eb, f2ne) + _ -> usrErr "AFRP" "cpXEAux" "Assertion failed: Functions on events must not map NoEvent to Event." + cpXEAux fd2 _ _ (SFCpAXA _ fd11 sf12 fd13) = + cpAXA fd11 sf12 (fdComp fd13 fd2) + cpXEAux fd2 f2 f2ne sf1 = SFCpAXA tf FDI sf1 fd2 +{- + if sfIsInv sf1 then + cpXEInv fd2 f2 f2ne sf1 + else + SFCpAXA tf False FDI sf1 fd2 +-} + where + tf dt a = (cpXEAux fd2 f2 f2ne sf1', + case eb of NoEvent -> f2ne; _ -> f2 eb) + where + (sf1', eb) = (sfTF' sf1) dt a + +{- + cpXEInv fd2 f2 f2ne sf1 = SFCpAXA tf True FDI sf1 fd2 + where + tf dt a = sf1 `seq` (cpXEInv fd2 f2 f2ne sf1', + case eb of NoEvent -> f2ne; _ -> f2 eb) + where + (sf1', eb) = (sfTF' sf1) dt a +-} + + +-- Widening. +-- The definition exploits the following identities: +-- first identity = identity -- New +-- first (constant b) = arr (\(_, c) -> (b, c)) +-- (first (arr f)) = arr (\(a, c) -> (f a, c)) +firstPrim :: SF a b -> SF (a,c) (b,c) +firstPrim (SF {sfTF = tf10}) = SF {sfTF = tf0} + where + tf0 ~(a0, c0) = (fpAux sf1, (b0, c0)) + where + (sf1, b0) = tf10 a0 + + +-- Also used in parSplitPrim +fpAux :: SF' a b -> SF' (a,c) (b,c) +fpAux (SFArr _ FDI) = sfId -- New +fpAux (SFArr _ (FDC b)) = sfArrG (\(~(_, c)) -> (b, c)) +fpAux (SFArr _ fd1) = sfArrG (\(~(a, c)) -> ((fdFun fd1) a, c)) +fpAux sf1 = SF' tf + -- if sfIsInv sf1 then fpInv sf1 else SF' tf False + where + tf dt ~(a, c) = (fpAux sf1', (b, c)) + where + (sf1', b) = (sfTF' sf1) dt a + + +{- +fpInv :: SF' a b -> SF' (a,c) (b,c) +fpInv sf1 = SF' tf True + where + tf dt ~(a, c) = sf1 `seq` (fpInv sf1', (b, c)) + where + (sf1', b) = (sfTF' sf1) dt a +-} + + +-- Mirror image of first. +secondPrim :: SF a b -> SF (c,a) (c,b) +secondPrim (SF {sfTF = tf10}) = SF {sfTF = tf0} + where + tf0 ~(c0, a0) = (spAux sf1, (c0, b0)) + where + (sf1, b0) = tf10 a0 + + +-- Also used in parSplitPrim +spAux :: SF' a b -> SF' (c,a) (c,b) +spAux (SFArr _ FDI) = sfId -- New +spAux (SFArr _ (FDC b)) = sfArrG (\(~(c, _)) -> (c, b)) +spAux (SFArr _ fd1) = sfArrG (\(~(c, a)) -> (c, (fdFun fd1) a)) +spAux sf1 = SF' tf + -- if sfIsInv sf1 then spInv sf1 else SF' tf False + where + tf dt ~(c, a) = (spAux sf1', (c, b)) + where + (sf1', b) = (sfTF' sf1) dt a + + +{- +spInv :: SF' a b -> SF' (c,a) (c,b) +spInv sf1 = SF' tf True + where + tf dt ~(c, a) = sf1 `seq` (spInv sf1', (c, b)) + where + (sf1', b) = (sfTF' sf1) dt a +-} + + +-- Parallel composition. +-- The definition exploits the following identities (that hold for SF): +-- identity *** identity = identity -- New +-- sf *** identity = first sf -- New +-- identity *** sf = second sf -- New +-- constant b *** constant d = constant (b, d) +-- constant b *** arr f2 = arr (\(_, c) -> (b, f2 c) +-- arr f1 *** constant d = arr (\(a, _) -> (f1 a, d) +-- arr f1 *** arr f2 = arr (\(a, b) -> (f1 a, f2 b) +parSplitPrim :: SF a b -> SF c d -> SF (a,c) (b,d) +parSplitPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0} + where + tf0 ~(a0, c0) = (psXX sf1 sf2, (b0, d0)) + where + (sf1, b0) = tf10 a0 + (sf2, d0) = tf20 c0 + + -- Naming convention: ps where and is one of: + -- X - arbitrary signal function + -- A - arbitrary pure arrow + -- C - constant arrow + + psXX :: SF' a b -> SF' c d -> SF' (a,c) (b,d) + psXX (SFArr _ fd1) (SFArr _ fd2) = sfArr (fdPar fd1 fd2) + psXX (SFArr _ FDI) sf2 = spAux sf2 -- New + psXX (SFArr _ (FDC b)) sf2 = psCX b sf2 + psXX (SFArr _ fd1) sf2 = psAX (fdFun fd1) sf2 + psXX sf1 (SFArr _ FDI) = fpAux sf1 -- New + psXX sf1 (SFArr _ (FDC d)) = psXC sf1 d + psXX sf1 (SFArr _ fd2) = psXA sf1 (fdFun fd2) +-- !!! Unclear if this really is a gain. +-- !!! potentially unnecessary tupling and untupling. +-- !!! To be investigated. +-- !!! 2005-07-01: At least for MEP 6, the corresponding opt for +-- !!! &&& was harmfull. On that basis, disable it here too. +-- psXX (SFCpAXA _ fd11 sf12 fd13) (SFCpAXA _ fd21 sf22 fd23) = +-- cpAXA (fdPar fd11 fd21) (psXX sf12 sf22) (fdPar fd13 fd23) + psXX sf1 sf2 = SF' tf +{- + if sfIsInv sf1 && sfIsInv sf2 then + psXXInv sf1 sf2 + else + SF' tf False +-} + where + tf dt ~(a, c) = (psXX sf1' sf2', (b, d)) + where + (sf1', b) = (sfTF' sf1) dt a + (sf2', d) = (sfTF' sf2) dt c + +{- + psXXInv :: SF' a b -> SF' c d -> SF' (a,c) (b,d) + psXXInv sf1 sf2 = SF' tf True + where + tf dt ~(a, c) = sf1 `seq` sf2 `seq` (psXXInv sf1' sf2', + (b, d)) + where + (sf1', b) = (sfTF' sf1) dt a + (sf2', d) = (sfTF' sf2) dt c +-} + + psCX :: b -> SF' c d -> SF' (a,c) (b,d) + psCX b (SFArr _ fd2) = sfArr (fdPar (FDC b) fd2) + psCX b sf2 = SF' tf +{- + if sfIsInv sf2 then + psCXInv b sf2 + else + SF' tf False +-} + where + tf dt ~(_, c) = (psCX b sf2', (b, d)) + where + (sf2', d) = (sfTF' sf2) dt c + +{- + psCXInv :: b -> SF' c d -> SF' (a,c) (b,d) + psCXInv b sf2 = SF' tf True + where + tf dt ~(_, c) = sf2 `seq` (psCXInv b sf2', (b, d)) + where + (sf2', d) = (sfTF' sf2) dt c +-} + + psXC :: SF' a b -> d -> SF' (a,c) (b,d) + psXC (SFArr _ fd1) d = sfArr (fdPar fd1 (FDC d)) + psXC sf1 d = SF' tf +{- + if sfIsInv sf1 then + psXCInv sf1 d + else + SF' tf False +-} + where + tf dt ~(a, _) = (psXC sf1' d, (b, d)) + where + (sf1', b) = (sfTF' sf1) dt a + +{- + psXCInv :: SF' a b -> d -> SF' (a,c) (b,d) + psXCInv sf1 d = SF' tf True + where + tf dt ~(a, _) = sf1 `seq` (psXCInv sf1' d, (b, d)) + where + (sf1', b) = (sfTF' sf1) dt a +-} + + psAX :: (a -> b) -> SF' c d -> SF' (a,c) (b,d) + psAX f1 (SFArr _ fd2) = sfArr (fdPar (FDG f1) fd2) + psAX f1 sf2 = SF' tf +{- + if sfIsInv sf2 then + psAXInv f1 sf2 + else + SF' tf False +-} + where + tf dt ~(a, c) = (psAX f1 sf2', (f1 a, d)) + where + (sf2', d) = (sfTF' sf2) dt c + +{- + psAXInv :: (a -> b) -> SF' c d -> SF' (a,c) (b,d) + psAXInv f1 sf2 = SF' tf True + where + tf dt ~(a, c) = sf2 `seq` (psAXInv f1 sf2', (f1 a, d)) + where + (sf2', d) = (sfTF' sf2) dt c +-} + + psXA :: SF' a b -> (c -> d) -> SF' (a,c) (b,d) + psXA (SFArr _ fd1) f2 = sfArr (fdPar fd1 (FDG f2)) + psXA sf1 f2 = SF' tf +{- + if sfIsInv sf1 then + psXAInv sf1 f2 + else + SF' tf False +-} + where + tf dt ~(a, c) = (psXA sf1' f2, (b, f2 c)) + where + (sf1', b) = (sfTF' sf1) dt a + +{- + psXAInv :: SF' a b -> (c -> d) -> SF' (a,c) (b,d) + psXAInv sf1 f2 = SF' tf True + where + tf dt ~(a, c) = sf1 `seq` (psXAInv sf1' f2, (b, f2 c)) + where + (sf1', b) = (sfTF' sf1) dt a +-} + + +-- !!! Hmmm. Why don't we optimize the FDE cases here??? +-- !!! Seems pretty obvious that we should! +-- !!! It should also be possible to optimize an event processor in +-- !!! parallel with another event processor or an Arr FDE. + +parFanOutPrim :: SF a b -> SF a c -> SF a (b, c) +parFanOutPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0} + where + tf0 a0 = (pfoXX sf1 sf2, (b0, c0)) + where + (sf1, b0) = tf10 a0 + (sf2, c0) = tf20 a0 + + -- Naming convention: pfo where and is one of: + -- X - arbitrary signal function + -- A - arbitrary pure arrow + -- I - identity arrow + -- C - constant arrow + + pfoXX :: SF' a b -> SF' a c -> SF' a (b ,c) + pfoXX (SFArr _ fd1) (SFArr _ fd2) = sfArr(fdFanOut fd1 fd2) + pfoXX (SFArr _ FDI) sf2 = pfoIX sf2 + pfoXX (SFArr _ (FDC b)) sf2 = pfoCX b sf2 + pfoXX (SFArr _ fd1) sf2 = pfoAX (fdFun fd1) sf2 + pfoXX sf1 (SFArr _ FDI) = pfoXI sf1 + pfoXX sf1 (SFArr _ (FDC c)) = pfoXC sf1 c + pfoXX sf1 (SFArr _ fd2) = pfoXA sf1 (fdFun fd2) +-- !!! Unclear if this really would be a gain +-- !!! 2005-07-01: NOT a win for MEP 6. +-- pfoXX (SFCpAXA _ fd11 sf12 fd13) (SFCpAXA _ fd21 sf22 fd23) = +-- cpAXA (fdPar fd11 fd21) (psXX sf12 sf22) (fdPar fd13 fd23) + pfoXX sf1 sf2 = SF' tf +{- + if sfIsInv sf1 && sfIsInv sf2 then + pfoXXInv sf1 sf2 + else + SF' tf False +-} + where + tf dt a = (pfoXX sf1' sf2', (b, c)) + where + (sf1', b) = (sfTF' sf1) dt a + (sf2', c) = (sfTF' sf2) dt a + +{- + pfoXXInv :: SF' a b -> SF' a c -> SF' a (b ,c) + pfoXXInv sf1 sf2 = SF' tf True + where + tf dt a = sf1 `seq` sf2 `seq` (pfoXXInv sf1' sf2', (b, c)) + where + (sf1', b) = (sfTF' sf1) dt a + (sf2', c) = (sfTF' sf2) dt a +-} + + pfoIX :: SF' a c -> SF' a (a ,c) + pfoIX (SFArr _ fd2) = sfArr (fdFanOut FDI fd2) + pfoIX sf2 = SF' tf +{- + if sfIsInv sf2 then + pfoIXInv sf2 + else + SF' tf False +-} + where + tf dt a = (pfoIX sf2', (a, c)) + where + (sf2', c) = (sfTF' sf2) dt a + +{- + pfoIXInv :: SF' a c -> SF' a (a ,c) + pfoIXInv sf2 = SF' tf True + where + tf dt a = sf2 `seq` (pfoIXInv sf2', (a, c)) + where + (sf2', c) = (sfTF' sf2) dt a +-} + + pfoXI :: SF' a b -> SF' a (b ,a) + pfoXI (SFArr _ fd1) = sfArr (fdFanOut fd1 FDI) + pfoXI sf1 = SF' tf +{- + if sfIsInv sf1 then + pfoXIInv sf1 + else + SF' tf False +-} + where + tf dt a = (pfoXI sf1', (b, a)) + where + (sf1', b) = (sfTF' sf1) dt a + +{- + pfoXIInv :: SF' a b -> SF' a (b ,a) + pfoXIInv sf1 = SF' tf True + where + tf dt a = sf1 `seq` (pfoXIInv sf1', (b, a)) + where + (sf1', b) = (sfTF' sf1) dt a +-} + + pfoCX :: b -> SF' a c -> SF' a (b ,c) + pfoCX b (SFArr _ fd2) = sfArr (fdFanOut (FDC b) fd2) + pfoCX b sf2 = SF' tf +{- + if sfIsInv sf2 then + pfoCXInv b sf2 + else + SF' tf False +-} + where + tf dt a = (pfoCX b sf2', (b, c)) + where + (sf2', c) = (sfTF' sf2) dt a + +{- + pfoCXInv :: b -> SF' a c -> SF' a (b ,c) + pfoCXInv b sf2 = SF' tf True + where + tf dt a = sf2 `seq` (pfoCXInv b sf2', (b, c)) + where + (sf2', c) = (sfTF' sf2) dt a +-} + + pfoXC :: SF' a b -> c -> SF' a (b ,c) + pfoXC (SFArr _ fd1) c = sfArr (fdFanOut fd1 (FDC c)) + pfoXC sf1 c = SF' tf +{- + if sfIsInv sf1 then + pfoXCInv sf1 c + else + SF' tf False +-} + where + tf dt a = (pfoXC sf1' c, (b, c)) + where + (sf1', b) = (sfTF' sf1) dt a + +{- + pfoXCInv :: SF' a b -> c -> SF' a (b ,c) + pfoXCInv sf1 c = SF' tf True + where + tf dt a = sf1 `seq` (pfoXCInv sf1' c, (b, c)) + where + (sf1', b) = (sfTF' sf1) dt a +-} + + pfoAX :: (a -> b) -> SF' a c -> SF' a (b ,c) + pfoAX f1 (SFArr _ fd2) = sfArr (fdFanOut (FDG f1) fd2) + pfoAX f1 sf2 = SF' tf +{- + if sfIsInv sf2 then + pfoAXInv f1 sf2 + else + SF' tf False +-} + where + tf dt a = (pfoAX f1 sf2', (f1 a, c)) + where + (sf2', c) = (sfTF' sf2) dt a + +{- + pfoAXInv :: (a -> b) -> SF' a c -> SF' a (b ,c) + pfoAXInv f1 sf2 = SF' tf True + where + tf dt a = sf2 `seq` (pfoAXInv f1 sf2', (f1 a, c)) + where + (sf2', c) = (sfTF' sf2) dt a +-} + + pfoXA :: SF' a b -> (a -> c) -> SF' a (b ,c) + pfoXA (SFArr _ fd1) f2 = sfArr (fdFanOut fd1 (FDG f2)) + pfoXA sf1 f2 = SF' tf +{- + if sfIsInv sf1 then + pfoXAInv sf1 f2 + else + SF' tf False +-} + where + tf dt a = (pfoXA sf1' f2, (b, f2 a)) + where + (sf1', b) = (sfTF' sf1) dt a + +{- + pfoXAInv :: SF' a b -> (a -> c) -> SF' a (b ,c) + pfoXAInv sf1 f2 = SF' tf True + where + tf dt a = sf1 `seq` (pfoXAInv sf1' f2, (b, f2 a)) + where + (sf1', b) = (sfTF' sf1) dt a +-} + + +------------------------------------------------------------------------------ +-- ArrowLoop instance and implementation +------------------------------------------------------------------------------ + +instance ArrowLoop SF where + loop = loopPrim + + +loopPrim :: SF (a,c) (b,c) -> SF a b +loopPrim (SF {sfTF = tf10}) = SF {sfTF = tf0} + where + tf0 a0 = (loopAux sf1, b0) + where + (sf1, (b0, c0)) = tf10 (a0, c0) + + loopAux :: SF' (a,c) (b,c) -> SF' a b + loopAux (SFArr _ FDI) = sfId + loopAux (SFArr _ (FDC (b, _))) = sfConst b + loopAux (SFArr _ fd1) = + sfArrG (\a -> let (b,c) = (fdFun fd1) (a,c) in b) + loopAux sf1 = SF' tf +{- + if sfIsInv sf1 then + loopInv sf1 + else + SF' tf False +-} + where + tf dt a = (loopAux sf1', b) + where + (sf1', (b, c)) = (sfTF' sf1) dt (a, c) + +{- + loopInv :: SF' (a,c) (b,c) -> SF' a b + loopInv sf1 = SF' tf True + where + tf dt a = sf1 `seq` (loopInv sf1', b) + where + (sf1', (b, c)) = (sfTF' sf1) dt (a, c) +-} + + +------------------------------------------------------------------------------ +-- Basic signal functions +------------------------------------------------------------------------------ + +-- Identity: identity = arr id +identity :: SF a a +identity = SF {sfTF = \a -> (sfId, a)} + + +-- Identity: constant b = arr (const b) +constant :: b -> SF a b +constant b = SF {sfTF = \_ -> (sfConst b, b)} + + +-- Outputs the time passed since the signal function instance was started. +localTime :: SF a Time +localTime = constant 1.0 >>> integral + + +-- Alternative name for localTime. +time :: SF a Time +time = localTime + + +------------------------------------------------------------------------------ +-- Initialization +------------------------------------------------------------------------------ + +-- Initialization operator (cf. Lustre/Lucid Synchrone). +(-->) :: b -> SF a b -> SF a b +b0 --> (SF {sfTF = tf10}) = SF {sfTF = \a0 -> (fst (tf10 a0), b0)} + + +-- Input initialization operator. +(>--) :: a -> SF a b -> SF a b +a0 >-- (SF {sfTF = tf10}) = SF {sfTF = \_ -> tf10 a0} + + +-- Transform initial output value. +(-=>) :: (b -> b) -> SF a b -> SF a b +f -=> (SF {sfTF = tf10}) = + SF {sfTF = \a0 -> let (sf1, b0) = tf10 a0 in (sf1, f b0)} + + +-- Transform initial input value. +(>=-) :: (a -> a) -> SF a b -> SF a b +f >=- (SF {sfTF = tf10}) = SF {sfTF = \a0 -> tf10 (f a0)} + + +-- Override initial value of input signal. +initially :: a -> SF a a +initially = (--> identity) + + +------------------------------------------------------------------------------ +-- Simple, stateful signal processing +------------------------------------------------------------------------------ + +-- New sscan primitive. It should be possible to define lots of functions +-- in terms of this one. Eventually a new constructor will be introduced if +-- this works out. + +sscan :: (b -> a -> b) -> b -> SF a b +sscan f b_init = sscanPrim f' b_init b_init + where + f' b a = let b' = f b a in Just (b', b') + + +{- +sscanPrim :: (c -> a -> Maybe (c, b)) -> c -> b -> SF a b +sscanPrim f c_init b_init = SF {sfTF = tf0} + where + tf0 a0 = case f c_init a0 of + Nothing -> (spAux f c_init b_init, b_init) + Just (c', b') -> (spAux f c' b', b') + + spAux :: (c -> a -> Maybe (c, b)) -> c -> b -> SF' a b + spAux f c b = sf + where + -- sf = SF' tf True + sf = SF' tf + tf _ a = case f c a of + Nothing -> (sf, b) + Just (c', b') -> (spAux f c' b', b') +-} + + +------------------------------------------------------------------------------ +-- Basic event sources +------------------------------------------------------------------------------ + +-- Event source that never occurs. +never :: SF a (Event b) +never = SF {sfTF = \_ -> (sfNever, 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 b0 = (Event b0 --> never) + + +-- Event source with a single occurrence at or as soon after (local) time q +-- as possible. +after :: Time -> b -> SF a (Event b) +after q x = afterEach [(q,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 q x | q > 0 = afterEach qxs + | otherwise = usrErr "AFRP" "repeatedly" "Non-positive period." + where + qxs = (q,x):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 +-} + +-- Or keep old def. for efficiency reasons? +-- After all, after, repeatedly etc. are defined in terms of afterEach. +afterEach :: [(Time,b)] -> SF a (Event b) +afterEach qxs = afterEachCat qxs >>> arr (fmap head) + + +-- Guaranteed not to miss any events. +afterEachCat :: [(Time,b)] -> SF a (Event [b]) +afterEachCat [] = never +afterEachCat ((q,x):qxs) + | q < 0 = usrErr "AFRP" "afterEachCat" "Negative period." + | otherwise = SF {sfTF = tf0} + where + tf0 _ = if q <= 0 then + emitEventsScheduleNext 0.0 [x] qxs + else + (awaitNextEvent (-q) x qxs, NoEvent) + + emitEventsScheduleNext _ xs [] = (sfNever, Event (reverse xs)) + emitEventsScheduleNext t xs ((q,x):qxs) + | q < 0 = usrErr "AFRP" "afterEachCat" "Negative period." + | t' >= 0 = emitEventsScheduleNext t' (x:xs) qxs + | otherwise = (awaitNextEvent t' x qxs, Event (reverse xs)) + where + t' = t - q + awaitNextEvent t x qxs = SF' tf -- False + where + tf dt _ | t' >= 0 = emitEventsScheduleNext t' [x] qxs + | otherwise = (awaitNextEvent t' x qxs, NoEvent) + where + t' = t + 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 q | q < 0 = usrErr "AFRP" "delayEvent" "Negative delay." + | q == 0 = identity + | otherwise = delayEventCat q >>> arr (fmap 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) +-} + +-- This version is not strict in the input event. +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 e = (case e of + NoEvent -> noPendingEvent + Event x -> pendingEvents (-q) [] [] (-q) x, + NoEvent) + + noPendingEvent = SF' tf -- True + where + tf _ e = (case e of + NoEvent -> noPendingEvent + 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 e + | t_next' >= 0 = + emitEventsScheduleNext e t_last' rqxs qxs t_next' [x] + | otherwise = + (pendingEvents t_last'' rqxs' qxs t_next' x, NoEvent) + where + t_next' = t_next + dt + t_last' = t_last + dt + (t_last'', rqxs') = + case e of + NoEvent -> (t_last', rqxs) + Event x' -> (-q, (t_last'+q,x') : 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 e _ [] [] _ rxs = + (case e of + NoEvent -> noPendingEvent + Event x -> pendingEvents (-q) [] [] (-q) x, + Event (reverse rxs)) + emitEventsScheduleNext e t_last rqxs [] t_next rxs = + emitEventsScheduleNext e t_last [] (reverse rqxs) t_next rxs + emitEventsScheduleNext e t_last rqxs ((q', x') : qxs') t_next rxs + | q' > t_next = (case e of + NoEvent -> + pendingEvents t_last + rqxs + qxs' + (t_next - q') + x' + Event x'' -> + pendingEvents (-q) + ((t_last+q, x'') : rqxs) + qxs' + (t_next - q') + x', + Event (reverse rxs)) + | otherwise = emitEventsScheduleNext e + t_last + rqxs + qxs' + (t_next - q') + (x' : rxs) + + +-- A rising edge detector. Useful for things like detecting key presses. +-- 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 = iEdge True + + +iEdge :: Bool -> SF Bool (Event ()) +-- iEdge i = edgeBy (isBoolRaisingEdge ()) i +iEdge b = sscanPrim f (if b then 2 else 0) NoEvent + where + f :: Int -> Bool -> Maybe (Int, Event ()) + f 0 False = Nothing + f 0 True = Just (1, Event ()) + f 1 False = Just (0, NoEvent) + f 1 True = Just (2, NoEvent) + f 2 False = Just (0, NoEvent) + f 2 True = Nothing + f _ _ = undefined + +-- Like edge, but parameterized on the tag value. +edgeTag :: a -> SF Bool (Event a) +-- edgeTag a = edgeBy (isBoolRaisingEdge a) True +edgeTag a = edge >>> arr (`tag` 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 + + +-- !!! 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 = edgeBy isJustEdge (Just undefined) + where + isJustEdge Nothing Nothing = Nothing + isJustEdge Nothing ma@(Just _) = ma + isJustEdge (Just _) (Just _) = Nothing + isJustEdge (Just _) Nothing = 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 isEdge a_init = SF {sfTF = tf0} + where + tf0 a0 = (ebAux a0, maybeToEvent (isEdge a_init a0)) + + ebAux a_prev = SF' tf -- True + where + tf _ a = (ebAux a, maybeToEvent (isEdge a_prev a)) + + +------------------------------------------------------------------------------ +-- Stateful event suppression +------------------------------------------------------------------------------ + +-- Suppression of initial (at local time 0) event. +notYet :: SF (Event a) (Event a) +notYet = initially NoEvent + + +-- Suppress all but first event. +once :: SF (Event a) (Event a) +once = takeEvents 1 + + +-- Suppress all but first n events. +takeEvents :: Int -> SF (Event a) (Event a) +takeEvents n | n <= 0 = never +takeEvents n = dSwitch (arr dup) (const (NoEvent >-- takeEvents (n - 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 n | n <= 0 = identity +dropEvents n = dSwitch (never &&& identity) + (const (NoEvent >-- dropEvents (n - 1))) + + +------------------------------------------------------------------------------ +-- Basic switchers +------------------------------------------------------------------------------ + +-- !!! Interesting case. It seems we need scoped type variables +-- !!! to be able to write down the local type signatures. +-- !!! On the other hand, the scoped type variables seem to +-- !!! prohibit the kind of unification that is needed for GADTs??? +-- !!! Maybe this could be made to wok if it actually WAS known +-- !!! that scoped type variables indeed corresponds to universally +-- !!! quantified variables? Or if one were to keep track of those +-- !!! scoped type variables that actually do? +-- !!! +-- !!! Find a simpler case to experiment further. For now, elim. +-- !!! the free variable. + +{- +-- Basic switch. +switch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b +switch (SF {sfTF = tf10} :: SF a (b, Event c)) (k :: c -> SF a b) = SF {sfTF = tf0} + where + tf0 a0 = + case tf10 a0 of + (sf1, (b0, NoEvent)) -> (switchAux sf1, b0) + (_, (_, Event c0)) -> sfTF (k c0) a0 + + -- It would be nice to optimize further here. E.g. if it would be + -- possible to observe the event source only. + switchAux :: SF' a (b, Event c) -> SF' a b + switchAux (SFId _) = switchAuxA1 id -- New + switchAux (SFConst _ (b, NoEvent)) = sfConst b + switchAux (SFArr _ f1) = switchAuxA1 f1 + switchAux sf1 = SF' tf + where + tf dt a = + case (sfTF' sf1) dt a of + (sf1', (b, NoEvent)) -> (switchAux sf1', b) + (_, (_, Event c)) -> sfTF (k c) a + + -- Could be optimized a little bit further by having a case for + -- identity, switchAuxI1 + + -- Note: While switch behaves as a stateless arrow at this point, that + -- could change after a switch. Hence, SF' overall. + switchAuxA1 :: (a -> (b, Event c)) -> SF' a b + switchAuxA1 f1 = sf + where + sf = SF' tf + tf _ a = + case f1 a of + (b, NoEvent) -> (sf, b) + (_, Event c) -> sfTF (k c) a +-} + +-- Basic switch. +switch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b +switch (SF {sfTF = tf10}) k = SF {sfTF = tf0} + where + tf0 a0 = + case tf10 a0 of + (sf1, (b0, NoEvent)) -> (switchAux sf1 k, b0) + (_, (_, Event c0)) -> sfTF (k c0) a0 + + -- It would be nice to optimize further here. E.g. if it would be + -- possible to observe the event source only. + switchAux :: SF' a (b, Event c) -> (c -> SF a b) -> SF' a b + switchAux (SFArr _ (FDC (b, NoEvent))) _ = sfConst b + switchAux (SFArr _ fd1) k = switchAuxA1 (fdFun fd1) k + switchAux sf1 k = SF' tf +{- + if sfIsInv sf1 then + switchInv sf1 k + else + SF' tf False +-} + where + tf dt a = + case (sfTF' sf1) dt a of + (sf1', (b, NoEvent)) -> (switchAux sf1' k, b) + (_, (_, Event c)) -> sfTF (k c) a + +{- + -- Note: subordinate signal function being invariant does NOT + -- imply that the overall signal function is. + switchInv :: SF' a (b, Event c) -> (c -> SF a b) -> SF' a b + switchInv sf1 k = SF' tf False + where + tf dt a = + case (sfTF' sf1) dt a of + (sf1', (b, NoEvent)) -> (switchInv sf1' k, b) + (_, (_, Event c)) -> sfTF (k c) a +-} + + -- !!! Could be optimized a little bit further by having a case for + -- !!! identity, switchAuxI1. But I'd expect identity is so unlikely + -- !!! that there is no point. + + -- Note: While switch behaves as a stateless arrow at this point, that + -- could change after a switch. Hence, SF' overall. + switchAuxA1 :: (a -> (b, Event c)) -> (c -> SF a b) -> SF' a b + switchAuxA1 f1 k = sf + where + sf = SF' tf -- False + tf _ a = + case f1 a of + (b, NoEvent) -> (sf, b) + (_, Event c) -> sfTF (k c) a + + +-- Switch with delayed observation. +-- Or "decoupled switch"? +-- (The SFId optimization is highly unlikley to be of much use, but it +-- does raise an interesting typing issue.) +dSwitch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b +dSwitch (SF {sfTF = tf10}) k = SF {sfTF = tf0} + where + tf0 a0 = + let (sf1, (b0, ec0)) = tf10 a0 + in (case ec0 of + NoEvent -> dSwitchAux sf1 k + Event c0 -> fst (sfTF (k c0) a0), + b0) + + -- It would be nice to optimize further here. E.g. if it would be + -- possible to observe the event source only. + dSwitchAux :: SF' a (b, Event c) -> (c -> SF a b) -> SF' a b + dSwitchAux (SFArr _ (FDC (b, NoEvent))) _ = sfConst b + dSwitchAux (SFArr _ fd1) k = dSwitchAuxA1 (fdFun fd1) k + dSwitchAux sf1 k = SF' tf +{- + if sfIsInv sf1 then + dSwitchInv sf1 k + else + SF' tf False +-} + where + tf dt a = + let (sf1', (b, ec)) = (sfTF' sf1) dt a + in (case ec of + NoEvent -> dSwitchAux sf1' k + Event c -> fst (sfTF (k c) a), + + b) + +{- + -- Note: that the subordinate signal function is invariant does NOT + -- imply that the overall signal function is. + dSwitchInv :: SF' a (b, Event c) -> (c -> SF a b) -> SF' a b + dSwitchInv sf1 k = SF' tf False + where + tf dt a = + let (sf1', (b, ec)) = (sfTF' sf1) dt a + in (case ec of + NoEvent -> dSwitchInv sf1' k + Event c -> fst (sfTF (k c) a), + + b) +-} + + -- !!! Could be optimized a little bit further by having a case for + -- !!! identity, switchAuxI1 + + -- Note: While dSwitch behaves as a stateless arrow at this point, that + -- could change after a switch. Hence, SF' overall. + dSwitchAuxA1 :: (a -> (b, Event c)) -> (c -> SF a b) -> SF' a b + dSwitchAuxA1 f1 k = sf + where + sf = SF' tf -- False + tf _ a = + let (b, ec) = f1 a + in (case ec of + NoEvent -> sf + Event c -> fst (sfTF (k c) a), + + b) + + +-- Recurring switch. +-- !!! Suboptimal. Overall, the constructor is invarying since rSwitch is +-- !!! being invoked recursively on a switch. In fact, we don't even care +-- !!! whether the subordinate signal function is invarying or not. +-- !!! We could make use of a signal function transformer sfInv to +-- !!! mark the constructor as invarying. Would that make sense? +-- !!! The price would be an extra loop with case analysis. +-- !!! The potential gain is fewer case analyses in superior loops. +rSwitch :: SF a b -> SF (a, Event (SF a b)) b +rSwitch sf = switch (first sf) ((noEventSnd >=-) . rSwitch) + +{- +-- Old version. New is more efficient. Which one is clearer? +rSwitch :: SF a b -> SF (a, Event (SF a b)) b +rSwitch sf = switch (first sf) rSwitch' + where + rSwitch' sf = switch (sf *** notYet) rSwitch' +-} + + +-- Recurring switch with delayed observation. +drSwitch :: SF a b -> SF (a, Event (SF a b)) b +drSwitch sf = dSwitch (first sf) ((noEventSnd >=-) . drSwitch) + +{- +-- Old version. New is more efficient. Which one is clearer? +drSwitch :: SF a b -> SF (a, Event (SF a b)) b +drSwitch sf = dSwitch (first sf) drSwitch' + where + drSwitch' sf = dSwitch (sf *** notYet) drSwitch' +-} + + +-- "Call-with-current-continuation" switch. +-- !!! Has not been optimized properly. +-- !!! Nor has opts been tested! +-- !!! Don't forget Inv opts! +kSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b +kSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0} + where + tf0 a0 = + let (sf1, b0) = tf10 a0 + in + case tfe0 (a0, b0) of + (sfe, NoEvent) -> (kSwitchAux sf1 sfe, b0) + (_, Event c0) -> sfTF (k sf10 c0) a0 + +-- Same problem as above: must pass k explicitly??? +-- kSwitchAux (SFId _) sfe = kSwitchAuxI1 sfe + kSwitchAux (SFArr _ (FDC b)) sfe = kSwitchAuxC1 b sfe + kSwitchAux (SFArr _ fd1) sfe = kSwitchAuxA1 (fdFun fd1) sfe + -- kSwitchAux (SFArrE _ f1) sfe = kSwitchAuxA1 f1 sfe + -- kSwitchAux (SFArrEE _ f1) sfe = kSwitchAuxA1 f1 sfe + kSwitchAux sf1 (SFArr _ (FDC NoEvent)) = sf1 + kSwitchAux sf1 (SFArr _ fde) = kSwitchAuxAE sf1 (fdFun fde) + -- kSwitchAux sf1 (SFArrE _ fe) = kSwitchAuxAE sf1 fe + -- kSwitchAux sf1 (SFArrEE _ fe) = kSwitchAuxAE sf1 fe + kSwitchAux sf1 sfe = SF' tf -- False + where + tf dt a = + let (sf1', b) = (sfTF' sf1) dt a + in + case (sfTF' sfe) dt (a, b) of + (sfe', NoEvent) -> (kSwitchAux sf1' sfe', b) + (_, Event c) -> sfTF (k (freeze sf1 dt) c) a + +{- +-- !!! Untested optimization! + kSwitchAuxI1 (SFConst _ NoEvent) = sfId + kSwitchAuxI1 (SFArr _ fe) = kSwitchAuxI1AE fe + kSwitchAuxI1 sfe = SF' tf + where + tf dt a = + case (sfTF' sfe) dt (a, a) of + (sfe', NoEvent) -> (kSwitchAuxI1 sfe', a) + (_, Event c) -> sfTF (k identity c) a +-} + +-- !!! Untested optimization! + kSwitchAuxC1 b (SFArr _ (FDC NoEvent)) = sfConst b + kSwitchAuxC1 b (SFArr _ fde) = kSwitchAuxC1AE b (fdFun fde) + -- kSwitchAuxC1 b (SFArrE _ fe) = kSwitchAuxC1AE b fe + -- kSwitchAuxC1 b (SFArrEE _ fe) = kSwitchAuxC1AE b fe + kSwitchAuxC1 b sfe = SF' tf -- False + where + tf dt a = + case (sfTF' sfe) dt (a, b) of + (sfe', NoEvent) -> (kSwitchAuxC1 b sfe', b) + (_, Event c) -> sfTF (k (constant b) c) a + +-- !!! Untested optimization! + kSwitchAuxA1 f1 (SFArr _ (FDC NoEvent)) = sfArrG f1 + kSwitchAuxA1 f1 (SFArr _ fde) = kSwitchAuxA1AE f1 (fdFun fde) + -- kSwitchAuxA1 f1 (SFArrE _ fe) = kSwitchAuxA1AE f1 fe + -- kSwitchAuxA1 f1 (SFArrEE _ fe) = kSwitchAuxA1AE f1 fe + kSwitchAuxA1 f1 sfe = SF' tf -- False + where + tf dt a = + let b = f1 a + in + case (sfTF' sfe) dt (a, b) of + (sfe', NoEvent) -> (kSwitchAuxA1 f1 sfe', b) + (_, Event c) -> sfTF (k (arr f1) c) a + +-- !!! Untested optimization! +-- kSwitchAuxAE (SFId _) fe = kSwitchAuxI1AE fe + kSwitchAuxAE (SFArr _ (FDC b)) fe = kSwitchAuxC1AE b fe + kSwitchAuxAE (SFArr _ fd1) fe = kSwitchAuxA1AE (fdFun fd1) fe + -- kSwitchAuxAE (SFArrE _ f1) fe = kSwitchAuxA1AE f1 fe + -- kSwitchAuxAE (SFArrEE _ f1) fe = kSwitchAuxA1AE f1 fe + kSwitchAuxAE sf1 fe = SF' tf -- False + where + tf dt a = + let (sf1', b) = (sfTF' sf1) dt a + in + case fe (a, b) of + NoEvent -> (kSwitchAuxAE sf1' fe, b) + Event c -> sfTF (k (freeze sf1 dt) c) a + +{- +-- !!! Untested optimization! + kSwitchAuxI1AE fe = SF' tf -- False + where + tf dt a = + case fe (a, a) of + NoEvent -> (kSwitchAuxI1AE fe, a) + Event c -> sfTF (k identity c) a +-} + +-- !!! Untested optimization! + kSwitchAuxC1AE b fe = SF' tf -- False + where + tf _ a = + case fe (a, b) of + NoEvent -> (kSwitchAuxC1AE b fe, b) + Event c -> sfTF (k (constant b) c) a + +-- !!! Untested optimization! + kSwitchAuxA1AE f1 fe = SF' tf -- False + where + tf _ a = + let b = f1 a + in + case fe (a, b) of + NoEvent -> (kSwitchAuxA1AE f1 fe, b) + Event c -> sfTF (k (arr f1) c) a + + +-- kSwitch with delayed observation. +-- !!! Has not been optimized properly. Should be like kSwitch. +dkSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b +dkSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0} + where + tf0 a0 = + let (sf1, b0) = tf10 a0 + in (case tfe0 (a0, b0) of + (sfe, NoEvent) -> dkSwitchAux sf1 sfe + (_, Event c0) -> fst (sfTF (k sf10 c0) a0), + b0) + + dkSwitchAux sf1 (SFArr _ (FDC NoEvent)) = sf1 + dkSwitchAux sf1 sfe = SF' tf -- False + where + tf dt a = + let (sf1', b) = (sfTF' sf1) dt a + in (case (sfTF' sfe) dt (a, b) of + (sfe', NoEvent) -> dkSwitchAux sf1' sfe' + (_, Event c) -> fst (sfTF (k (freeze sf1 dt) c) a), + b) + + +------------------------------------------------------------------------------ +-- Parallel composition and switching over collections with broadcasting +------------------------------------------------------------------------------ + +broadcast :: Functor col => a -> col sf -> col (a, sf) +broadcast a sfs = fmap (\sf -> (a, sf)) sfs + + +-- !!! Hmm. We should really optimize here. +-- !!! Check for Arr in parallel! +-- !!! Check for Arr FDE in parallel!!! +-- !!! Check for EP in parallel!!!!! +-- !!! Cf &&&. +-- !!! But how??? All we know is that the collection is a functor ... +-- !!! Maybe that kind of generality does not make much sense for +-- !!! par and parB? (Although it is niceto be able to switch into a +-- !!! par or parB from within a pSwitch[B].) +-- !!! If we had a parBList, that could be defined in terms of &&&, surely? +-- !!! E.g. +-- !!! parBList [] = constant [] +-- !!! parBList (sf:sfs) = sf &&& parBList sfs >>> arr (\(x,xs) -> x:xs) +-- !!! +-- !!! This ought to optimize quite well. E.g. +-- !!! parBList [arr1,arr2,arr3] +-- !!! = arr1 &&& parBList [arr2,arr3] >>> arrX +-- !!! = arr1 &&& (arr2 &&& parBList [arr3] >>> arrX) >>> arrX +-- !!! = arr1 &&& (arr2 &&& (arr3 &&& parBList [] >>> arrX) >>> arrX) >>> arrX +-- !!! = arr1 &&& (arr2 &&& (arr3C >>> arrX) >>> arrX) >>> arrX +-- !!! = arr1 &&& (arr2 &&& (arr3CcpX) >>> arrX) >>> arrX +-- !!! = arr1 &&& (arr23CcpX >>> arrX) >>> arrX +-- !!! = arr1 &&& (arr23CcpXcpX) >>> arrX +-- !!! = arr123CcpXcpXcpX + +-- Spatial parallel composition of a signal function collection. +parB :: Functor col => col (SF a b) -> SF a (col b) +parB = par broadcast + + +-- Parallel switch (dynamic collection of signal functions spatially composed +-- in parallel). +pSwitchB :: Functor col => + col (SF a b) -> SF (a,col b) (Event c) -> (col (SF a b)->c-> SF a (col b)) + -> SF a (col b) +pSwitchB = pSwitch broadcast + + +dpSwitchB :: Functor col => + col (SF a b) -> SF (a,col b) (Event c) -> (col (SF a b)->c->SF a (col b)) + -> SF a (col b) +dpSwitchB = dpSwitch broadcast + + +rpSwitchB :: Functor col => + col (SF a b) -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b) +rpSwitchB = rpSwitch broadcast + + +drpSwitchB :: Functor col => + col (SF a b) -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b) +drpSwitchB = drpSwitch broadcast + + +------------------------------------------------------------------------------ +-- Parallel composition and switching over collections with general routing +------------------------------------------------------------------------------ + +-- Spatial parallel composition of a signal function collection parameterized +-- on the routing function. +-- rf ......... Routing function: determines the input to each signal function +-- in the collection. IMPORTANT! The routing function MUST +-- preserve the structure of the signal function collection. +-- sfs0 ....... Signal function collection. +-- Returns the spatial parallel composition of the supplied signal functions. + +par :: Functor col => + (forall sf . (a -> col sf -> col (b, sf))) + -> col (SF b c) + -> SF a (col c) +par rf sfs0 = SF {sfTF = tf0} + where + tf0 a0 = + let bsfs0 = rf a0 sfs0 + sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0 + sfs = fmap fst sfcs0 + cs0 = fmap snd sfcs0 + in + (parAux rf sfs, cs0) + + +-- Internal definition. Also used in parallel swithers. +parAux :: Functor col => + (forall sf . (a -> col sf -> col (b, sf))) + -> col (SF' b c) + -> SF' a (col c) +parAux rf sfs = SF' tf -- True + where + tf dt a = + let bsfs = rf a sfs + sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs + sfs' = fmap fst sfcs' + cs = fmap snd sfcs' + in + (parAux rf sfs', cs) + + +-- Parallel switch parameterized on the routing function. This is the most +-- general switch from which all other (non-delayed) switches in principle +-- can be derived. The signal function collection is spatially composed in +-- parallel and run until the event signal function has an occurrence. Once +-- the switching event occurs, all signal function are "frozen" and their +-- continuations are passed to the continuation function, along with the +-- event value. +-- rf ......... Routing function: determines the input to each signal function +-- in the collection. IMPORTANT! The routing function has an +-- obligation to preserve the structure of the signal function +-- collection. +-- sfs0 ....... Signal function collection. +-- sfe0 ....... Signal function generating the switching event. +-- k .......... Continuation to be invoked once event occurs. +-- Returns the resulting signal function. +-- +-- !!! Could be optimized on the event source being SFArr, SFArrE, SFArrEE +-- +pSwitch :: Functor col => + (forall sf . (a -> col sf -> col (b, sf))) + -> col (SF b c) + -> SF (a, col c) (Event d) + -> (col (SF b c) -> d -> SF a (col c)) + -> SF a (col c) +pSwitch rf sfs0 sfe0 k = SF {sfTF = tf0} + where + tf0 a0 = + let bsfs0 = rf a0 sfs0 + sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0 + sfs = fmap fst sfcs0 + cs0 = fmap snd sfcs0 + in + case (sfTF sfe0) (a0, cs0) of + (sfe, NoEvent) -> (pSwitchAux sfs sfe, cs0) + (_, Event d0) -> sfTF (k sfs0 d0) a0 + + pSwitchAux sfs (SFArr _ (FDC NoEvent)) = parAux rf sfs + pSwitchAux sfs sfe = SF' tf -- False + where + tf dt a = + let bsfs = rf a sfs + sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs + sfs' = fmap fst sfcs' + cs = fmap snd sfcs' + in + case (sfTF' sfe) dt (a, cs) of + (sfe', NoEvent) -> (pSwitchAux sfs' sfe', cs) + (_, Event d) -> sfTF (k (freezeCol sfs dt) d) a + + +-- Parallel switch with delayed observation parameterized on the routing +-- function. +-- +-- !!! Could be optimized on the event source being SFArr, SFArrE, SFArrEE. +-- +dpSwitch :: Functor col => + (forall sf . (a -> col sf -> col (b, sf))) + -> col (SF b c) + -> SF (a, col c) (Event d) + -> (col (SF b c) -> d -> SF a (col c)) + -> SF a (col c) +dpSwitch rf sfs0 sfe0 k = SF {sfTF = tf0} + where + tf0 a0 = + let bsfs0 = rf a0 sfs0 + sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0 + cs0 = fmap snd sfcs0 + in + (case (sfTF sfe0) (a0, cs0) of + (sfe, NoEvent) -> dpSwitchAux (fmap fst sfcs0) sfe + (_, Event d0) -> fst (sfTF (k sfs0 d0) a0), + cs0) + + dpSwitchAux sfs (SFArr _ (FDC NoEvent)) = parAux rf sfs + dpSwitchAux sfs sfe = SF' tf -- False + where + tf dt a = + let bsfs = rf a sfs + sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs + cs = fmap snd sfcs' + in + (case (sfTF' sfe) dt (a, cs) of + (sfe', NoEvent) -> dpSwitchAux (fmap fst sfcs') + sfe' + (_, Event d) -> fst (sfTF (k (freezeCol sfs dt) + d) + a), + cs) + + +-- Recurring parallel switch parameterized on the routing function. +-- rf ......... Routing function: determines the input to each signal function +-- in the collection. IMPORTANT! The routing function has an +-- obligation to preserve the structure of the signal function +-- collection. +-- sfs ........ Initial signal function collection. +-- Returns the resulting signal function. + +rpSwitch :: Functor col => + (forall sf . (a -> col sf -> col (b, sf))) + -> col (SF b c) -> SF (a, Event (col (SF b c) -> col (SF b c))) (col c) +rpSwitch rf sfs = + pSwitch (rf . fst) sfs (arr (snd . fst)) $ \sfs' f -> + noEventSnd >=- rpSwitch rf (f sfs') + + +{- +rpSwitch rf sfs = pSwitch (rf . fst) sfs (arr (snd . fst)) k + where + k sfs f = rpSwitch' (f sfs) + rpSwitch' sfs = pSwitch (rf . fst) sfs (NoEvent --> arr (snd . fst)) k +-} + +-- Recurring parallel switch with delayed observation parameterized on the +-- routing function. +drpSwitch :: Functor col => + (forall sf . (a -> col sf -> col (b, sf))) + -> col (SF b c) -> SF (a, Event (col (SF b c) -> col (SF b c))) (col c) +drpSwitch rf sfs = + dpSwitch (rf . fst) sfs (arr (snd . fst)) $ \sfs' f -> + noEventSnd >=- drpSwitch rf (f sfs') + +{- +drpSwitch rf sfs = dpSwitch (rf . fst) sfs (arr (snd . fst)) k + where + k sfs f = drpSwitch' (f sfs) + drpSwitch' sfs = dpSwitch (rf . fst) sfs (NoEvent-->arr (snd . fst)) k +-} + + +------------------------------------------------------------------------------ +-- Wave-form generation +------------------------------------------------------------------------------ + +-- Zero-order hold. +-- !!! Should be redone using SFSScan? +-- !!! Otherwise, we are missing an invarying case. +old_hold :: a -> SF (Event a) a +old_hold a_init = switch (constant a_init &&& identity) + ((NoEvent >--) . old_hold) + +hold :: a -> SF (Event a) a +hold a_init = epPrim f () a_init + where + f _ a = ((), a, a) + +-- !!! +-- !!! 2005-04-10: I DO NO LONGER THINK THIS IS CORRECT! +-- !!! CAN ONE POSSIBLY GET THE DESIRED STRICTNESS PROPERTIES +-- !!! ("DECOUPLING") this way??? +-- !!! Also applies to the other "d" functions that were tentatively +-- !!! defined using only epPrim. +-- !!! +-- !!! 2005-06-13: Yes, indeed wrong! (But it's subtle, one has to +-- !!! make sure that the incoming event (and not just the payload +-- !!! of the event) is control dependent on the output of "dHold" +-- !!! to observe it. +-- !!! +-- !!! 2005-06-09: But if iPre can be defined in terms of sscan, +-- !!! and ep + sscan = sscan, then things might work, and +-- !!! it might be possible to define dHold simply as hold >>> iPre +-- !!! without any performance penalty. +-- Zero-order hold with delay. +-- Identity: dHold a0 = hold a0 >>> iPre a0). +dHold :: a -> SF (Event a) a +dHold a0 = hold a0 >>> iPre a0 +{- +-- THIS IS WRONG! SEE ABOVE. +dHold a_init = epPrim f a_init a_init + where + f a' a = (a, a', a) +-} + +-- Tracks input signal when available, holds last value when disappears. +-- !!! DANGER!!! Event used inside arr! Probably OK because arr will not be +-- !!! optimized to arrE. But still. Maybe rewrite this using, say, scan? +-- !!! or switch? Switching (in hold) for every input sample does not +-- !!! seem like such a great idea anyway. +trackAndHold :: a -> SF (Maybe a) a +trackAndHold a_init = arr (maybe NoEvent Event) >>> hold a_init + + +------------------------------------------------------------------------------ +-- Accumulators +------------------------------------------------------------------------------ + +old_accum :: a -> SF (Event (a -> a)) (Event a) +old_accum = accumBy (flip ($)) + +accum :: a -> SF (Event (a -> a)) (Event a) +accum a_init = epPrim f a_init NoEvent + where + f a g = (a', Event a', NoEvent) + where + a' = g a + + +accumHold :: a -> SF (Event (a -> a)) a +accumHold a_init = epPrim f a_init a_init + where + f a g = (a', a', a') + where + a' = g a + +dAccumHold :: a -> SF (Event (a -> a)) a +dAccumHold a_init = accumHold a_init >>> iPre a_init +{- +-- WRONG! +-- epPrim DOES and MUST patternmatch +-- on the input at every time step. +-- Test case to check for this added! +dAccumHold a_init = epPrim f a_init a_init + where + f a g = (a', a, a') + where + a' = g a +-} + + +old_accumBy :: (b -> a -> b) -> b -> SF (Event a) (Event b) +old_accumBy f b_init = switch (never &&& identity) $ \a -> abAux (f b_init a) + where + abAux b = switch (now b &&& notYet) $ \a -> abAux (f b a) + +accumBy :: (b -> a -> b) -> b -> SF (Event a) (Event b) +accumBy g b_init = epPrim f b_init NoEvent + where + f b a = (b', Event b', NoEvent) + where + b' = g b a + +accumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b +accumHoldBy g b_init = epPrim f b_init b_init + where + f b a = (b', b', b') + where + b' = g b a + +-- !!! This cannot be right since epPrim DOES and MUST patternmatch +-- !!! on the input at every time step. +-- !!! Add a test case to check for this! + +dAccumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b +dAccumHoldBy f a_init = accumHoldBy f a_init >>> iPre a_init +{- +-- WRONG! +-- epPrim DOES and MUST patternmatch +-- on the input at every time step. +-- Test case to check for this added! +dAccumHoldBy g b_init = epPrim f b_init b_init + where + f b a = (b', b, b') + where + b' = g b a +-} + + +{- Untested: + +accumBy f b = switch (never &&& identity) $ \a -> + let b' = f b a in NoEvent >-- Event b' --> accumBy f b' + +But no real improvement in clarity anyway. + +-} + +-- accumBy f b = accumFilter (\b -> a -> let b' = f b a in (b', Event b')) b + +{- +-- Identity: accumBy f = accumFilter (\b a -> let b' = f b a in (b',Just b')) +accumBy :: (b -> a -> b) -> b -> SF (Event a) (Event b) +accumBy f b_init = SF {sfTF = tf0} + where + tf0 NoEvent = (abAux b_init, NoEvent) + tf0 (Event a0) = let b' = f b_init a0 + in (abAux b', Event b') + + abAux b = SF' {sfTF' = tf} + where + tf _ NoEvent = (abAux b, NoEvent) + tf _ (Event a) = let b' = f b a + in (abAux b', Event b') +-} + +{- +accumFilter :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b) +accumFilter f c_init = SF {sfTF = tf0} + where + tf0 NoEvent = (afAux c_init, NoEvent) + tf0 (Event a0) = case f c_init a0 of + (c', Nothing) -> (afAux c', NoEvent) + (c', Just b0) -> (afAux c', Event b0) + + afAux c = SF' {sfTF' = tf} + where + tf _ NoEvent = (afAux c, NoEvent) + tf _ (Event a) = case f c a of + (c', Nothing) -> (afAux c', NoEvent) + (c', Just b) -> (afAux c', Event b) +-} + + +old_accumFilter :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b) +old_accumFilter f c_init = switch (never &&& identity) $ \a -> afAux (f c_init a) + where + afAux (c, Nothing) = switch (never &&& notYet) $ \a -> afAux (f c a) + afAux (c, Just b) = switch (now b &&& notYet) $ \a -> afAux (f c a) + +accumFilter :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b) +accumFilter g c_init = epPrim f c_init NoEvent + where + f c a = case g c a of + (c', Nothing) -> (c', NoEvent, NoEvent) + (c', Just b) -> (c', Event b, NoEvent) + + +------------------------------------------------------------------------------ +-- Delays +------------------------------------------------------------------------------ + +-- Uninitialized delay operator. +-- !!! The seq helps in the dynamic delay line example. But is it a good +-- !!! idea in general? Are there other accumulators which should be seq'ed +-- !!! as well? E.g. accum? Switch? Anywhere else? What's the underlying +-- !!! design principle? What can the user assume? +-- +old_pre :: SF a a +old_pre = SF {sfTF = tf0} + where + tf0 a0 = (preAux a0, usrErr "AFRP" "pre" "Uninitialized pre operator.") + + preAux a_prev = SF' tf -- True + where + tf _ a = {- a_prev `seq` -} (preAux a, a_prev) + +-- Initialized delay operator. +old_iPre :: a -> SF a a +old_iPre = (--> old_pre) + + + +-- !!! Redefined using SFSScan +-- !!! About 20% slower than old_pre on its own. +pre :: SF a a +pre = sscanPrim f uninit uninit + where + f c a = Just (a, c) + uninit = usrErr "AFRP" "pre" "Uninitialized pre operator." + + +-- Initialized delay operator. +iPre :: a -> SF a a +iPre = (--> pre) + + +------------------------------------------------------------------------------ +-- Timed delays +------------------------------------------------------------------------------ + + +-- Invariants: +-- t_diff measure the time since the latest output sample ideally +-- should have been output. Whenever that equals or exceeds the +-- time delta for the next buffered sample, it is time to output a +-- new sample (although not necessarily the one first in the queue: +-- it might be necessary to "catch up" by discarding samples. +-- 0 <= t_diff < bdt, where bdt is the buffered time delta for the +-- sample on the front of the buffer queue. +-- +-- Sum of time deltas in the queue >= q. + +-- !!! PROBLEM! +-- Since input samples sometimes need to be duplicated, it is not a +-- good idea use a delay on things like events since we then could +-- end up with duplication of event occurrences. +-- (Thus, we actually NEED delayEvent.) + +delay :: Time -> a -> SF a a +delay q a_init | q < 0 = usrErr "AFRP" "delay" "Negative delay." + | q == 0 = identity + | otherwise = SF {sfTF = tf0} + where + tf0 a0 = (delayAux [] [(q, a0)] 0 a_init, a_init) + + delayAux _ [] _ _ = undefined + delayAux rbuf buf@((bdt, ba) : buf') t_diff a_prev = SF' tf -- True + where + tf dt a | t_diff' < bdt = + (delayAux rbuf' buf t_diff' a_prev, a_prev) + | otherwise = nextSmpl rbuf' buf' (t_diff' - bdt) ba + where + t_diff' = t_diff + dt + rbuf' = (dt, a) : rbuf + + nextSmpl rbuf [] t_diff a = + nextSmpl [] (reverse rbuf) t_diff a + nextSmpl rbuf buf@((bdt, ba) : buf') t_diff a + | t_diff < bdt = (delayAux rbuf buf t_diff a, a) + | otherwise = nextSmpl rbuf buf' (t_diff-bdt) ba + + +-- !!! Hmm. Not so easy to do efficiently, it seems ... + +-- varDelay :: Time -> a -> SF (a, Time) a +-- varDelay = undefined + + +------------------------------------------------------------------------------ +-- Integration and differentiation +------------------------------------------------------------------------------ + +-- Integration using the rectangle rule. +{-# INLINE integral #-} +integral :: VectorSpace a s => SF a a +integral = SF {sfTF = tf0} + where + igrl0 = zeroVector + + tf0 a0 = (integralAux igrl0 a0, igrl0) + + integralAux igrl a_prev = SF' tf -- True + where + tf dt a = (integralAux igrl' a, igrl') + where + igrl' = igrl ^+^ realToFrac dt *^ a_prev + + +-- "immediate" integration (using the function's value at the current time) +imIntegral :: VectorSpace a s => a -> SF a a +imIntegral = ((\ _ a' dt v -> v ^+^ realToFrac dt *^ a') `iterFrom`) + +iterFrom :: (a -> a -> DTime -> b -> b) -> b -> SF a b +f `iterFrom` b = SF (iterAux b) where + -- iterAux b a = (SF' (\ dt a' -> iterAux (f a a' dt b) a') True, b) + iterAux b a = (SF' (\ dt a' -> iterAux (f a a' dt b) a'), b) + + +-- This is extremely crude. Use at your own risk. +derivative :: VectorSpace a s => SF a a +derivative = SF {sfTF = tf0} + where + tf0 a0 = (derivativeAux a0, zeroVector) + + derivativeAux a_prev = SF' tf -- True + where + tf dt a = (derivativeAux a, (a ^-^ a_prev) ^/ realToFrac dt) + + +------------------------------------------------------------------------------ +-- Loops with guaranteed well-defined feedback +------------------------------------------------------------------------------ + +loopPre :: c -> SF (a,c) (b,c) -> SF a b +loopPre c_init sf = loop (second (iPre c_init) >>> sf) + + + +loopIntegral :: VectorSpace c s => SF (a,c) (b,c) -> SF a b +loopIntegral sf = loop (second integral >>> sf) + + +------------------------------------------------------------------------------ +-- Noise (i.e. random signal generators) and stochastic processes +------------------------------------------------------------------------------ + +-- Noise (random signal) with default range for type in question; +-- based on "randoms". +noise :: (RandomGen g, Random b) => g -> SF a b +noise g0 = streamToSF (randoms g0) + + +-- Noise (random signal) with specified range; based on "randomRs". +noiseR :: (RandomGen g, Random b) => (b,b) -> g -> SF a b +noiseR range g0 = streamToSF (randomRs range g0) + + +-- Internal. Not very useful for other purposes since we do not have any +-- control over the intervals between each "sample". Or? A version with +-- time-stamped samples would be similar to embedSynch (applied to identity). +-- The list argument must be a stream (infinite list) at present. + +streamToSF :: [b] -> SF a b +streamToSF [] = intErr "AFRP" "streamToSF" "Empty list!" +streamToSF (b:bs) = SF {sfTF = tf0} + where + tf0 _ = (stsfAux bs, b) + + stsfAux [] = intErr "AFRP" "streamToSF" "Empty list!" + -- Invarying since stsfAux [] is an error. + stsfAux (b:bs) = SF' tf -- True + where + tf _ _ = (stsfAux bs, b) + +{- New def, untested: + +streamToSF = sscan2 f + where + f [] _ = intErr "AFRP" "streamToSF" "Empty list!" + f (b:bs) _ = (bs, b) + +-} + + +-- Stochastic event source with events occurring on average once every t_avg +-- seconds. However, no more than one event results from any one sampling +-- interval in the case of relatively sparse sampling, thus avoiding an +-- "event backlog" should sampling become more frequent at some later +-- point in time. +-- !!! Maybe it would better to give a frequency? But like this to make +-- !!! consitent with "repeatedly". +occasionally :: RandomGen g => g -> Time -> b -> SF a (Event b) +occasionally g t_avg x | t_avg > 0 = SF {sfTF = tf0} + | otherwise = usrErr "AFRP" "occasionally" + "Non-positive average interval." + where + -- Generally, if events occur with an average frequency of f, the + -- probability of at least one event occurring in an interval of t + -- is given by (1 - exp (-f*t)). The goal in the following is to + -- decide whether at least one event occurred in the interval of size + -- dt preceding the current sample point. For the first point, + -- we can think of the preceding interval as being 0, implying + -- no probability of an event occurring. + + tf0 _ = (occAux ((randoms g) :: [Time]), NoEvent) + + occAux [] = undefined + occAux (r:rs) = SF' tf -- True + where + tf dt _ = let p = 1 - exp (-(dt/t_avg)) -- Probability for at least one event. + in (occAux rs, if r < p then Event x else NoEvent) + + + +------------------------------------------------------------------------------ +-- Reactimation +------------------------------------------------------------------------------ + +-- Reactimation of a signal function. +-- init ....... IO action for initialization. Will only be invoked once, +-- at (logical) time 0, before first call to "sense". +-- Expected to return the value of input at time 0. +-- sense ...... IO action for sensing of system input. +-- arg. #1 ....... True: action may block, waiting for an OS event. +-- False: action must not block. +-- res. #1 ....... Time interval since previous invocation of the sensing +-- action (or, the first time round, the init action), +-- returned. The interval must be _strictly_ greater +-- than 0. Thus even a non-blocking invocation must +-- ensure that time progresses. +-- res. #2 ....... Nothing: input is unchanged w.r.t. the previously +-- returned input sample. +-- Just i: the input is currently i. +-- It is OK to always return "Just", even if input is +-- unchanged. +-- actuate .... IO action for outputting the system output. +-- arg. #1 ....... True: output may have changed from previous output +-- sample. +-- False: output is definitely unchanged from previous +-- output sample. +-- It is OK to ignore argument #1 and assume that the +-- the output has always changed. +-- arg. #2 ....... Current output sample. +-- result ....... Termination flag. Once True, reactimate will exit +-- the reactimation loop and return to its caller. +-- sf ......... Signal function to reactimate. + +reactimate :: IO a + -> (Bool -> IO (DTime, Maybe a)) + -> (Bool -> b -> IO Bool) + -> SF a b + -> IO () +reactimate init sense actuate (SF {sfTF = tf0}) = + do + a0 <- init + let (sf, b0) = tf0 a0 + loop sf a0 b0 + where + loop sf a b = do + done <- actuate True b + unless (a `seq` b `seq` done) $ do + (dt, ma') <- sense False + let a' = maybe a id ma' + (sf', b') = (sfTF' sf) dt a' + loop sf' a' b' + + +-- An API for animating a signal function when some other library +-- needs to own the top-level control flow: + +-- reactimate's state, maintained across samples: +data ReactState a b = ReactState { + rsActuate :: ReactHandle a b -> Bool -> b -> IO Bool, + rsSF :: SF' a b, + rsA :: a, + rsB :: b + } + +type ReactHandle a b = IORef (ReactState a b) + +-- initialize top-level reaction handle +reactInit :: IO a -- init + -> (ReactHandle a b -> Bool -> b -> IO Bool) -- actuate + -> SF a b + -> IO (ReactHandle a b) +reactInit init actuate (SF {sfTF = tf0}) = + do a0 <- init + let (sf,b0) = tf0 a0 + -- TODO: really need to fix this interface, since right now we + -- just ignore termination at time 0: + r <- newIORef (ReactState {rsActuate = actuate, rsSF = sf, + rsA = a0, rsB = b0 }) + done <- actuate r True b0 + return r + +-- process a single input sample: +react :: ReactHandle a b + -> (DTime,Maybe a) + -> IO Bool +react rh (dt,ma') = + do rs@(ReactState {rsActuate = actuate, + rsSF = sf, + rsA = a, + rsB = b }) <- readIORef rh + let a' = maybe a id ma' + (sf',b') = (sfTF' sf) dt a' + writeIORef rh (rs {rsSF = sf',rsA = a',rsB = b'}) + done <- actuate rh True b' + return done + + +------------------------------------------------------------------------------ +-- Embedding +------------------------------------------------------------------------------ + +-- New embed interface. We will probably have to revisit this. To run an +-- embedded signal function while retaining full control (e.g. start and +-- stop at will), one would probably need a continuation based interface +-- (as well as a continuation based underlying implementation). +-- +-- E.g. here are interesting alternative (or maybe complementary) +-- signatures: +-- +-- sample :: SF a b -> SF (Event a) (Event b) +-- sample' :: SF a b -> SF (Event (DTime, a)) (Event b) +-- +-- Maybe it should be called "subSample", since that's the only thing +-- that can be achieved. At least does not have the problem with missing +-- events when supersampling. +-- +-- subSampleSynch :: SF a b -> SF (Event a) (Event b) +-- Time progresses at the same rate in the embedded system. +-- But it is only sampled on the events. +-- E.g. +-- repeatedly 0.1 () >>> subSampleSynch sf >>> hold +-- +-- subSample :: DTime -> SF a b -> SF (Event a) (Event b) +-- Time advanced by dt for each event, not synchronized with the outer clock. + +embed :: SF a b -> (a, [(DTime, Maybe a)]) -> [b] +embed sf0 (a0, dtas) = b0 : loop a0 sf dtas + where + (sf, b0) = (sfTF sf0) a0 + + loop _ _ [] = [] + loop a_prev sf ((dt, ma) : dtas) = + b : (a `seq` b `seq` (loop a sf' dtas)) + where + a = maybe a_prev id ma + (sf', b) = (sfTF' sf) dt a + + +-- Synchronous embedding. The embedded signal function is run on the supplied +-- input and time stream at a given (but variable) ratio >= 0 to the outer +-- time flow. When the ratio is 0, the embedded signal function is paused. +-- +-- What about running an embedded signal function at a fixed (guaranteed) +-- sampling frequency? E.g. super sampling if the outer sampling is slower, +-- subsampling otherwise. AS WELL as at a given ratio to the outer one. +-- +-- Ah, but that's more or less what embedSync does. +-- So just simplify the interface. But maybe it should also be possible +-- to feed in input from the enclosing system. + +-- !!! Should "dropped frames" be forced to avoid space leaks? +-- !!! It's kind of hard to se why, but "frame dropping" was a problem +-- !!! in the old robot simulator. Try to find an example! + +embedSynch :: SF a b -> (a, [(DTime, Maybe a)]) -> SF Double b +embedSynch sf0 (a0, dtas) = SF {sfTF = tf0} + where + tts = scanl (\t (dt, _) -> t + dt) 0 dtas + bbs@(b:_) = embed sf0 (a0, dtas) + + tf0 _ = (esAux 0 (zip tts bbs), b) + + esAux _ [] = intErr "AFRP" "embedSynch" "Empty list!" + -- Invarying below since esAux [] is an error. + esAux tp_prev tbtbs = SF' tf -- True + where + tf dt r | r < 0 = usrErr "AFRP" "embedSynch" + "Negative ratio." + | otherwise = let tp = tp_prev + dt * r + (b, tbtbs') = advance tp tbtbs + in + (esAux tp tbtbs', b) + + -- Advance the time stamped stream to the perceived time tp. + -- Under the assumption that the perceived time never goes + -- backwards (non-negative ratio), advance maintains the + -- invariant that the perceived time is always >= the first + -- time stamp. + advance _ tbtbs@[(_, b)] = (b, tbtbs) + advance tp tbtbtbs@((_, b) : tbtbs@((t', _) : _)) + | tp < t' = (b, tbtbtbs) + | t' <= tp = advance tp tbtbs + advance _ _ = undefined + +deltaEncode :: Eq a => DTime -> [a] -> (a, [(DTime, Maybe a)]) +deltaEncode _ [] = usrErr "AFRP" "deltaEncode" "Empty input list." +deltaEncode dt aas@(_:_) = deltaEncodeBy (==) dt aas + + +deltaEncodeBy :: (a -> a -> Bool) -> DTime -> [a] -> (a, [(DTime, Maybe a)]) +deltaEncodeBy _ _ [] = usrErr "AFRP" "deltaEncodeBy" "Empty input list." +deltaEncodeBy eq dt (a0:as) = (a0, zip (repeat dt) (debAux a0 as)) + where + debAux _ [] = [] + debAux a_prev (a:as) | a `eq` a_prev = Nothing : debAux a as + | otherwise = Just a : debAux a as + +-- Embedding and missing events. +-- Suppose a subsystem is super sampled. Then some of the output +-- samples will have to be dropped. If we are unlycky, the dropped +-- samples could be occurring events that we'd rather not miss. +-- This is a real problem. +-- Similarly, when feeding input into a super-sampled system, +-- we may need to extrapolate the input, assuming that it is +-- constant. But if (part of) the input is an occurring event, we'd +-- rather not duplicate that!!! +-- This suggests that: +-- * output samples should be merged through a user-supplied merge +-- function. +-- * input samples should be extrapolated if necessary through a +-- user-supplied extrapolation function. +-- +-- Possible signature: +-- +-- resample :: Time -> (c -> [a]) -> SF a b -> ([b] -> d) -> SF c d +-- +-- But what do we do if the inner system runs more slowly than the +-- outer one? Then we need to extrapolate the output from the +-- inner system, and we have the same problem with events AGAIN! diff --git a/FRP/Yampa/AffineSpace.hs b/FRP/Yampa/AffineSpace.hs new file mode 100644 --- /dev/null +++ b/FRP/Yampa/AffineSpace.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.AffineSpace +-- 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 : non-portable (GHC extensions) +-- +-- Affine space type relation. +-- +----------------------------------------------------------------------------------------- + +module FRP.Yampa.AffineSpace where + +import FRP.Yampa.VectorSpace + +------------------------------------------------------------------------------ +-- Affine Space type relation +------------------------------------------------------------------------------ + +infix 6 .+^, .-^, .-. + +-- Maybe origin should not be a class method, even though an origin +-- can be assocoated with any affine space. +-- Maybe distance should not be a class method, in which case the constraint +-- on the coefficient space (a) could be Fractional (i.e., a Field), which +-- seems closer to the mathematical definition of affine space, provided +-- the constraint on the coefficient space for VectorSpace is also Fractional. + +-- Minimal instance: origin, .+^, .^. +class (Floating a, VectorSpace v a) => AffineSpace p v a | p -> v, v -> a where + origin :: p + (.+^) :: p -> v -> p + (.-^) :: p -> v -> p + (.-.) :: p -> p -> v + distance :: p -> p -> a + + p .-^ v = p .+^ (negateVector v) + + distance p1 p2 = norm (p1 .-. p2) diff --git a/FRP/Yampa/Diagnostics.hs b/FRP/Yampa/Diagnostics.hs new file mode 100644 --- /dev/null +++ b/FRP/Yampa/Diagnostics.hs @@ -0,0 +1,21 @@ +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.Diagnostics +-- 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 +-- +-- Standardized error-reporting for Yampa +----------------------------------------------------------------------------------------- + +module FRP.Yampa.Diagnostics where + +usrErr :: String -> String -> String -> a +usrErr mn fn msg = error (mn ++ "." ++ fn ++ ": " ++ msg) + +intErr :: String -> String -> String -> a +intErr mn fn msg = error ("[internal error] " ++ mn ++ "." ++ fn ++ ": " + ++ msg) diff --git a/FRP/Yampa/Event.hs b/FRP/Yampa/Event.hs new file mode 100644 --- /dev/null +++ b/FRP/Yampa/Event.hs @@ -0,0 +1,297 @@ +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.Event +-- 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 +-- +-- Definition of Yampa Event type. +-- +-- Note on naming conventions used in this module. +-- +-- Names here might have to be rethought. It's really a bit messy. +-- In general, the aim has been short and convenient names (like 'tag', +-- 'attach', 'lMerge') and thus we have tried to stay away from suffixing/ +-- prefixing conventions. E.g. 'Event' as a common suffix would be very +-- verbose. +-- +-- However, part of the names come from a desire to stay close to similar +-- functions for the Maybe type. e.g. 'event', 'fromEvent', 'isEvent'. +-- In many cases, this use of 'Event' can could understood to refer to the +-- constructor 'Event', not to the type name 'Event'. Thus this use of +-- event should not be seen as a suffixing-with-type-name convention. But +-- that is obviously not easy to see, and, more over, interpreting 'Event' +-- as the name of the type might make equally good or better sense. E.g. +-- 'fromEvent' can also be seen as a function taking an event signal, +-- which is a partial function on time, to a normal signal. The latter is +-- then undefined when the source event function is undefined. +-- +-- In other cases, it has been necessary to somehow stay out of the way of +-- names used by the prelude or other commonly imported modules/modules +-- which could be expected to be used heavily in Yampa code. In those cases +-- a suffix 'E' have been added. Examples are 'filterE' (exists in Prelude) +-- and 'joinE' (exists in Monad). Maybe the suffix isn't necessary in the +-- last case. +-- +-- Some functions (actually only one currently, 'mapFilterE') have got an 'E' +-- suffix just because they're closely related (by name or semantics) to one +-- which already has an 'E' suffix. Another candidate would be 'splitE' to +-- complement 'joinE'. But events carrying pairs could obviously have other +-- sources than a 'joinE', so currently it is called 'split'. +-- +-- 2003-05-19: Actually, have now changed to 'splitE' to avoid a clash +-- with the method 'split' in the class RandomGen. +-- +-- 2003-05-19: What about 'gate'? Stands out compared to e.g. 'filterE'. +-- +-- Currently the 'E' suffix is considered an exception. Maybe we should use +-- completely different names to avoid the 'E' suffix. If the functions +-- are not used that often, 'Event' might be approriate. Alternatively the +-- suffix 'E' should be adopted globaly (except if the name already contains +-- 'event' in some form?). +-- +-- Arguably, having both a type 'Event' and a constructor 'Event' is confusing +-- since there are more than one constructor. But the name 'Event' for the +-- constructor is quite apt. It's really the type name that is wrong. But +-- no one has found a better name, and changing it would be a really major +-- undertaking. Yes, the constructor 'Event' is not exported, but we still +-- need to talk conceptually about them. On the other hand, if we consider +-- Event-signals as partial functions on time, maybe it isn't so confusing: +-- they just don't have a value between events, so 'NoEvent' does not really +-- exist conceptually. +-- +-- ToDo: +-- - Either: reveal NoEvent and Event +-- or: introcuce 'event = Event', call what's now 'event' 'fromEvent', +-- and call what's now called 'fromEvent' something else, like +-- 'unsafeFromEvent'??? Better, dump it! After all, using current +-- names, 'fromEvent = event undefined'! +----------------------------------------------------------------------------------------- + +module FRP.Yampa.Event where + +import FRP.Yampa.Diagnostics +import FRP.Yampa.Forceable + + +infixl 8 `tag`, `attach`, `gate` +infixl 7 `joinE` +infixl 6 `lMerge`, `rMerge`, `merge` + + +------------------------------------------------------------------------------ +-- The Event type +------------------------------------------------------------------------------ + +-- The type Event represents a single possible event occurrence. +-- It is isomorphic to Maybe, but its constructors are not exposed outside +-- the AFRP implementation. +-- There could possibly be further constructors, but note that the NeverEvent- +-- idea does not work, at least not in the current AFRP implementation. +-- Also note that it unfortunately is possible to partially break the +-- abstractions through judicious use of e.g. snap and switching. + +data Event a = NoEvent + | Event a +-- deriving Show + + +-- Make the NoEvent constructor available. Useful e.g. for initialization, +-- ((-->) & friends), and it's easily available anyway (e.g. mergeEvents []). +noEvent :: Event a +noEvent = NoEvent + + +-- Suppress any event in the first component of a pair. +noEventFst :: (Event a, b) -> (Event c, b) +noEventFst (_, b) = (NoEvent, b) + + +-- Suppress any event in the second component of a pair. +noEventSnd :: (a, Event b) -> (a, Event c) +noEventSnd (a, _) = (a, NoEvent) + + +------------------------------------------------------------------------------ +-- Eq instance +------------------------------------------------------------------------------ + +-- Right now, we could derive this instance. But that could possibly change. + +instance Eq a => Eq (Event a) where + NoEvent == NoEvent = True + (Event x) == (Event y) = x == y + _ == _ = False + + +------------------------------------------------------------------------------ +-- Ord instance +------------------------------------------------------------------------------ + +instance Ord a => Ord (Event a) where + compare NoEvent NoEvent = EQ + compare NoEvent (Event _) = LT + compare (Event _) NoEvent = GT + compare (Event x) (Event y) = compare x y + + +------------------------------------------------------------------------------ +-- Functor instance +------------------------------------------------------------------------------ + +instance Functor Event where + fmap _ NoEvent = NoEvent + fmap f (Event a) = Event (f a) + + +------------------------------------------------------------------------------ +-- Forceable instance +------------------------------------------------------------------------------ + +instance Forceable a => Forceable (Event a) where + force ea@NoEvent = ea + force ea@(Event a) = force a `seq` ea + + +------------------------------------------------------------------------------ +-- Internal utilities for event construction +------------------------------------------------------------------------------ + +-- These utilities are to be considered strictly internal to AFRP for the +-- time being. + +maybeToEvent :: Maybe a -> Event a +maybeToEvent Nothing = NoEvent +maybeToEvent (Just a) = Event a + + +------------------------------------------------------------------------------ +-- Utility functions similar to those available for Maybe +------------------------------------------------------------------------------ + +-- An event-based version of the maybe function. +event :: a -> (b -> a) -> Event b -> a +event a _ NoEvent = a +event _ f (Event b) = f b + +fromEvent :: Event a -> a +fromEvent (Event a) = a +fromEvent NoEvent = usrErr "AFRP" "fromEvent" "Not an event." + +isEvent :: Event a -> Bool +isEvent NoEvent = False +isEvent (Event _) = True + +isNoEvent :: Event a -> Bool +isNoEvent = not . isEvent + + +------------------------------------------------------------------------------ +-- Event tagging +------------------------------------------------------------------------------ + +-- Tags an (occurring) event with a value ("replacing" the old value). +tag :: Event a -> b -> Event b +e `tag` b = fmap (const b) e + +tagWith :: b -> Event a -> Event b +tagWith = flip tag + +-- Attaches an extra value to the value of an occurring event. +attach :: Event a -> b -> Event (a, b) +e `attach` b = fmap (\a -> (a, b)) e + + +------------------------------------------------------------------------------ +-- Event merging (disjunction) and joining (conjunction) +------------------------------------------------------------------------------ + +-- !!! I think this is too complicated. rMerge can be obtained simply by +-- !!! swapping the arguments. So the only time it is possibly of any +-- !!! interest is for partial app. "merge" is inherently dangerous. +-- !!! But this is NOT obvious from its type: it's type is just like +-- !!! the others. This is the only example of such a def. +-- !!! Finally: mergeEvents is left-biased, but this is not reflected in +-- !!! its name. + +-- Left-biased event merge. +lMerge :: Event a -> Event a -> Event a +le `lMerge` re = event re Event le + + +-- Right-biased event merge. +rMerge :: Event a -> Event a -> Event a +le `rMerge` re = event le Event re + + +-- Unbiased event merge: simultaneous occurrence is an error. +merge :: Event a -> Event a -> Event a +merge = mergeBy (usrErr "AFRP" "merge" "Simultaneous event occurrence.") + + +-- Event merge paramterezied on the conflict resolution function. +mergeBy :: (a -> a -> a) -> Event a -> Event a -> Event a +mergeBy _ NoEvent NoEvent = NoEvent +mergeBy _ le@(Event _) NoEvent = le +mergeBy _ NoEvent re@(Event _) = re +mergeBy resolve (Event l) (Event r) = Event (resolve l r) + + +-- A generic event merge utility: +mapMerge :: (a -> c) -> (b -> c) -> (a -> b -> c) + -> Event a -> Event b -> Event c +mapMerge _ _ _ NoEvent NoEvent = NoEvent +mapMerge lf _ _ (Event l) NoEvent = Event (lf l) +mapMerge _ rf _ NoEvent (Event r) = Event (rf r) +mapMerge _ _ lrf (Event l) (Event r) = Event (lrf l r) + +-- Merging of a list of events; foremost event has priority. +mergeEvents :: [Event a] -> Event a +mergeEvents = foldr lMerge NoEvent + + +-- Collects simultaneous event occurrences; no event if none. +catEvents :: [Event a] -> Event [a] +catEvents eas = case [ a | Event a <- eas ] of + [] -> NoEvent + as -> Event as + + +-- Join (conjucntion) of two events. +joinE :: Event a -> Event b -> Event (a,b) +joinE NoEvent _ = NoEvent +joinE _ NoEvent = NoEvent +joinE (Event l) (Event r) = Event (l,r) + + +-- Split event carrying pairs into two events. +splitE :: Event (a,b) -> (Event a, Event b) +splitE NoEvent = (NoEvent, NoEvent) +splitE (Event (a,b)) = (Event a, Event b) + + +------------------------------------------------------------------------------ +-- Event filtering +------------------------------------------------------------------------------ + +-- Filter out events that don't satisfy some predicate. +filterE :: (a -> Bool) -> Event a -> Event a +filterE p e@(Event a) = if (p a) then e else NoEvent +filterE _ NoEvent = NoEvent + + +-- Combined event mapping and filtering. +mapFilterE :: (a -> Maybe b) -> Event a -> Event b +mapFilterE _ NoEvent = NoEvent +mapFilterE f (Event a) = case f a of + Nothing -> NoEvent + Just b -> Event b + + +-- Enable/disable event occurences based on an external condition. +gate :: Event a -> Bool -> Event a +_ `gate` False = NoEvent +e `gate` True = e diff --git a/FRP/Yampa/Forceable.hs b/FRP/Yampa/Forceable.hs new file mode 100644 --- /dev/null +++ b/FRP/Yampa/Forceable.hs @@ -0,0 +1,76 @@ +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.Forceable +-- Copyright : (c) Zhanyong Wan, Yale University, 2003 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : nilsson@cs.yale.edu +-- Stability : provisional +-- Portability : portable +-- +-- Hyperstrict evaluation. +----------------------------------------------------------------------------------------- + +module FRP.Yampa.Forceable where + + +class Forceable a where + force :: a -> a + + +instance Forceable Int where + force = id + + +instance Forceable Integer where + force = id + + +instance Forceable Double where + force = id + + +instance Forceable Float where + force = id + + +instance Forceable Bool where + force = id + + +instance Forceable () where + force = id + + +instance Forceable Char where + force = id + + +instance (Forceable a, Forceable b) => Forceable (a, b) where + force p@(a, b) = force a `seq` force b `seq` p + + +instance (Forceable a, Forceable b, Forceable c) => Forceable (a, b, c) where + force p@(a, b, c) = force a `seq` force b `seq` force c `seq` p + + +instance (Forceable a, Forceable b, Forceable c, Forceable d) => + Forceable (a, b, c, d) where + force p@(a, b, c, d) = + force a `seq` force b `seq` force c `seq` force d `seq` p + + +instance (Forceable a, Forceable b, Forceable c, Forceable d, Forceable e) => + Forceable (a, b, c, d, e) where + force p@(a, b, c, d, e) = + force a `seq` force b `seq` force c `seq` force d `seq` force e `seq` p + + +instance (Forceable a) => Forceable [a] where + force nil@[] = nil + force xs@(x:xs') = force x `seq` force xs' `seq` xs + + +instance (Forceable a) => Forceable (Maybe a) where + force mx@Nothing = mx + force mx@(Just x) = force x `seq` mx diff --git a/FRP/Yampa/Geometry.hs b/FRP/Yampa/Geometry.hs new file mode 100644 --- /dev/null +++ b/FRP/Yampa/Geometry.hs @@ -0,0 +1,30 @@ +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.Geometry +-- 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 : non-portable (GHC extensions) +-- +-- Basic geometrical abstractions. +----------------------------------------------------------------------------------------- + +module FRP.Yampa.Geometry ( + module FRP.Yampa.VectorSpace, + module FRP.Yampa.AffineSpace, + module FRP.Yampa.Vector2, + module FRP.Yampa.Vector3, + module FRP.Yampa.Point2, + module FRP.Yampa.Point3 +) where + +import FRP.Yampa.VectorSpace +import FRP.Yampa.AffineSpace +import FRP.Yampa.Vector2 +import FRP.Yampa.Vector3 +import FRP.Yampa.Point2 +import FRP.Yampa.Point3 + + diff --git a/FRP/Yampa/Internals.hs b/FRP/Yampa/Internals.hs new file mode 100644 --- /dev/null +++ b/FRP/Yampa/Internals.hs @@ -0,0 +1,37 @@ +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.Internals +-- 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 +-- +-- An interface giving access to some of the internal +-- details of the Yampa implementation. +-- +-- This interface is indended to be used when the need arises to break +-- abstraction barriers, e.g. for interfacing Yampa to the real world, for +-- debugging purposes, or the like. Be aware that the internal details +-- may change. Relying on this interface means that your code is not +-- insulated against such changes. +----------------------------------------------------------------------------------------- + +module FRP.Yampa.Internals ( + Event(..) -- The event type, its constructors, and instances. +) where + +import FRP.Yampa.Event + + +------------------------------------------------------------------------------ +-- Extra Event instances +------------------------------------------------------------------------------ + +instance Show a => Show (Event a) where + showsPrec d NoEvent = showString "NoEvent" + showsPrec d (Event a) = showParen (d >= 10) + (showString "Event " . showsPrec 10 a) + + diff --git a/FRP/Yampa/MergeableRecord.hs b/FRP/Yampa/MergeableRecord.hs new file mode 100644 --- /dev/null +++ b/FRP/Yampa/MergeableRecord.hs @@ -0,0 +1,86 @@ +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.Miscellany +-- 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 +-- +-- Framework for record merging. +-- +-- Idea: +-- +-- MergeableRecord is intended to be a super class for classes providing +-- update operations on records. The ADT induced by such a set of operations +-- can be considered a "mergeable record", which can be merged into larger +-- mergeable records essentially by function composition. Finalization turns +-- a mergeable record into a record. +-- +-- Typical use: +-- +-- Given +-- +-- > data Foo = Foo {l1 :: T1, l2 :: T2} +-- +-- one define a mergeable record type (MR Foo) by the following instance: +-- +-- @ +-- instance MergeableRecord Foo where +-- mrDefault = Foo {l1 = v1_dflt, l2 = v2_dflt} +-- @ +-- +-- Typically, one would also provide definitions for setting the fields, +-- possibly (but not necessarily) overloaded: +-- +-- @ +-- instance HasL1 Foo where +-- setL1 v = mrMake (\foo -> foo {l1 = v}) +-- @ +-- +-- Now Foo records can be created as follows: +-- +-- @ +-- let foo1 = setL1 v1 +-- ... +-- let foo2 = setL2 v2 ~+~ foo1 +-- ... +-- let foo = setL1 vN ~+~ foo +-- let fooFinal = mrFinalize foo +-- @ +----------------------------------------------------------------------------------------- + +module FRP.Yampa.MergeableRecord ( + MergeableRecord(..), + MR, -- Abstract + mrMake, + (~+~), + mrMerge, + mrFinalize +) where + +class MergeableRecord a where + mrDefault :: a + + +-- Type constructor for mergeable records. +newtype MergeableRecord a => MR a = MR (a -> a) + + +-- Construction of a mergeable record. +mrMake :: MergeableRecord a => (a -> a) -> MR a +mrMake f = (MR f) + + +-- Merge two mergeable records. Left "overrides" in case of conflict. +(~+~) :: MergeableRecord a => MR a -> MR a -> MR a +(MR f1) ~+~ (MR f2) = MR (f1 . f2) + +mrMerge :: MergeableRecord a => MR a -> MR a -> MR a +mrMerge = (~+~) + + +-- Finalization: turn a mergeable record into a record. +mrFinalize :: MergeableRecord a => MR a -> a +mrFinalize (MR f) = f mrDefault diff --git a/FRP/Yampa/Miscellany.hs b/FRP/Yampa/Miscellany.hs new file mode 100644 --- /dev/null +++ b/FRP/Yampa/Miscellany.hs @@ -0,0 +1,140 @@ +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.Miscellany +-- 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 +-- +-- Collection of entities that really should be part +-- of the Haskell 98 prelude or simply have no better +-- home. +-- +-- !!! Reverse function composition should go. +-- !!! Better to use '<<<' and '>>>' for, respectively, +-- !!! function composition and reverse function composition. +-- +----------------------------------------------------------------------------------------- + +module FRP.Yampa.Miscellany ( +-- Reverse function composition + ( # ), -- :: (a -> b) -> (b -> c) -> (a -> c), infixl 9 + +-- Arrow plumbing aids + dup, -- :: a -> (a,a) + swap, -- :: (a,b) -> (b,a) + +-- Maps over lists of pairs + mapFst, -- :: (a -> b) -> [(a,c)] -> [(b,c)] + mapSnd, -- :: (a -> b) -> [(c,a)] -> [(c,b)] + +-- Generalized tuple selectors + sel3_1, sel3_2, sel3_3, + sel4_1, sel4_2, sel4_3, sel4_4, + sel5_1, sel5_2, sel5_3, sel5_4, sel5_5, + +-- Floating point utilities + fDiv, -- :: (RealFrac a, Integral b) => a -> a -> b + fMod, -- :: RealFrac a => a -> a -> a + fDivMod -- :: (RealFrac a, Integral b) => a -> a -> (b, a) +) where + +infixl 9 # +infixl 7 `fDiv`, `fMod` + + +------------------------------------------------------------------------------ +-- Reverse function composition +------------------------------------------------------------------------------ + +-- !!! Reverse function composition should go. +-- !!! Better to use <<< and >>> for, respectively, +-- !!! function composition and reverse function composition. + +( # ) :: (a -> b) -> (b -> c) -> (a -> c) +f # g = g . f + + +------------------------------------------------------------------------------ +-- Arrow plumbing aids +------------------------------------------------------------------------------ + +dup :: a -> (a,a) +dup x = (x,x) + +swap :: (a,b) -> (b,a) +swap ~(x,y) = (y,x) + + +------------------------------------------------------------------------------ +-- Maps over lists of pairs +------------------------------------------------------------------------------ + +mapFst :: (a -> b) -> [(a,c)] -> [(b,c)] +mapFst _ [] = [] +mapFst f ((x, y) : xys) = (f x, y) : mapFst f xys + +mapSnd :: (a -> b) -> [(c,a)] -> [(c,b)] +mapSnd _ [] = [] +mapSnd f ((x, y) : xys) = (x, f y) : mapSnd f xys + + +------------------------------------------------------------------------------ +-- Generalized tuple selectors +------------------------------------------------------------------------------ + +-- Triples +sel3_1 :: (a, b, c) -> a +sel3_1 (x,_,_) = x +sel3_2 :: (a, b, c) -> b +sel3_2 (_,x,_) = x +sel3_3 :: (a, b, c) -> c +sel3_3 (_,_,x) = x + + +-- 4-tuples +sel4_1 :: (a, b, c, d) -> a +sel4_1 (x,_,_,_) = x +sel4_2 :: (a, b, c, d) -> b +sel4_2 (_,x,_,_) = x +sel4_3 :: (a, b, c, d) -> c +sel4_3 (_,_,x,_) = x +sel4_4 :: (a, b, c, d) -> d +sel4_4 (_,_,_,x) = x + + +-- 5-tuples + +sel5_1 :: (a, b, c, d, e) -> a +sel5_1 (x,_,_,_,_) = x +sel5_2 :: (a, b, c, d, e) -> b +sel5_2 (_,x,_,_,_) = x +sel5_3 :: (a, b, c, d, e) -> c +sel5_3 (_,_,x,_,_) = x +sel5_4 :: (a, b, c, d, e) -> d +sel5_4 (_,_,_,x,_) = x +sel5_5 :: (a, b, c, d, e) -> e +sel5_5 (_,_,_,_,x) = x + + +------------------------------------------------------------------------------ +-- Floating point utilities +------------------------------------------------------------------------------ + +-- Floating-point div and modulo operators. + +fDiv :: (RealFrac a) => a -> a -> Integer +fDiv x y = fst (fDivMod x y) + + +fMod :: (RealFrac a) => a -> a -> a +fMod x y = snd (fDivMod x y) + + +fDivMod :: (RealFrac a) => a -> a -> (Integer, a) +fDivMod x y = (q, r) + where + q = (floor (x/y)) + r = x - fromIntegral q * y diff --git a/FRP/Yampa/Point2.hs b/FRP/Yampa/Point2.hs new file mode 100644 --- /dev/null +++ b/FRP/Yampa/Point2.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.Point2 +-- 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 : non-portable (GHC extensions) +-- +-- 2D point abstraction (R^2). +-- +-- ToDo: Deriving Show, or provide dedicated show instance? +-- +----------------------------------------------------------------------------------------- + +module FRP.Yampa.Point2 ( + -- module AFRPVectorSpace, + -- module AFRPAffineSpace, + -- module AFRPVector2, + Point2(..), -- Non-abstract, instance of AffineSpace + point2X, -- :: RealFloat a => Point2 a -> a + point2Y -- :: RealFloat a => Point2 a -> a +) where + +import FRP.Yampa.VectorSpace () +import FRP.Yampa.AffineSpace +import FRP.Yampa.Vector2 +import FRP.Yampa.Forceable + +------------------------------------------------------------------------------ +-- 2D point, constructors and selectors. +------------------------------------------------------------------------------ + +data RealFloat a => Point2 a = Point2 !a !a deriving (Eq, Show) + +point2X :: RealFloat a => Point2 a -> a +point2X (Point2 x _) = x + +point2Y :: RealFloat a => Point2 a -> a +point2Y (Point2 _ y) = y + + +------------------------------------------------------------------------------ +-- Affine space instance +------------------------------------------------------------------------------ + +instance RealFloat a => AffineSpace (Point2 a) (Vector2 a) a where + origin = Point2 0 0 + + (Point2 x y) .+^ v = Point2 (x + vector2X v) (y + vector2Y v) + + (Point2 x y) .-^ v = Point2 (x - vector2X v) (y - vector2Y v) + + (Point2 x1 y1) .-. (Point2 x2 y2) = vector2 (x1 - x2) (y1 - y2) + + +------------------------------------------------------------------------------ +-- Forceable instance +------------------------------------------------------------------------------ + +instance RealFloat a => Forceable (Point2 a) where + force = id diff --git a/FRP/Yampa/Point3.hs b/FRP/Yampa/Point3.hs new file mode 100644 --- /dev/null +++ b/FRP/Yampa/Point3.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.Point3 +-- 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 : non-portable (GHC extensions) +-- +-- 3D point abstraction (R^3). +-- +----------------------------------------------------------------------------------------- + +module FRP.Yampa.Point3 ( + -- module AFRPVectorSpace, + -- module AFRPAffineSpace, + -- module AFRPVector3, + Point3(..), -- Non-abstract, instance of AffineSpace + point3X, -- :: RealFloat a => Point3 a -> a + point3Y, -- :: RealFloat a => Point3 a -> a + point3Z -- :: RealFloat a => Point3 a -> a +) where + +import FRP.Yampa.VectorSpace () +import FRP.Yampa.AffineSpace +import FRP.Yampa.Vector3 +import FRP.Yampa.Forceable + +------------------------------------------------------------------------------ +-- 3D point, constructors and selectors. +------------------------------------------------------------------------------ + +data RealFloat a => Point3 a = Point3 !a !a !a deriving Eq + +point3X :: RealFloat a => Point3 a -> a +point3X (Point3 x _ _) = x + +point3Y :: RealFloat a => Point3 a -> a +point3Y (Point3 _ y _) = y + +point3Z :: RealFloat a => Point3 a -> a +point3Z (Point3 _ _ z) = z + + +------------------------------------------------------------------------------ +-- Affine space instance +------------------------------------------------------------------------------ + +instance RealFloat a => AffineSpace (Point3 a) (Vector3 a) a where + origin = Point3 0 0 0 + + (Point3 x y z) .+^ v = + Point3 (x + vector3X v) (y + vector3Y v) (z + vector3Z v) + + (Point3 x y z) .-^ v = + Point3 (x - vector3X v) (y - vector3Y v) (z - vector3Z v) + + (Point3 x1 y1 z1) .-. (Point3 x2 y2 z2) = + vector3 (x1 - x2) (y1 - y2) (z1 - z2) + + +------------------------------------------------------------------------------ +-- Forceable instance +------------------------------------------------------------------------------ + +instance RealFloat a => Forceable (Point3 a) where + force = id diff --git a/FRP/Yampa/Task.hs b/FRP/Yampa/Task.hs new file mode 100644 --- /dev/null +++ b/FRP/Yampa/Task.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE Rank2Types #-} +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.Task +-- 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 : non-portable (GHC extensions) +-- +-- Task abstraction on top of signal transformers. +-- +----------------------------------------------------------------------------------------- + +module FRP.Yampa.Task ( + Task, + mkTask, -- :: SF a (b, Event c) -> Task a b c + runTask, -- :: Task a b c -> SF a (Either b c) -- Might change. + runTask_, -- :: Task a b c -> SF a b + taskToSF, -- :: Task a b c -> SF a (b, Event c) -- Might change. + constT, -- :: b -> Task a b c + sleepT, -- :: Time -> b -> Task a b () + snapT, -- :: Task a b a + timeOut, -- :: Task a b c -> Time -> Task a b (Maybe c) + abortWhen, -- :: Task a b c -> SF a (Event d) -> Task a b (Either c d) + repeatUntil,-- :: Monad m => m a -> (a -> Bool) -> m a + for, -- :: Monad m => a -> (a -> a) -> (a -> Bool) -> m b -> m () + forAll, -- :: Monad m => [a] -> (a -> m b) -> m () + forEver -- :: Monad m => m a -> m b +) where + +import FRP.Yampa +import FRP.Yampa.Utilities (snap) +import FRP.Yampa.Diagnostics + +infixl 0 `timeOut`, `abortWhen`, `repeatUntil` + + +------------------------------------------------------------------------------ +-- The Task type +------------------------------------------------------------------------------ + +-- CPS-based representation allowing a termination to be detected. +-- (Note the rank 2 polymorphic type!) +-- The representation can be changed if necessary, but the Monad laws +-- follow trivially in this case. +newtype Task a b c = + Task (forall d . (c -> SF a (Either b d)) -> SF a (Either b d)) + + +unTask :: Task a b c -> ((c -> SF a (Either b d)) -> SF a (Either b d)) +unTask (Task f) = f + + +mkTask :: SF a (b, Event c) -> Task a b c +mkTask st = Task (switch (st >>> first (arr Left))) + + +-- "Runs" a task (unusually bad name?). The output from the resulting +-- signal transformer is tagged with Left while the underlying task is +-- running. Once the task has terminated, the output goes constant with +-- the value Right x, where x is the value of the terminating event. +runTask :: Task a b c -> SF a (Either b c) +runTask tk = (unTask tk) (\c -> constant (Right c)) + + +-- Runs a task. The output becomes undefined once the underlying task has +-- terminated. Convenient e.g. for tasks which are known not to terminate. +runTask_ :: Task a b c -> SF a b +runTask_ tk = runTask tk + >>> arr (either id (usrErr "AFRPTask" "runTask_" + "Task terminated!")) + + +-- Seems as if the following is convenient after all. Suitable name??? +-- Maybe that implies a representation change for Tasks? +-- Law: mkTask (taskToSF task) = task (but not (quite) vice versa.) +taskToSF :: Task a b c -> SF a (b, Event c) +taskToSF tk = runTask tk + >>> (arr (either id ((usrErr "AFRPTask" "runTask_" + "Task terminated!"))) + &&& edgeBy isEdge (Left undefined)) + where + isEdge (Left _) (Left _) = Nothing + isEdge (Left _) (Right c) = Just c + isEdge (Right _) (Right _) = Nothing + isEdge (Right _) (Left _) = Nothing + + +------------------------------------------------------------------------------ +-- Monad instance +------------------------------------------------------------------------------ + +instance Monad (Task a b) where + tk >>= f = Task (\k -> (unTask tk) (\c -> unTask (f c) k)) + return x = Task (\k -> k x) + +{- +Let's check the monad laws: + + t >>= return + = \k -> t (\c -> return c k) + = \k -> t (\c -> (\x -> \k -> k x) c k) + = \k -> t (\c -> (\x -> \k' -> k' x) c k) + = \k -> t (\c -> k c) + = \k -> t k + = t + QED + + return x >>= f + = \k -> (return x) (\c -> f c k) + = \k -> (\k -> k x) (\c -> f c k) + = \k -> (\k' -> k' x) (\c -> f c k) + = \k -> (\c -> f c k) x + = \k -> f x k + = f x + QED + + (t >>= f) >>= g + = \k -> (t >>= f) (\c -> g c k) + = \k -> (\k' -> t (\c' -> f c' k')) (\c -> g c k) + = \k -> t (\c' -> f c' (\c -> g c k)) + = \k -> t (\c' -> (\x -> \k' -> f x (\c -> g c k')) c' k) + = \k -> t (\c' -> (\x -> f x >>= g) c' k) + = t >>= (\x -> f x >>= g) + QED + +No surprises (obviously, since this is essentially just the CPS monad). +-} + + +------------------------------------------------------------------------------ +-- Basic tasks +------------------------------------------------------------------------------ + +-- Non-terminating task with constant output b. +constT :: b -> Task a b c +constT b = mkTask (constant b &&& never) + + +-- "Sleeps" for t seconds with constant output b. +sleepT :: Time -> b -> Task a b () +sleepT t b = mkTask (constant b &&& after t ()) + + +-- Takes a "snapshot" of the input and terminates immediately with the input +-- value as the result. No time passes; law: +-- +-- snapT >> snapT = snapT +-- +snapT :: Task a b a +snapT = mkTask (constant (intErr "AFRPTask" "snapT" "Bad switch?") &&& snap) + + +------------------------------------------------------------------------------ +-- Basic tasks combinators +------------------------------------------------------------------------------ + +-- Impose a time out on a task. +timeOut :: Task a b c -> Time -> Task a b (Maybe c) +tk `timeOut` t = mkTask ((taskToSF tk &&& after t ()) >>> arr aux) + where + aux ((b, ec), et) = (b, (lMerge (fmap Just ec) + (fmap (const Nothing) et))) + + +-- Run a "guarding" event source (SF a (Event b)) in parallel with a +-- (possibly non-terminating) task. The task will be aborted at the +-- first occurrence of the event source (if it has not terminated itself +-- before that). Useful for separating sequencing and termination concerns. +-- E.g. we can do something "useful", but in parallel watch for a (exceptional) +-- condition which should terminate that activity, whithout having to check +-- for that condition explicitly during each and every phase of the activity. +-- Example: tsk `abortWhen` lbp +abortWhen :: Task a b c -> SF a (Event d) -> Task a b (Either c d) +tk `abortWhen` est = mkTask ((taskToSF tk &&& est) >>> arr aux) + where + aux ((b, ec), ed) = (b, (lMerge (fmap Left ec) (fmap Right ed))) + + +------------------------------------------------------------------------------ +-- Loops +------------------------------------------------------------------------------ + +-- These are general monadic combinators. Maybe they don't really belong here. + +-- Repeat m until result satisfies the predicate p +repeatUntil :: Monad m => m a -> (a -> Bool) -> m a +m `repeatUntil` p = m >>= \x -> if not (p x) then repeatUntil m p else return x + + +-- C-style for-loop. +-- Example: for 0 (+1) (>=10) ... +for :: Monad m => a -> (a -> a) -> (a -> Bool) -> m b -> m () +for i f p m = if p i then m >> for (f i) f p m else return () + + +-- Perform the monadic operation for each element in the list. +forAll :: Monad m => [a] -> (a -> m b) -> m () +forAll = flip mapM_ + + +-- Repeat m for ever. +forEver :: Monad m => m a -> m b +forEver m = m >> forEver m + + +-- Alternatives/other potentially useful signatures: +-- until :: a -> (a -> M a) -> (a -> Bool) -> M a +-- for: a -> b -> (a -> b -> a) -> (a -> b -> Bool) -> (a -> b -> M b) -> M b +-- while??? It could be: +-- while :: a -> (a -> Bool) -> (a -> M a) -> M a + + +------------------------------------------------------------------------------ +-- Monad transformers? +------------------------------------------------------------------------------ + +-- What about monad transformers if we want to compose this monad with +-- other capabilities??? diff --git a/FRP/Yampa/Utilities.hs b/FRP/Yampa/Utilities.hs new file mode 100644 --- /dev/null +++ b/FRP/Yampa/Utilities.hs @@ -0,0 +1,352 @@ +----------------------------------------------------------------------------------------- +-- | +-- 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 (^+^) diff --git a/FRP/Yampa/Vector2.hs b/FRP/Yampa/Vector2.hs new file mode 100644 --- /dev/null +++ b/FRP/Yampa/Vector2.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.Vector2 +-- 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 : non-portable (GHC extensions) +-- +-- 2D vector abstraction (R^2). +-- +-- ToDo: Deriving Show, or provide dedicated show instance? +----------------------------------------------------------------------------------------- + +module FRP.Yampa.Vector2 ( + -- module AFRPVectorSpace, + Vector2, -- Abstract, instance of VectorSpace + vector2, -- :: RealFloat a => a -> a -> Vector2 a + vector2X, -- :: RealFloat a => Vector2 a -> a + vector2Y, -- :: RealFloat a => Vector2 a -> a + vector2XY, -- :: RealFloat a => Vector2 a -> (a, a) + vector2Polar, -- :: RealFloat a => a -> a -> Vector2 a + vector2Rho, -- :: RealFloat a => Vector2 a -> a + vector2Theta, -- :: RealFloat a => Vector2 a -> a + vector2RhoTheta, -- :: RealFloat a => Vector2 a -> (a, a) + vector2Rotate -- :: RealFloat a => a -> Vector2 a -> Vector2 a +) where + +import FRP.Yampa.VectorSpace +import FRP.Yampa.Forceable + + +------------------------------------------------------------------------------ +-- 2D vector, constructors and selectors. +------------------------------------------------------------------------------ + +-- Restrict coefficient space to RealFloat (rather than Floating) for now. +-- While unclear if a complex coefficient space would be useful (and if the +-- result really would be a 2d vector), the only thing causing trouble is the +-- use of atan2 in vector2Theta. Maybe atan2 can be generalized? + +data RealFloat a => Vector2 a = Vector2 !a !a deriving (Eq,Show) + +vector2 :: RealFloat a => a -> a -> Vector2 a +vector2 x y = Vector2 x y + +vector2X :: RealFloat a => Vector2 a -> a +vector2X (Vector2 x _) = x + +vector2Y :: RealFloat a => Vector2 a -> a +vector2Y (Vector2 _ y) = y + +vector2XY :: RealFloat a => Vector2 a -> (a, a) +vector2XY (Vector2 x y) = (x, y) + +vector2Polar :: RealFloat a => a -> a -> Vector2 a +vector2Polar rho theta = Vector2 (rho * cos theta) (rho * sin theta) + +vector2Rho :: RealFloat a => Vector2 a -> a +vector2Rho (Vector2 x y) = sqrt (x * x + y * y) + +vector2Theta :: RealFloat a => Vector2 a -> a +vector2Theta (Vector2 x y) = atan2 y x + +vector2RhoTheta :: RealFloat a => Vector2 a -> (a, a) +vector2RhoTheta v = (vector2Rho v, vector2Theta v) + +------------------------------------------------------------------------------ +-- Vector space instance +------------------------------------------------------------------------------ + +instance RealFloat a => VectorSpace (Vector2 a) a where + zeroVector = Vector2 0 0 + + a *^ (Vector2 x y) = Vector2 (a * x) (a * y) + + (Vector2 x y) ^/ a = Vector2 (x / a) (y / a) + + negateVector (Vector2 x y) = (Vector2 (-x) (-y)) + + (Vector2 x1 y1) ^+^ (Vector2 x2 y2) = Vector2 (x1 + x2) (y1 + y2) + + (Vector2 x1 y1) ^-^ (Vector2 x2 y2) = Vector2 (x1 - x2) (y1 - y2) + + (Vector2 x1 y1) `dot` (Vector2 x2 y2) = x1 * x2 + y1 * y2 + + +------------------------------------------------------------------------------ +-- Additional operations +------------------------------------------------------------------------------ + +vector2Rotate :: RealFloat a => a -> Vector2 a -> Vector2 a +vector2Rotate theta' v = vector2Polar (vector2Rho v) (vector2Theta v + theta') + + +------------------------------------------------------------------------------ +-- Forceable instance +------------------------------------------------------------------------------ + +instance RealFloat a => Forceable (Vector2 a) where + force = id diff --git a/FRP/Yampa/Vector3.hs b/FRP/Yampa/Vector3.hs new file mode 100644 --- /dev/null +++ b/FRP/Yampa/Vector3.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.Vector3 +-- 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 : non-portable (GHC extensions) +-- +-- 3D vector abstraction (R^3). +-- +-- ToDo: Deriving Show, or provide dedicated show instance? +----------------------------------------------------------------------------------------- + +module FRP.Yampa.Vector3 ( + -- module AFRPVectorSpace, + Vector3, -- Abstract, instance of VectorSpace + vector3, -- :: RealFloat a => a -> a -> a -> Vector3 a + vector3X, -- :: RealFloat a => Vector3 a -> a + vector3Y, -- :: RealFloat a => Vector3 a -> a + vector3Z, -- :: RealFloat a => Vector3 a -> a + vector3XYZ, -- :: RealFloat a => Vector3 a -> (a, a, a) + vector3Spherical, -- :: RealFloat a => a -> a -> a -> Vector3 a + vector3Rho, -- :: RealFloat a => Vector3 a -> a + vector3Theta, -- :: RealFloat a => Vector3 a -> a + vector3Phi, -- :: RealFloat a => Vector3 a -> a + vector3RhoThetaPhi, -- :: RealFloat a => Vector3 a -> (a, a, a) + vector3Rotate -- :: RealFloat a => a -> a -> Vector3 a -> Vector3 a +) where + +import FRP.Yampa.VectorSpace +import FRP.Yampa.Forceable + +------------------------------------------------------------------------------ +-- 3D vector, constructors and selectors. +------------------------------------------------------------------------------ + +-- Restrict coefficient space to RealFloat (rather than Floating) for now. +-- While unclear if a complex coefficient space would be useful (and if the +-- result really would be a 3d vector), the only thing causing trouble is the +-- use of atan2 in vector3Theta and vector3Phi. Maybe atan2 can be generalized? + +data RealFloat a => Vector3 a = Vector3 !a !a !a deriving (Eq, Show) + +vector3 :: RealFloat a => a -> a -> a -> Vector3 a +vector3 x y z = Vector3 x y z + +vector3X :: RealFloat a => Vector3 a -> a +vector3X (Vector3 x _ _) = x + +vector3Y :: RealFloat a => Vector3 a -> a +vector3Y (Vector3 _ y _) = y + +vector3Z :: RealFloat a => Vector3 a -> a +vector3Z (Vector3 _ _ z) = z + +vector3XYZ :: RealFloat a => Vector3 a -> (a, a, a) +vector3XYZ (Vector3 x y z) = (x, y, z) + +vector3Spherical :: RealFloat a => a -> a -> a -> Vector3 a +vector3Spherical rho theta phi = + Vector3 (rhoSinPhi * cos theta) (rhoSinPhi * sin theta) (rho * cos phi) + where + rhoSinPhi = rho * sin phi + +vector3Rho :: RealFloat a => Vector3 a -> a +vector3Rho (Vector3 x y z) = sqrt (x * x + y * y + z * z) + +vector3Theta :: RealFloat a => Vector3 a -> a +vector3Theta (Vector3 x y _) = atan2 y x + +vector3Phi :: RealFloat a => Vector3 a -> a +vector3Phi v@(Vector3 _ _ z) = acos (z / vector3Rho v) + +vector3RhoThetaPhi :: RealFloat a => Vector3 a -> (a, a, a) +vector3RhoThetaPhi (Vector3 x y z) = (rho, theta, phi) + where + rho = sqrt (x * x + y * y + z * z) + theta = atan2 y x + phi = acos (z / rho) + + +------------------------------------------------------------------------------ +-- Vector space instance +------------------------------------------------------------------------------ + +instance RealFloat a => VectorSpace (Vector3 a) a where + zeroVector = Vector3 0 0 0 + + a *^ (Vector3 x y z) = Vector3 (a * x) (a * y) (a * z) + + (Vector3 x y z) ^/ a = Vector3 (x / a) (y / a) (z / a) + + negateVector (Vector3 x y z) = (Vector3 (-x) (-y) (-z)) + + (Vector3 x1 y1 z1) ^+^ (Vector3 x2 y2 z2) = Vector3 (x1+x2) (y1+y2) (z1+z2) + + (Vector3 x1 y1 z1) ^-^ (Vector3 x2 y2 z2) = Vector3 (x1-x2) (y1-y2) (z1-z2) + + (Vector3 x1 y1 z1) `dot` (Vector3 x2 y2 z2) = x1 * x2 + y1 * y2 + z1 * z2 + + +------------------------------------------------------------------------------ +-- Additional operations +------------------------------------------------------------------------------ + +vector3Rotate :: RealFloat a => a -> a -> Vector3 a -> Vector3 a +vector3Rotate theta' phi' v = + vector3Spherical (vector3Rho v) + (vector3Theta v + theta') + (vector3Phi v + phi') + + +------------------------------------------------------------------------------ +-- Forceable instance +------------------------------------------------------------------------------ + +instance RealFloat a => Forceable (Vector3 a) where + force = id diff --git a/FRP/Yampa/VectorSpace.hs b/FRP/Yampa/VectorSpace.hs new file mode 100644 --- /dev/null +++ b/FRP/Yampa/VectorSpace.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.VectorSpace +-- 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 : non-portable (GHC extensions) +-- +-- Vector space type relation and basic instances. +-- +----------------------------------------------------------------------------------------- + +module FRP.Yampa.VectorSpace where + +------------------------------------------------------------------------------ +-- Vector space type relation +------------------------------------------------------------------------------ + +infixr *^ +infixl ^/ +infix 7 `dot` +infixl 6 ^+^, ^-^ + +-- Maybe norm and normalize should not be class methods, in which case +-- the constraint on the coefficient space (a) should (or, at least, could) +-- be Fractional (roughly a Field) rather than Floating. + +-- Minimal instance: zeroVector, (*^), (^+^), dot +class Floating a => VectorSpace v a | v -> a where + zeroVector :: v + (*^) :: a -> v -> v + (^/) :: v -> a -> v + negateVector :: v -> v + (^+^) :: v -> v -> v + (^-^) :: v -> v -> v + dot :: v -> v -> a + norm :: v -> a + normalize :: v -> v + + v ^/ a = (1/a) *^ v + + negateVector v = (-1) *^ v + + v1 ^-^ v2 = v1 ^+^ negateVector v2 + + norm v = sqrt (v `dot` v) + + normalize v = if nv /= 0 then v ^/ nv else error "normalize: zero vector" + where + nv = norm v + +------------------------------------------------------------------------------ +-- Vector space instances for Float and Double +------------------------------------------------------------------------------ + +instance VectorSpace Float Float where + zeroVector = 0 + + a *^ x = a * x + + x ^/ a = x / a + + negateVector x = (-x) + + x1 ^+^ x2 = x1 + x2 + + x1 ^-^ x2 = x1 - x2 + + x1 `dot` x2 = x1 * x2 + + +instance VectorSpace Double Double where + zeroVector = 0 + + a *^ x = a * x + + x ^/ a = x / a + + negateVector x = (-x) + + x1 ^+^ x2 = x1 + x2 + + x1 ^-^ x2 = x1 - x2 + + x1 `dot` x2 = x1 * x2 + + +------------------------------------------------------------------------------ +-- Vector space instances for small tuples of Floating +------------------------------------------------------------------------------ + +instance Floating a => VectorSpace (a,a) a where + zeroVector = (0,0) + + a *^ (x,y) = (a * x, a * y) + + (x,y) ^/ a = (x / a, y / a) + + negateVector (x,y) = (-x, -y) + + (x1,y1) ^+^ (x2,y2) = (x1 + x2, y1 + y2) + + (x1,y1) ^-^ (x2,y2) = (x1 - x2, y1 - y2) + + (x1,y1) `dot` (x2,y2) = x1 * x2 + y1 * y2 + + +instance Floating a => VectorSpace (a,a,a) a where + zeroVector = (0,0,0) + + a *^ (x,y,z) = (a * x, a * y, a * z) + + (x,y,z) ^/ a = (x / a, y / a, z / a) + + negateVector (x,y,z) = (-x, -y, -z) + + (x1,y1,z1) ^+^ (x2,y2,z2) = (x1+x2, y1+y2, z1+z2) + + (x1,y1,z1) ^-^ (x2,y2,z2) = (x1-x2, y1-y2, z1-z2) + + (x1,y1,z1) `dot` (x2,y2,z2) = x1 * x2 + y1 * y2 + z1 * z2 + + +instance Floating a => VectorSpace (a,a,a,a) a where + zeroVector = (0,0,0,0) + + a *^ (x,y,z,u) = (a * x, a * y, a * z, a * u) + + (x,y,z,u) ^/ a = (x / a, y / a, z / a, u / a) + + negateVector (x,y,z,u) = (-x, -y, -z, -u) + + (x1,y1,z1,u1) ^+^ (x2,y2,z2,u2) = (x1+x2, y1+y2, z1+z2, u1+u2) + + (x1,y1,z1,u1) ^-^ (x2,y2,z2,u2) = (x1-x2, y1-y2, z1-z2, u1-u2) + + (x1,y1,z1,u1) `dot` (x2,y2,z2,u2) = x1 * x2 + y1 * y2 + z1 * z2 + u1 * u2 + + +instance Floating a => VectorSpace (a,a,a,a,a) a where + zeroVector = (0,0,0,0,0) + + a *^ (x,y,z,u,v) = (a * x, a * y, a * z, a * u, a * v) + + (x,y,z,u,v) ^/ a = (x / a, y / a, z / a, u / a, v / a) + + negateVector (x,y,z,u,v) = (-x, -y, -z, -u, -v) + + (x1,y1,z1,u1,v1) ^+^ (x2,y2,z2,u2,v2) = (x1+x2, y1+y2, z1+z2, u1+u2, v1+v2) + + (x1,y1,z1,u1,v1) ^-^ (x2,y2,z2,u2,v2) = (x1-x2, y1-y2, z1-z2, u1-u2, v1-v2) + + (x1,y1,z1,u1,v1) `dot` (x2,y2,z2,u2,v2) = + x1 * x2 + y1 * y2 + z1 * z2 + u1 * u2 + v1 * v2 + + + diff --git a/Game.hs b/Game.hs --- a/Game.hs +++ b/Game.hs @@ -8,7 +8,7 @@ type R = GLdouble -data Point3D = P3D { x :: Integer, y :: Integer, z :: Integer } +data Point3D = P3D { x :: Integer, y :: Integer, z :: Integer } deriving (Show) p3DtoV3 :: (RealFloat a) => Point3D -> Vector3 a p3DtoV3 (P3D x y z) = vector3 (fromInteger x) (fromInteger y) (fromInteger z) @@ -39,7 +39,9 @@ -- TODO: List can't be empty! testLevel = Level (P3D 0 0 1) (P3D 4 4 5) [P3D 0 0 0, P3D 0 5 1, P3D 5 4 1] testLevel2 = Level (P3D 0 0 1) (P3D 0 4 1) [P3D 5 5 5] -testLevel3 = Level (P3D 0 1 0) (P3D 4 2 1)[P3D 0 1 1, P3D 1 2 0, P3D 1 3 3, P3D 1 1 4, P3D 2 3 0, P3D 3 1 0, P3D 3 4 0, P3D 3 0 2, P3D 3 3 3, P3D 3 1 4, P3D 4 2 0] +testLevel3 = Level (P3D 0 1 0) (P3D 4 2 1) [P3D 0 1 1, P3D 1 2 0, P3D 1 3 3, + P3D 1 1 4, P3D 2 3 0, P3D 3 1 0, P3D 3 4 0, P3D 3 0 2, P3D 3 3 3, P3D 3 1 4, + P3D 4 2 0] levels = concat (repeat [testLevel, testLevel2, testLevel3]) diff --git a/GameLogic.hs b/GameLogic.hs --- a/GameLogic.hs +++ b/GameLogic.hs @@ -13,11 +13,22 @@ -- Logic data WinLose = Win | Lose deriving (Eq) +-- Snapping integral +{-# INLINE integral' #-} +integral' = SF {sfTF = tf0} + where igrl0 = zeroVector + tf0 a0 = (integralAux igrl0 a0, igrl0) + integralAux igrl a_prev = SF' tf -- True + where tf dt a = (integralAux igrl' a, igrl') + where igrl' | a_prev == zeroVector = + vectorApply (fromIntegral . round) igrl + | otherwise = igrl ^+^ realToFrac dt *^ a_prev + calculateState :: SF ParsedInput GameState calculateState = proc pi@(ParsedInput ws as ss ds _ _ _ _) -> do rec speed <- rSwitch selectSpeed -< ((pi, pos, speed, obstacles level), winLose `tag` selectSpeed) - posi <- drSwitch (integral) -< (speed, winLose `tag` integral) + posi <- drSwitch (integral') -< (speed, winLose `tag` integral') pos <- arr calculatePPos -< (posi, level) winLose <- arr testWinLoseCondition -< (pos, level) wins <- arr (filterE (==Win)) >>> delayEvent 1 -< winLose @@ -44,7 +55,7 @@ selectSpeed = proc (pi, pos, speed, obss) -> do let rotX = (fromInteger $ (floor $ (ws pi) - (ss pi)) `mod` 36 + 36) `mod` 36 theta = (((rotX - 6) `div` 9) + 1) `mod` 4 - -- TODO: Get rid of the undefineds? + -- TODO: Get rid of the undefined? speedC <- drSwitch (constant zeroVector) -< (undefined, tagKeys (upEvs pi) speed ((-v) *^ zAxis) theta `merge` tagKeys (downEvs pi) speed (v *^ zAxis) theta `merge` @@ -58,9 +69,10 @@ yAxis = vector3 0 1 0 zAxis = vector3 0 0 1 v = 0.5 + -- TODO: make nicer? too many magical numbers & not 100% reliable collision (obss,pos,speed) = - any (\obs -> norm (pos ^+^ (2 *^ speed) ^-^ (p3DtoV3 obs)) - <= 0.001) obss + any (\obs -> norm (pos ^+^ ((1/v) *^ speed) ^-^ (p3DtoV3 obs)) + <= 0.4) obss -- TODO: Confusing names, can they be generalized? tagKeys event speed vector theta | speed == zeroVector = event `tag` constant diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -33,7 +33,7 @@ newTime' <- get elapsedTime oldTime' <- get oldTime let dt = let dt' = (fromIntegral $ newTime' - oldTime')/50 - in if dt' < 1 then dt' else 1 + in if dt' < 0.8 then dt' else 0.8 react rh (dt, Just newInput') writeIORef oldTime newTime' return () diff --git a/cuboid.cabal b/cuboid.cabal --- a/cuboid.cabal +++ b/cuboid.cabal @@ -14,9 +14,12 @@ In order to add levels check out Game.hs. If you come up with a great level do send it to me. I plan to extract the levels into a configuration file in the future. + . + A slightly modified version of Yampa was included, which exports + the constructors that allow building new complex stateful operators Synopsis: 3D Yampa/GLUT Puzzle Game -Version: 0.12 +Version: 0.13 License: MIT License-file: LICENSE Copyright: (C) 2010 Pedro Martins @@ -25,10 +28,11 @@ Bug-Reports: http://github.com/pedromartins/cuboid/issues Stability: experimental Build-Type: Simple -Cabal-Version: >= 1.4 +Cabal-Version: >= 1.6 +Extra-Source-Files: FRP/*.hs, FRP/Yampa/*.hs Executable cuboid - Main-Is: Main.hs - Other-Modules: Game, GameLogic, Graphics, Input - Build-Depends: base >= 3 && < 5, Yampa, GLUT + Main-Is: Main.hs + Other-Modules: Game, GameLogic, Graphics, Input + Build-Depends: base >= 3 && < 5, random, GLUT