Yampa 0.13.4 → 0.13.5
raw patch · 27 files changed
+1660/−2059 lines, 27 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG +17/−0
- Yampa.cabal +2/−3
- examples/Elevator/Elevator.hs +59/−76
- examples/Elevator/TestElevatorMain.hs +41/−54
- examples/TailgatingDetector/TailgatingDetector.hs +111/−147
- examples/TailgatingDetector/TestTGMain.hs +32/−49
- examples/yampa-game/MainCircleMouse.hs +3/−3
- src/FRP/Yampa.hs +146/−215
- src/FRP/Yampa/Arrow.hs +11/−14
- src/FRP/Yampa/Basic.hs +18/−24
- src/FRP/Yampa/Conditional.hs +32/−32
- src/FRP/Yampa/Delays.hs +41/−49
- src/FRP/Yampa/Diagnostics.hs +1/−1
- src/FRP/Yampa/Event.hs +47/−75
- src/FRP/Yampa/EventS.hs +146/−164
- src/FRP/Yampa/Hybrid.hs +42/−55
- src/FRP/Yampa/Integration.hs +28/−35
- src/FRP/Yampa/InternalCore.hs +448/−508
- src/FRP/Yampa/Loop.hs +7/−8
- src/FRP/Yampa/Random.hs +27/−38
- src/FRP/Yampa/Scan.hs +11/−13
- src/FRP/Yampa/Simulation.hs +92/−127
- src/FRP/Yampa/Switches.hs +237/−293
- src/FRP/Yampa/Task.hs +56/−65
- src/FRP/Yampa/Time.hs +5/−7
- tests/HaddockCoverage.hs +0/−2
- tests/hlint.hs +0/−2
CHANGELOG view
@@ -1,3 +1,20 @@+2022-06-07 Ivan Perez <ivan.perez@haskell.sexy>+ * Yampa.cabal: Version bump (0.13.5) (#220).+ * src/: Remove vim modeline settings (#209), remove unnecessary+ comments from module export lists (#210), style consistency of+ separators (#211), adjust format of export lists (#212), align+ lists, tuples, records by leading comma (#213), compress multiple+ empty lines (#214), adjust indentation to two spaces (#215), make+ arrows less prominent in descriptions (#183), remove unnecessary+ import (#222).+ * examples/: Replace tabs with spaces (#205), format module header to+ conform to style guide (#207), style consistency of separators+ (#211), adjust format of export lists (#212), align lists, tuples,+ records by leading comma (#213), compress multiple empty lines+ (#214), adjust indentation to two spaces (#215).+ * tests/: Style consistency of separators (#211).+ * README: make arrows less prominent in descriptions (#183).+ 2022-04-07 Ivan Perez <ivan.perez@haskell.sexy> * Yampa.cabal: Version bump (0.13.4) (#203), syntax rules (#196), remove regression tests (#201).
Yampa.cabal view
@@ -30,7 +30,7 @@ build-type: Simple name: Yampa-version: 0.13.4+version: 0.13.5 author: Henrik Nilsson, Antony Courtney maintainer: Ivan Perez (ivan.perez@keera.co.uk) homepage: https://github.com/ivanperez-keera/Yampa/@@ -42,8 +42,7 @@ description: Domain-specific language embedded in Haskell for programming hybrid (mixed discrete-time and continuous-time) systems. Yampa is based on the concepts of- Functional Reactive Programming (FRP) and is structured using arrow- combinators.+ Functional Reactive Programming (FRP). extra-source-files: CHANGELOG,
examples/Elevator/Elevator.hs view
@@ -1,36 +1,22 @@ {-# LANGUAGE Arrows #-}--{--******************************************************************************-* A F R P *-* *-* Module: Elevator *-* Purpose: Elevator simulation based on the Fran version *-* from Simon Thompson's paper "A functional reactive *-* animation of a lift using Fran". *-* Authors: Henrik Nilsson *-* *-* Copyright (c) The University of Nottingham, 2004 *-* *-******************************************************************************--}-+-- Module : Elevator+-- Description : Elevator simulation based on the Fran version by Thompson.+-- Copyright : The University of Nottingham, 2004+-- Authors : Henrik Nilsson+--+-- Elevator simulation based on the Fran version from Simon Thompson's paper "A+-- functional reactive animation of a lift using Fran". module Elevator where import FRP.Yampa ---------------------------------------------------------------------------------- Auxiliary definitions---------------------------------------------------------------------------------type Position = Double -- [m]-type Distance = Double -- [m]-type Velocity = Double -- [m/s]+-- * Auxiliary definitions +type Position = Double -- [m]+type Distance = Double -- [m]+type Velocity = Double -- [m/s] ---------------------------------------------------------------------------------- Elevator simulator-------------------------------------------------------------------------------+-- * Elevator simulator lower, upper :: Position lower = 0@@ -40,67 +26,64 @@ upRate = 1 downRate = 1.1 - elevator :: SF (Event (), Event ()) Position elevator = proc (lbp,rbp) -> do- rec- -- This delayed hold can be thought of as modelling acceleration.- -- It is not "physical" to expect a desire to travel at a certain- -- velocity to be immediately reflected in the actual velocity.- -- (The reason we get into trouble here is that the stop/go events- -- depends instantaneously on "stopped" which in turn depends- -- instantaneously on "v".)- v <- dHold 0 -< stop `tag` 0- `lMerge`- goUp `tag` upRate- `lMerge`- goDown `tag` (-downRate)+ rec+ -- This delayed hold can be thought of as modelling acceleration.+ -- It is not "physical" to expect a desire to travel at a certain+ -- velocity to be immediately reflected in the actual velocity.+ -- (The reason we get into trouble here is that the stop/go events+ -- depends instantaneously on "stopped" which in turn depends+ -- instantaneously on "v".)+ v <- dHold 0 -< stop `tag` 0+ `lMerge` goUp `tag` upRate+ `lMerge` goDown `tag` (-downRate) - y <- (lower +) ^<< integral -< v+ y <- (lower +) ^<< integral -< v - let atBottom = y <= lower- atTop = y >= upper- stopped = v == 0 -- Somewhat dubious ...+ let atBottom = y <= lower+ atTop = y >= upper+ stopped = v == 0 -- Somewhat dubious ... - waitingBottom = atBottom && stopped- waitingTop = atTop && stopped+ waitingBottom = atBottom && stopped+ waitingTop = atTop && stopped - arriveBottom <- edge -< atBottom- arriveTop <- edge -< atTop+ arriveBottom <- edge -< atBottom+ arriveTop <- edge -< atTop - let setUp = lbp `tag` True- setDown = rbp `tag` True+ let setUp = lbp `tag` True+ setDown = rbp `tag` True - -- This does not work. The reset events would be generated as soon- -- as the corresponding go event was generated, but the latter- -- depend instantaneusly on the reset signals.--- resetUp = goUp `tag` False--- resetDown = goDown `tag` False+ -- This does not work. The reset events would be generated as soon+ -- as the corresponding go event was generated, but the latter+ -- depend instantaneusly on the reset signals.+ -- resetUp = goUp `tag` False+ -- resetDown = goDown `tag` False - -- One approach would be to wait for "physical confiramtion"- -- that the elevator actually is moving in the desired direction:--- resetUp <- (`tag` True) ^<< edge -< v > 0--- resetDown <- (`tag` False) ^<< edge -< v < 0+ -- One approach would be to wait for "physical confiramtion"+ -- that the elevator actually is moving in the desired direction:+ -- resetUp <- (`tag` True) ^<< edge -< v > 0+ -- resetDown <- (`tag` False) ^<< edge -< v < 0 - -- Another approach is to simply delay the reset events to avoid- -- suppressing the very event that generates the reset event.- resetUp <- iPre noEvent -< goUp `tag` False- resetDown <- iPre noEvent -< goDown `tag` False+ -- Another approach is to simply delay the reset events to avoid+ -- suppressing the very event that generates the reset event.+ resetUp <- iPre noEvent -< goUp `tag` False+ resetDown <- iPre noEvent -< goDown `tag` False - -- Of course, a third approach would be to just use dHold below.- -- But that does not seem to be the right solution to me.- upPending <- hold False -< setUp `lMerge` resetUp- downPending <- hold False -< setDown `lMerge` resetDown+ -- Of course, a third approach would be to just use dHold below.+ -- But that does not seem to be the right solution to me.+ upPending <- hold False -< setUp `lMerge` resetUp+ downPending <- hold False -< setDown `lMerge` resetDown - let pending = upPending || downPending- eitherButton = lbp `lMerge` rbp+ let pending = upPending || downPending+ eitherButton = lbp `lMerge` rbp - goDown = arriveTop `gate` pending- `lMerge`- eitherButton `gate` waitingTop- goUp = arriveBottom `gate` pending- `lMerge`- eitherButton `gate` waitingBottom- stop = (arriveTop `lMerge` arriveBottom) `gate` not pending+ goDown = arriveTop `gate` pending+ `lMerge` eitherButton `gate` waitingTop - returnA -< y+ goUp = arriveBottom `gate` pending+ `lMerge` eitherButton `gate` waitingBottom++ stop = (arriveTop `lMerge` arriveBottom) `gate` not pending++ returnA -< y
examples/Elevator/TestElevatorMain.hs view
@@ -1,16 +1,9 @@-{--******************************************************************************-* A F R P *-* *-* Example: Elevator *-* Purpose: Testing of the Elevator simulator. *-* Authors: Henrik Nilsson *-* *-* Copyright (c) The University of Nottingham, 2004 *-* *-******************************************************************************--}-+-- |+-- Description : Testing of the Elevator simulator.+-- Copyright : The University of Nottingham, 2004+-- Authors : Henrik Nilsson+--+-- Part of Elevator example. module Main where import Data.List (sortBy, intersperse)@@ -28,66 +21,60 @@ rbps :: SF a (Event ()) rbps = afterEach [(20.0, ()), (2.0, ()), (18.0, ()), (15.001, ())] - -- Looks for interesting events by inspecting the input events -- and the elevator position over the interval [0, t_max]. data State = Stopped | GoingUp | GoingDown deriving Eq - testElevator :: Time -> [(Time, ((Event (), Event ()), Position))] testElevator t_max = takeWhile ((<= t_max) . fst) tios- where- -- Time, Input, and Output- tios = embed (localTime &&& ((lbps &&& rbps >>^ dup)- >>> second elevator))- (deltaEncode smplPer (repeat ()))-+ where+ -- Time, Input, and Output+ tios = embed (localTime &&& ((lbps &&& rbps >>^ dup) >>> second elevator))+ (deltaEncode smplPer (repeat ())) findEvents :: [(Time, ((Event (), Event ()), Position))] -> [(Time, Position, String)] findEvents [] = [] findEvents tios@((_, (_, y)) : _) = feAux Stopped y tios- where- feAux _ _ [] = []- feAux sPre yPre ((t, ((lbp, rbp), y)) : tios') =- if not (null message) then- (t, y, message) : feAux s y tios'- else- feAux s y tios'- where- s = if y == yPre then- Stopped- else if yPre < y then- GoingUp- else- GoingDown+ where+ feAux _ _ [] = []+ feAux sPre yPre ((t, ((lbp, rbp), y)) : tios') =+ if not (null message)+ then (t, y, message) : feAux s y tios'+ else feAux s y tios'+ where+ s = if y == yPre+ then Stopped+ else if yPre < y+ then GoingUp+ else+ GoingDown - ms = if s /= sPre then- case s of- Stopped -> Just "elevator stopped"- GoingUp -> Just "elevator started going up"- GoingDown -> Just "elevator started going down"- else- Nothing+ ms = if s /= sPre+ then+ case s of+ Stopped -> Just "elevator stopped"+ GoingUp -> Just "elevator started going up"+ GoingDown -> Just "elevator started going down"+ else+ Nothing - mu = if isEvent lbp then- Just "up button pressed"- else- Nothing+ mu = if isEvent lbp+ then Just "up button pressed"+ else Nothing - md = if isEvent rbp then- Just "down button pressed"- else- Nothing+ md = if isEvent rbp+ then Just "down button pressed"+ else Nothing - message = concat (intersperse ", " (catMaybes [ms, mu, md]))+ message = concat (intersperse ", " (catMaybes [ms, mu, md])) formatEvent :: (Time, Position, String) -> String formatEvent (t, y, m) = "t = " ++ t' ++ ",\ty = " ++ y' ++ ":\t" ++ m- where- t' = show (fromIntegral (round (t * 100)) / 100)- y' = show (fromIntegral (round (y * 100)) / 100)+ where+ t' = show (fromIntegral (round (t * 100)) / 100)+ y' = show (fromIntegral (round (y * 100)) / 100) ppEvents [] = return () ppEvents (e : es) = putStrLn (formatEvent e) >> ppEvents es
examples/TailgatingDetector/TailgatingDetector.hs view
@@ -1,17 +1,9 @@ {-# LANGUAGE Arrows #-}--{--******************************************************************************-* A F R P *-* *-* Module: TailgatingDetector *-* Purpose: AFRP Expressitivity Test *-* Authors: Henrik Nilsson *-* *-* Copyright (c) Yale University, 2003 *-* *-******************************************************************************--}+-- |+-- Module : TailgatingDetector+-- Description : AFRP Expressitivity Test+-- Copyright : Yale University, 2003+-- Authors : Henrik Nilsson -- Context: an autonomous flying vehicle carrying out traffic surveillance -- through an on-board video camera.@@ -46,66 +38,55 @@ import FRP.Yampa.Conditional import FRP.Yampa.EventS ----------------------------------------------------------------------------------- Testing framework-------------------------------------------------------------------------------+-- * Testing framework -type Position = Double -- [m]-type Distance = Double -- [m]-type Velocity = Double -- [m/s]+type Position = Double -- [m]+type Distance = Double -- [m]+type Velocity = Double -- [m/s] -- We'll call any ground vehicle "car". For our purposes, a car is -- represented by its ground position and ground velocity. type Car = (Position, Velocity) - -- A highway is just a list of cars. In this simple setting, we assume all -- cars are there all the time (no enter or exit ramps etc.) type Highway = [Car] - -- Type of the Video signal. Here just an association list of cars *in view* -- with *relative* positions. type Video = [(Int, Car)] - -- System info, such as height and ground speed. Here, just the position. type UAVStatus = Position - -- Various ways of making cars. switchAfter :: Time -> SF a b -> (b -> SF a b) -> SF a b switchAfter t sf k = switch (sf &&& after t () >>^ \(b,e) -> (b, e `tag` b)) k - mkCar1 :: Position -> Velocity -> SF a Car mkCar1 p0 v = constant v >>> (integral >>^ (+p0)) &&& identity mkCar2 :: Position -> Velocity -> Time -> Velocity -> SF a Car mkCar2 p0 v0 t0 v = switchAfter t0 (mkCar1 p0 v0) (flip mkCar1 v . fst) - mkCar3 :: Position->Velocity->Time->Velocity->Time->Velocity->SF a Car mkCar3 p0 v0 t0 v1 t1 v = switchAfter t0 (mkCar1 p0 v0) $ \(p1, _) ->- switchAfter t1 (mkCar1 p1 v1) $ \(p2, _) ->+ switchAfter t1 (mkCar1 p1 v1) $ \(p2, _) -> mkCar1 p2 v - highway :: SF a Highway-highway = parB [mkCar1 (-600) 30.9,- mkCar1 0 30,- mkCar3 (-1000) 40 95 30 200 30.9,- mkCar1 (-3000) 45,- mkCar1 700 28,- mkCar1 800 29.1]-+highway = parB [ mkCar1 (-600) 30.9+ , mkCar1 0 30+ , mkCar3 (-1000) 40 95 30 200 30.9+ , mkCar1 (-3000) 45+ , mkCar1 700 28+ , mkCar1 800 29.1+ ] -- The status of the UAV. For now, it's just flying at constant speed. uavStatus :: SF a UAVStatus uavStatus = constant 30 >>> integral - -- Tracks a car in the video stream. An event is generated when tracking is -- lost, which we assume only happens if the car leaves the field of vision. -- We don't concern ourselves with realistic creation of trackers.@@ -121,43 +102,39 @@ -- as cars enters the field of view. mkVideoAndTrackers :: SF (Highway, UAVStatus) (Video, Event CarTracker) mkVideoAndTrackers = arr mkVideo >>> identity &&& carEntry- where- mkVideo :: (Highway, Position) -> Video- mkVideo (cars, p_uav) =- [ (i, (p_rel, v))- | (i, (p, v)) <- zip [0..] cars,- let p_rel = p - p_uav, abs p_rel <= range]-- carEntry :: SF Video (Event CarTracker)- carEntry = edgeBy newCar []- where- newCar v_prev v =- case (map fst v) \\ (map fst v_prev) of- [] -> Nothing- (i : _) -> Just (mkCarTracker i)+ where+ mkVideo :: (Highway, Position) -> Video+ mkVideo (cars, p_uav) =+ [ (i, (p_rel, v))+ | (i, (p, v)) <- zip [0..] cars+ , let p_rel = p - p_uav, abs p_rel <= range+ ] - mkCarTracker :: Int -> CarTracker- mkCarTracker i = arr (lookup i . fst)- >>> trackAndHold undefined- &&& edgeBy justToNothing (Just undefined)- where- justToNothing Nothing Nothing = Nothing- justToNothing Nothing (Just _) = Nothing- justToNothing (Just _) (Just _) = Nothing- justToNothing (Just _) Nothing = Just ()+ carEntry :: SF Video (Event CarTracker)+ carEntry = edgeBy newCar []+ where+ newCar v_prev v =+ case (map fst v) \\ (map fst v_prev) of+ [] -> Nothing+ (i : _) -> Just (mkCarTracker i) + mkCarTracker :: Int -> CarTracker+ mkCarTracker i = arr (lookup i . fst)+ >>> trackAndHold undefined+ &&& edgeBy justToNothing (Just undefined)+ where+ justToNothing Nothing Nothing = Nothing+ justToNothing Nothing (Just _) = Nothing+ justToNothing (Just _) (Just _) = Nothing+ justToNothing (Just _) Nothing = Just () videoAndTrackers :: SF a (Video, Event CarTracker) videoAndTrackers = highway &&& uavStatus >>> mkVideoAndTrackers - smplFreq = 2.0 smplPer = 1/smplFreq ----------------------------------------------------------------------------------- Tailgating detector-------------------------------------------------------------------------------+-- * Tailgating detector -- Looks at the positions of two cars and determines if the first is -- tailgating the second. Tailgating is assumed to have occurred if:@@ -170,30 +147,26 @@ tailgating :: SF (Car, Car) (Event ()) tailgating = provided follow tooClose never- where- follow ((p1, v1), (p2, v2)) = p1 < p2- && v1 > 5.0- && abs ((v2 - v1)/v1) < 0.2- && (p2 - p1) / v1 < 5.0-- -- Under the assumption that car c1 is following car c2, generate an- -- event if car1 has been too close to car2 on average during the- -- last 30 s.- tooClose :: SF (Car, Car) (Event ())- tooClose = proc (c1, c2) -> do- ead <- recur (snapAfter 30 <<< avgDist) -< (c1, c2)- returnA -< (filterE (<1.0) ead) `tag` ()+ where+ follow ((p1, v1), (p2, v2)) = p1 < p2+ && v1 > 5.0+ && abs ((v2 - v1)/v1) < 0.2+ && (p2 - p1) / v1 < 5.0 - avgDist = proc ((p1, v1), (p2, v2)) -> do- let nd = (p2 - p1) / v1- ind <- integral -< nd- t <- localTime -< ()- returnA -< if t > 0 then ind / t else nd+ -- Under the assumption that car c1 is following car c2, generate an event+ -- if car1 has been too close to car2 on average during the last 30 s.+ tooClose :: SF (Car, Car) (Event ())+ tooClose = proc (c1, c2) -> do+ ead <- recur (snapAfter 30 <<< avgDist) -< (c1, c2)+ returnA -< (filterE (<1.0) ead) `tag` () + avgDist = proc ((p1, v1), (p2, v2)) -> do+ let nd = (p2 - p1) / v1+ ind <- integral -< nd+ t <- localTime -< ()+ returnA -< if t > 0 then ind / t else nd ---------------------------------------------------------------------------------- Multi-Car tracker-------------------------------------------------------------------------------+-- * Multi-Car tracker -- Auxiliary definitions @@ -201,10 +174,8 @@ data MCTCol a = MCTCol Id [(Id, a)] - instance Functor MCTCol where- fmap f (MCTCol n ias) = MCTCol n [ (i, f a) | (i, a) <- ias ]-+ fmap f (MCTCol n ias) = MCTCol n [ (i, f a) | (i, a) <- ias ] -- Tracking of individual cars in a group. The arrival of a new car is -- signalled by an external event, which causes a new tracker to be added@@ -225,49 +196,44 @@ mct :: SF (Video, UAVStatus, Event CarTracker) [(Id, Car)] mct = pSwitch route cts_init addOrDelCTs (\cts' f -> mctAux (f cts')) >>^ getCars- where- mctAux cts = pSwitch route- cts- (noEvent --> addOrDelCTs)- (\cts' f -> mctAux (f cts'))-- route (v, s, _) = fmap (\ct -> ((v, s), ct))+ where+ mctAux cts = pSwitch route+ cts+ (noEvent --> addOrDelCTs)+ (\cts' f -> mctAux (f cts')) - -- addOrDelCTs :: SF _ (Event (MCTCol CarTracker -> MCTCol carTracker))- addOrDelCTs = proc ((_, _, ect), ces) -> do- let eAdd = fmap addCT ect- let eDel = fmap delCTs (catEvents (getEvents ces))- returnA -< mergeBy (.) eAdd eDel+ route (v, s, _) = fmap (\ct -> ((v, s), ct)) - cts_init :: MCTCol CarTracker- cts_init = MCTCol 0 []+ -- addOrDelCTs :: SF _ (Event (MCTCol CarTracker -> MCTCol carTracker))+ addOrDelCTs = proc ((_, _, ect), ces) -> do+ let eAdd = fmap addCT ect+ let eDel = fmap delCTs (catEvents (getEvents ces))+ returnA -< mergeBy (.) eAdd eDel - addCT :: CarTracker -> MCTCol CarTracker -> MCTCol CarTracker- addCT ct (MCTCol n icts) = MCTCol (n+1) ((n, ct) : icts)+ cts_init :: MCTCol CarTracker+ cts_init = MCTCol 0 [] - delCTs :: [Id] -> MCTCol CarTracker -> MCTCol CarTracker- delCTs is (MCTCol n icts) =- MCTCol n (filter (flip notElem is . fst) icts)+ addCT :: CarTracker -> MCTCol CarTracker -> MCTCol CarTracker+ addCT ct (MCTCol n icts) = MCTCol (n+1) ((n, ct) : icts) - getCars :: MCTCol (Car, Event ()) -> [(Id, Car)]- getCars (MCTCol _ ices) = [(i, c) | (i, (c, _)) <- ices ]+ delCTs :: [Id] -> MCTCol CarTracker -> MCTCol CarTracker+ delCTs is (MCTCol n icts) =+ MCTCol n (filter (flip notElem is . fst) icts) - getEvents :: MCTCol (Car, Event ()) -> [Event Id]- getEvents (MCTCol _ ices) = [e `tag` i | (i,(_,e)) <- ices]+ getCars :: MCTCol (Car, Event ()) -> [(Id, Car)]+ getCars (MCTCol _ ices) = [(i, c) | (i, (c, _)) <- ices ] + getEvents :: MCTCol (Car, Event ()) -> [Event Id]+ getEvents (MCTCol _ ices) = [e `tag` i | (i,(_,e)) <- ices] ---------------------------------------------------------------------------------- Multi tailgating detector-------------------------------------------------------------------------------+-- * Multi tailgating detector -- Auxiliary definitions newtype MTGDCol a = MTGDCol [((Id,Id), a)] - instance Functor MTGDCol where- fmap f (MTGDCol iias) = MTGDCol [ (ii, f a) | (ii, a) <- iias ]-+ fmap f (MTGDCol iias) = MTGDCol [ (ii, f a) | (ii, a) <- iias ] -- Run tailgating above for each pair of tracked cars. A structural change -- to the list of tracked cars is signalled by an event, at which point@@ -283,43 +249,41 @@ eno <- newOrder -< ics' etgs <- rpSwitch route (MTGDCol []) -< (ics', fmap updateTGDs eno) returnA -< tailgaters etgs- where- route ics (MTGDCol iitgs) = MTGDCol $- let cs = map snd ics- in- [ (ii, (cc, tg))- | (cc, (ii, tg)) <- zip (zip cs (tail cs)) iitgs ]-- relPos (_, (p1, _)) (_, (p2, _)) = compare p1 p2+ where+ route ics (MTGDCol iitgs) = MTGDCol $+ let cs = map snd ics+ in [ (ii, (cc, tg))+ | (cc, (ii, tg)) <- zip (zip cs (tail cs)) iitgs+ ] - newOrder :: SF [(Id, Car)] (Event [Id])- newOrder = edgeBy (\ics ics' -> if sameOrder ics ics' then- Nothing- else- Just (map fst ics'))- []- where- sameOrder [] [] = True- sameOrder [] _ = False- sameOrder _ [] = False- sameOrder ((i,_):ics) ((i',_):ics')- | i == i' = sameOrder ics ics'- | otherwise = False+ relPos (_, (p1, _)) (_, (p2, _)) = compare p1 p2 - updateTGDs is (MTGDCol iitgs) = MTGDCol $- [ (ii, maybe tailgating id (lookup ii iitgs))- | ii <- zip is (tail is) ]+ newOrder :: SF [(Id, Car)] (Event [Id])+ newOrder = edgeBy (\ics ics' -> if sameOrder ics ics'+ then Nothing+ else Just (map fst ics'))+ []+ where+ sameOrder [] [] = True+ sameOrder [] _ = False+ sameOrder _ [] = False+ sameOrder ((i,_):ics) ((i',_):ics')+ | i == i' = sameOrder ics ics'+ | otherwise = False - tailgaters :: MTGDCol (Event ()) -> Event [(Id, Id)]- tailgaters (MTGDCol iies) = catEvents [ e `tag` ii | (ii, e) <- iies ]+ updateTGDs is (MTGDCol iitgs) = MTGDCol $+ [ (ii, maybe tailgating id (lookup ii iitgs))+ | ii <- zip is (tail is) ] + tailgaters :: MTGDCol (Event ()) -> Event [(Id, Id)]+ tailgaters (MTGDCol iies) = catEvents [ e `tag` ii | (ii, e) <- iies ] -- Finally, we can tie the individaul pieces together into a signal -- function which finds tailgaters: findTailgaters ::- SF (Video, UAVStatus, Event CarTracker) ([(Id, Car)], Event [(Id, Id)])+ SF (Video, UAVStatus, Event CarTracker) ([(Id, Car)], Event [(Id, Id)]) findTailgaters = proc (v, s, ect) -> do- ics <- mct -< (v, s, ect)- etgs <- mtgd -< ics- returnA -< (ics, etgs)+ ics <- mct -< (v, s, ect)+ etgs <- mtgd -< ics+ returnA -< (ics, etgs)
examples/TailgatingDetector/TestTGMain.hs view
@@ -1,18 +1,10 @@ {-# LANGUAGE Arrows #-}--{--******************************************************************************-* A F R P *-* *-* Example: Test TG *-* Purpose: Testing of the tailgating detector. *-* Authors: Henrik Nilsson *-* *-* Copyright (c) Yale University, 2003 *-* *-******************************************************************************--}-+-- |+-- Description : Testing of the tailgating detector.+-- Copyright : Yale University, 2003+-- Authors : Henrik Nilsson+--+-- Part of the TailgatingDetector example. module Main where import Data.List (sortBy)@@ -21,39 +13,34 @@ import TailgatingDetector - -- Looks for interesting events in the video stream (cars entering, -- leaving, overtaking) in the interval [0, t]. testVideo :: Time -> [(Time, Event Video)] testVideo t_max = filter (isEvent . snd) $ takeWhile (\(t, _) -> t <= t_max) $ embed (localTime &&& (videoAndTrackers >>^ fst)- >>> filterVideo)- (deltaEncode smplPer (repeat ()))- where- filterVideo = second (edgeBy change [])- where- change v_prev v =- if (map fst (sortBy comparePos v_prev))- /= (map fst (sortBy comparePos v)) then- Just v- else- Nothing-- comparePos (_, (p1, _)) (_, (p2, _)) = compare p1 p2+ >>> filterVideo)+ (deltaEncode smplPer (repeat ()))+ where+ filterVideo = second (edgeBy change [])+ where+ change v_prev v =+ if (map fst (sortBy comparePos v_prev))+ /= (map fst (sortBy comparePos v))+ then Just v+ else Nothing + comparePos (_, (p1, _)) (_, (p2, _)) = compare p1 p2 ppTestVideo t = mapM_ (putStrLn . show) (testVideo t) - testTailgating t_max = filter (isEvent . snd) $ takeWhile (\(t, _) -> t <= t_max) $ embed (localTime- &&& (mkCar3 (-1000) 40 95 30 200 30.9- &&& mkCar1 0 30- >>> tailgating))- (deltaEncode smplPer (repeat ()))-+ &&& (mkCar3 (-1000) 40 95 30 200 30.9+ &&& mkCar1 0 30+ >>> tailgating))+ (deltaEncode smplPer (repeat ())) testMCT :: Time -> [(Time, Event [(Id, Car)])] testMCT t_max = filter (isEvent . snd) $@@ -64,24 +51,21 @@ &&& identity >>> arr (\((v, ect), s) -> (v, s, ect)) >>> mct)- >>> filterMCTOutput)- (deltaEncode smplPer (repeat ()))- where- filterMCTOutput = second (edgeBy change [])- where- change v_prev v =- if (map fst (sortBy comparePos v_prev))- /= (map fst (sortBy comparePos v)) then- Just v- else- Nothing-- comparePos (_, (p1, _)) (_, (p2, _)) = compare p1 p2+ >>> filterMCTOutput)+ (deltaEncode smplPer (repeat ()))+ where+ filterMCTOutput = second (edgeBy change [])+ where+ change v_prev v =+ if (map fst (sortBy comparePos v_prev))+ /= (map fst (sortBy comparePos v))+ then Just v+ else Nothing + comparePos (_, (p1, _)) (_, (p2, _)) = compare p1 p2 ppTestMCT t = mapM_ (putStrLn . show) (testMCT t) - testMTGD :: Time -> [(Time, (Event [(Id,Id)], [(Id, Car)]))] testMTGD t_max = filter (isEvent . fst . snd) $ takeWhile (\(t, _) -> t <= t_max) $@@ -95,7 +79,6 @@ (deltaEncode smplPer (repeat ())) ppTestMTGD t = mapM_ (putStrLn . show) (testMTGD t)- -- We could read the car specification from standard input. main = ppTestMTGD 2000
examples/yampa-game/MainCircleMouse.hs view
@@ -20,7 +20,7 @@ -- The first two arguments to reactimate are the value of the input signal -- at time zero and at subsequent times, together with the times between -- samples.--- +-- -- The third argument to reactimate is the output consumer that renders -- the signal. --@@ -60,8 +60,8 @@ -- | Input controller data Controller = Controller- { controllerPos :: (Double, Double)- }+ { controllerPos :: (Double, Double)+ } -- | Give a controller, refresh its state and return the latest value. -- We need a non-blocking controller-polling function.
src/FRP/Yampa.hs view
@@ -1,4 +1,3 @@--------------------------------------------------------------------------------- -- | -- Module : FRP.Yampa -- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003@@ -10,8 +9,7 @@ -- -- Domain-specific language embedded in Haskell for programming deterministic -- hybrid (mixed discrete-time and continuous-time) systems. Yampa is based on--- the concepts of Functional Reactive Programming (FRP) and is structured--- using arrow combinators.+-- the concepts of Functional Reactive Programming (FRP). -- -- Yampa has been used to write professional Haskell cross-platform games for -- iOS, Android, desktop and web. There is a library for testing Yampa@@ -232,243 +230,179 @@ -- 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 (-- -- * Basic definitions- Time, -- [s] Both for time w.r.t. some reference and intervals.- DTime, -- [s] Sampling interval, always > 0.- SF, -- Signal Function.- Event(..), -- Events; conceptually similar to Maybe (but abstract).-- -- Temporary!- -- SF(..), sfTF',-- -- 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-- -- ** Lifting- arrPrim, arrEPrim, -- For optimization-- -- * Signal functions-- -- ** 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- (-:>), -- :: 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+module FRP.Yampa+ (+ -- * Basic definitions+ Time+ , DTime+ , SF+ , Event(..) - -- ** Simple, stateful signal processing- sscan, -- :: (b -> a -> b) -> b -> SF a b- sscanPrim, -- :: (c -> a -> Maybe (c, b)) -> c -> b -> SF a b+ -- ** Lifting+ , arrPrim, arrEPrim - -- * Events- -- ** Basic event sources- never, -- :: SF a (Event b)- now, -- :: b -> SF a (Event b)- after, -- :: Time -> b -> SF a (Event b)- repeatedly, -- :: Time -> b -> SF a (Event b)- afterEach, -- :: [(Time,b)] -> SF a (Event b)- afterEachCat, -- :: [(Time,b)] -> SF a (Event [b])- delayEvent, -- :: Time -> SF (Event a) (Event a)- delayEventCat, -- :: Time -> SF (Event a) (Event [a])- edge, -- :: SF Bool (Event ())- iEdge, -- :: Bool -> SF Bool (Event ())- edgeTag, -- :: a -> SF Bool (Event a)- edgeJust, -- :: SF (Maybe a) (Event a)- edgeBy, -- :: (a -> a -> Maybe b) -> a -> SF a (Event b)- maybeToEvent, -- :: Maybe a -> Event a+ -- * Signal functions - -- ** 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 signal functions+ , identity+ , constant+ , localTime+ , time - -- ** 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+ -- ** Initialization+ , (-->)+ , (-:>)+ , (>--)+ , (-=>)+ , (>=-)+ , initially - -- * Switching- -- ** 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+ -- ** Simple, stateful signal processing+ , sscan+ , sscanPrim - -- ** Parallel composition and switching- -- *** 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)+ -- * Events+ -- ** Basic event sources+ , never+ , now+ , after+ , repeatedly+ , afterEach+ , afterEachCat+ , delayEvent+ , delayEventCat+ , edge+ , iEdge+ , edgeTag+ , edgeJust+ , edgeBy+ , maybeToEvent - -- *** 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)- --+ -- ** Stateful event suppression+ , notYet+ , once+ , takeEvents+ , dropEvents - -- * Discrete to continuous-time signal functions- -- ** Wave-form generation- hold, -- :: a -> SF (Event a) a- dHold, -- :: a -> SF (Event a) a- trackAndHold, -- :: a -> SF (Maybe a) a+ -- ** Pointwise functions on events+ , noEvent+ , noEventFst+ , noEventSnd+ , event+ , fromEvent+ , isEvent+ , isNoEvent+ , tag+ , tagWith+ , attach+ , lMerge+ , rMerge+ , merge+ , mergeBy+ , mapMerge+ , mergeEvents+ , catEvents+ , joinE+ , splitE+ , filterE+ , mapFilterE+ , gate - -- ** Accumulators- 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)+ -- * Switching+ -- ** Basic switchers+ , switch, dSwitch+ , rSwitch, drSwitch+ , kSwitch, dkSwitch - -- * Delays- -- ** Basic delays- pre, -- :: SF a a- iPre, -- :: a -> SF a a+ -- ** Parallel composition and switching+ -- *** Parallel composition and switching over collections with broadcasting+ , parB+ , pSwitchB,dpSwitchB+ , rpSwitchB,drpSwitchB - -- ** Timed delays- delay, -- :: Time -> a -> SF a a+ -- *** Parallel composition and switching over collections with general routing+ , par+ , pSwitch, dpSwitch+ , rpSwitch,drpSwitch - -- ** Variable delay- pause, -- :: b -> SF a b -> SF a Bool -> SF a b+ -- * Discrete to continuous-time signal functions+ -- ** Wave-form generation+ , hold+ , dHold+ , trackAndHold - -- * State keeping combinators+ -- ** Accumulators+ , accum+ , accumHold+ , dAccumHold+ , accumBy+ , accumHoldBy+ , dAccumHoldBy+ , accumFilter - -- ** 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+ -- * Delays+ -- ** Basic delays+ , pre+ , iPre - -- ** Integration and differentiation- integral, -- :: VectorSpace a s => SF a a- imIntegral, -- :: VectorSpace a s => a -> SF a a- impulseIntegral, -- :: VectorSpace a k => SF (a, Event a) a- count, -- :: Integral b => SF (Event a) (Event b)- derivative, -- :: VectorSpace a s => SF a a -- Crude!+ -- ** Timed delays+ , delay + -- ** Variable delay+ , pause - -- Temporarily hidden, but will eventually be made public.- iterFrom, -- :: (a -> a -> DTime -> b -> b) -> b -> SF a b+ -- * State keeping combinators - -- * 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)+ -- ** Loops with guaranteed well-defined feedback+ , loopPre+ , loopIntegral - RandomGen(..),- Random(..),+ -- ** Integration and differentiation+ , integral+ , imIntegral+ , impulseIntegral+ , count+ , derivative - -- * Execution/simulation- -- ** 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)+ -- Temporarily hidden, but will eventually be made public.+ , iterFrom - -- process a single input sample:- react, -- ReactHandle a b- -- -> (DTime,Maybe a)- -- -> IO Bool+ -- * Noise (random signal) sources and stochastic event sources+ , noise+ , noiseR+ , occasionally - -- ** Embedding- -- (tentative: will be revisited)- 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)])+ , RandomGen(..)+ , Random(..) - FutureSF,- evalAtZero,- evalAt,- evalFuture,+ -- * Execution/simulation+ -- ** Reactimation+ , reactimate+ , ReactHandle+ , reactInit+ , react - -- * Auxiliary definitions- -- Reverse function composition and arrow plumbing aids- dup, -- :: a -> (a,a)+ -- ** Embedding+ , embed+ , embedSynch+ , deltaEncode+ , deltaEncodeBy - -- Re-exported module, classes, and types- module Control.Arrow,- module Data.VectorSpace,+ , FutureSF+ , evalAtZero+ , evalAt+ , evalFuture -) where+ -- * Auxiliary definitions+ -- Reverse function composition and arrow plumbing aids+ , dup + -- Re-exported module, classes, and types+ , module Control.Arrow+ , module Data.VectorSpace+ )+ where import FRP.Yampa.InternalCore import FRP.Yampa.Basic@@ -488,6 +422,3 @@ import Control.Arrow import Data.VectorSpace---- Vim modeline--- vim:set tabstop=8 expandtab:
src/FRP/Yampa/Arrow.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} -- | -- Module : FRP.Yampa.Arrow -- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003@@ -9,20 +8,18 @@ -- Portability : portable -- -- Arrow helper functions.-module FRP.Yampa.Arrow (- -- * Arrow plumbing aids- dup, -- :: a -> (a,a)-- -- * 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-) where+module FRP.Yampa.Arrow+ (+ -- * Arrow plumbing aids+ dup -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative (Applicative(..))-#endif+ -- * Liftings+ , arr2+ , arr3+ , arr4+ , arr5+ )+ where import Control.Arrow
src/FRP/Yampa/Basic.hs view
@@ -15,29 +15,27 @@ -- -- It also defines ways of altering the input and the output signal only -- by inserting one value in the signal, or by transforming it.-module FRP.Yampa.Basic (-- -- * Basic signal functions- identity, -- :: SF a a- constant, -- :: b -> SF a b-- -- ** Initialization- (-->), -- :: b -> SF a b -> SF a b, infixr 0- (-:>), -- :: 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+module FRP.Yampa.Basic+ (+ -- * Basic signal functions+ identity+ , constant - ) where+ -- ** Initialization+ , (-->)+ , (-:>)+ , (>--)+ , (-=>)+ , (>=-)+ , initially+ )+ where import FRP.Yampa.InternalCore (SF(..), SF'(..), sfConst, sfId) infixr 0 -->, -:>, >--, -=>, >=- ---------------------------------------------------------------------------------- Basic signal functions-------------------------------------------------------------------------------+-- * Basic signal functions -- | Identity: identity = arr id --@@ -56,9 +54,7 @@ constant :: b -> SF a b constant b = SF {sfTF = \_ -> (sfConst b, b)} ---------------------------------------------------------------------------------- Initialization-------------------------------------------------------------------------------+-- * Initialization -- | Initialization operator (cf. Lustre/Lucid Synchrone). --@@ -74,7 +70,7 @@ -- like the given sf. (-:>) :: b -> SF a b -> SF a b b0 -:> (SF {sfTF = tf10}) = SF {sfTF = \_a0 -> (ct, b0)}- where ct = SF' $ \_dt a0 -> tf10 a0+ where ct = SF' $ \_dt a0 -> tf10 a0 -- | Input initialization operator. --@@ -84,15 +80,13 @@ (>--) :: a -> SF a b -> SF a b a0 >-- (SF {sfTF = tf10}) = SF {sfTF = \_ -> tf10 a0} - -- | Transform initial output value. -- -- Applies a transformation 'f' only to the first output value at -- time zero. (-=>) :: (b -> b) -> SF a b -> SF a b f -=> (SF {sfTF = tf10}) =- SF {sfTF = \a0 -> let (sf1, b0) = tf10 a0 in (sf1, f b0)}-+ SF {sfTF = \a0 -> let (sf1, b0) = tf10 a0 in (sf1, f b0)} -- | Transform initial input value. --
src/FRP/Yampa/Conditional.hs view
@@ -8,11 +8,11 @@ -- Portability : non-portable (GHC extensions) -- -- Apply SFs only under certain conditions.-module FRP.Yampa.Conditional (- provided -- :: (a -> Bool) -> SF a b -> SF a b -> SF a b- , pause -- :: b -> SF a b -> SF a Bool -> SF a b-- ) where+module FRP.Yampa.Conditional+ ( provided+ , pause+ )+ where import Control.Arrow @@ -41,9 +41,9 @@ 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)+ where+ stt = switch (sft &&& (not . p ^>> edge)) (const stf)+ stf = switch (sff &&& (p ^>> edge)) (const stt) -- * Variable pause @@ -54,29 +54,29 @@ -- transformation is paused. pause :: b -> SF a Bool -> SF a b -> SF a b pause b_init (SF { sfTF = tfP}) (SF {sfTF = tf10}) = SF {sfTF = tf0}- where- -- Initial transformation (no time delta):- -- If the condition is True, return the accumulator b_init)- -- Otherwise transform the input normally and recurse.- tf0 a0 = case tfP a0 of- (c, True) -> (pauseInit b_init tf10 c, b_init)- (c, False) -> let (k, b0) = tf10 a0- in (pause' b0 k c, b0)+ where+ -- Initial transformation (no time delta):+ -- If the condition is True, return the accumulator b_init)+ -- Otherwise transform the input normally and recurse.+ tf0 a0 = case tfP a0 of+ (c, True) -> (pauseInit b_init tf10 c, b_init)+ (c, False) -> let (k, b0) = tf10 a0+ in (pause' b0 k c, b0) - -- Similar deal, but with a time delta- pauseInit :: b -> (a -> Transition a b) -> SF' a Bool -> SF' a b- pauseInit b_init' tf10' c = SF' tf0'- where tf0' dt a =- case (sfTF' c) dt a of- (c', True) -> (pauseInit b_init' tf10' c', b_init')- (c', False) -> let (k, b0) = tf10' a- in (pause' b0 k c', b0)+ -- Similar deal, but with a time delta+ pauseInit :: b -> (a -> Transition a b) -> SF' a Bool -> SF' a b+ pauseInit b_init' tf10' c = SF' tf0'+ where tf0' dt a =+ case (sfTF' c) dt a of+ (c', True) -> (pauseInit b_init' tf10' c', b_init')+ (c', False) -> let (k, b0) = tf10' a+ in (pause' b0 k c', b0) - -- Very same deal (almost alpha-renameable)- pause' :: b -> SF' a b -> SF' a Bool -> SF' a b- pause' b_init' tf10' tfP' = SF' tf0'- where tf0' dt a =- case (sfTF' tfP') dt a of- (tfP'', True) -> (pause' b_init' tf10' tfP'', b_init')- (tfP'', False) -> let (tf10'', b0') = (sfTF' tf10') dt a- in (pause' b0' tf10'' tfP'', b0')+ -- Very same deal (almost alpha-renameable)+ pause' :: b -> SF' a b -> SF' a Bool -> SF' a b+ pause' b_init' tf10' tfP' = SF' tf0'+ where tf0' dt a =+ case (sfTF' tfP') dt a of+ (tfP'', True) -> (pause' b_init' tf10' tfP'', b_init')+ (tfP'', False) -> let (tf10'', b0') = (sfTF' tf10') dt a+ in (pause' b0' tf10'' tfP'', b0')
src/FRP/Yampa/Delays.hs view
@@ -9,17 +9,17 @@ -- -- SF primitives and combinators to delay signals, introducing new values in -- them.-module FRP.Yampa.Delays (-- -- * Basic delays- pre, -- :: SF a a- iPre, -- :: a -> SF a a- fby, -- :: b -> SF a b -> SF a b, infixr 0-- -- * Timed delays- delay, -- :: Time -> a -> SF a a+module FRP.Yampa.Delays+ (+ -- * Basic delays+ pre+ , iPre+ , fby -) where+ -- * Timed delays+ , delay+ )+ where import Control.Arrow @@ -30,9 +30,7 @@ infixr 0 `fby` ---------------------------------------------------------------------------------- Delays-------------------------------------------------------------------------------+-- * Delays -- | Uninitialized delay operator. --@@ -40,10 +38,9 @@ -- zero is undefined. pre :: SF a a pre = sscanPrim f uninit uninit- where- f c a = Just (a, c)- uninit = usrErr "AFRP" "pre" "Uninitialized pre operator."-+ where+ f c a = Just (a, c)+ uninit = usrErr "AFRP" "pre" "Uninitialized pre operator." -- | Initialized delay operator. --@@ -64,9 +61,7 @@ fby :: b -> SF a b -> SF a b b0 `fby` sf = b0 --> sf >>> pre ---------------------------------------------------------------------------------- Timed delays-------------------------------------------------------------------------------+-- * Timed delays -- | Delay a signal by a fixed time 't', using the second parameter -- to fill in the initial 't' seconds.@@ -74,34 +69,31 @@ 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)-- -- 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.- 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+ where+ tf0 a0 = (delayAux [] [(q, a0)] 0 a_init, a_init) - 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+ -- 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.+ 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 --- Vim modeline--- vim:set tabstop=8 expandtab:+ 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
src/FRP/Yampa/Diagnostics.hs view
@@ -17,4 +17,4 @@ -- | Reports an error in Yampa's implementation. intErr :: String -> String -> String -> a intErr mn fn msg = error ("[internal error] " ++ mn ++ "." ++ fn ++ ": "- ++ msg)+ ++ msg)
src/FRP/Yampa/Event.hs view
@@ -36,10 +36,7 @@ infixl 7 `joinE` infixl 6 `lMerge`, `rMerge`, `merge` ----------------------------------------------------------------------------------- The Event type-------------------------------------------------------------------------------+-- * The Event type -- | A single possible event occurrence, that is, a value that may or may -- not occur. Events are used to represent values that are not produced@@ -52,87 +49,80 @@ 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 (equivalent to derived instance) instance Eq a => Eq (Event a) where- -- | Equal if both NoEvent or both Event carrying equal values.- NoEvent == NoEvent = True- (Event x) == (Event y) = x == y- _ == _ = False-+ -- | Equal if both NoEvent or both Event carrying equal values.+ NoEvent == NoEvent = True+ (Event x) == (Event y) = x == y+ _ == _ = False -- | Ord instance (equivalent to derived instance) instance Ord a => Ord (Event a) where- -- | NoEvent is smaller than Event, Event x < Event y if x < y- compare NoEvent NoEvent = EQ- compare NoEvent (Event _) = LT- compare (Event _) NoEvent = GT- compare (Event x) (Event y) = compare x y+ -- | NoEvent is smaller than Event, Event x < Event y if x < y+ compare NoEvent NoEvent = EQ+ compare NoEvent (Event _) = LT+ compare (Event _) NoEvent = GT+ compare (Event x) (Event y) = compare x y -- | Functor instance (could be derived). instance Functor Event where- -- | Apply function to value carried by 'Event', if any.- fmap _ NoEvent = NoEvent- fmap f (Event a) = Event (f a)-+ -- | Apply function to value carried by 'Event', if any.+ fmap _ NoEvent = NoEvent+ fmap f (Event a) = Event (f a) -- | Applicative instance (similar to 'Maybe'). instance Applicative Event where- -- | Wrap a pure value in an 'Event'.- pure = Event- -- | If any value (function or arg) is 'NoEvent', everything is.- NoEvent <*> _ = NoEvent- Event f <*> x = f <$> x+ -- | Wrap a pure value in an 'Event'.+ pure = Event+ -- | If any value (function or arg) is 'NoEvent', everything is.+ NoEvent <*> _ = NoEvent+ Event f <*> x = f <$> x -- | Monad instance instance Monad Event where- -- | Combine events, return 'NoEvent' if any value in the- -- sequence is 'NoEvent'.- (Event x) >>= k = k x- NoEvent >>= _ = NoEvent+ -- | Combine events, return 'NoEvent' if any value in the+ -- sequence is 'NoEvent'.+ (Event x) >>= k = k x+ NoEvent >>= _ = NoEvent - (>>) = (*>)+ (>>) = (*>) - -- | See 'pure'.- return = pure+ -- | See 'pure'.+ return = pure #if !(MIN_VERSION_base(4,13,0))- -- | Fail with 'NoEvent'.- fail = Fail.fail+ -- | Fail with 'NoEvent'.+ fail = Fail.fail #endif instance Fail.MonadFail Event where- -- | Fail with 'NoEvent'.- fail _ = NoEvent+ -- | Fail with 'NoEvent'.+ fail _ = NoEvent -- | Alternative instance instance Alternative Event where- -- | An empty alternative carries no event, so it is ignored.- empty = NoEvent- -- | Merge favouring the left event ('NoEvent' only if both are- -- 'NoEvent').- NoEvent <|> r = r- l <|> _ = l+ -- | An empty alternative carries no event, so it is ignored.+ empty = NoEvent+ -- | Merge favouring the left event ('NoEvent' only if both are+ -- 'NoEvent').+ NoEvent <|> r = r+ l <|> _ = l -- | NFData instance instance NFData a => NFData (Event a) where- -- | Evaluate value carried by event.- rnf NoEvent = ()- rnf (Event a) = rnf a `seq` ()+ -- | Evaluate value carried by event.+ rnf NoEvent = ()+ rnf (Event a) = rnf a `seq` () ---------------------------------------------------------------------------------- Internal utilities for event construction-------------------------------------------------------------------------------+-- * Internal utilities for event construction -- These utilities are to be considered strictly internal to AFRP for the -- time being.@@ -142,10 +132,7 @@ maybeToEvent Nothing = NoEvent maybeToEvent (Just a) = Event a ----------------------------------------------------------------------------------- Utility functions similar to those available for Maybe-------------------------------------------------------------------------------+-- * Utility functions similar to those available for Maybe -- | An event-based version of the maybe function. event :: a -> (b -> a) -> Event b -> a@@ -166,10 +153,7 @@ isNoEvent :: Event a -> Bool isNoEvent = not . isEvent ----------------------------------------------------------------------------------- Event tagging-------------------------------------------------------------------------------+-- * Event tagging -- | Tags an (occurring) event with a value ("replacing" the old value). --@@ -190,26 +174,20 @@ attach :: Event a -> b -> Event (a, b) e `attach` b = fmap (\a -> (a, b)) e ----------------------------------------------------------------------------------- Event merging (disjunction) and joining (conjunction)-------------------------------------------------------------------------------+-- * Event merging (disjunction) and joining (conjunction) -- | Left-biased event merge (always prefer left event, if present). lMerge :: Event a -> Event a -> Event a lMerge = (<|>) - -- | Right-biased event merge (always prefer right event, if present). rMerge :: Event a -> Event a -> Event a rMerge = flip (<|>) - -- | 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 parameterized by a conflict resolution function. -- -- Applicative-based definition:@@ -249,8 +227,8 @@ -- carEvents e = if (null e) then NoEvent else (sequenceA e) catEvents :: [Event a] -> Event [a] catEvents eas = case [ a | Event a <- eas ] of- [] -> NoEvent- as -> Event as+ [] -> NoEvent+ as -> Event as -- | Join (conjunction) of two events. Only produces an event -- if both events exist.@@ -262,31 +240,25 @@ 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-------------------------------------------------------------------------------+-- * 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. Note: since 'Event' is a 'Functor', -- see 'fmap' for a simpler version of this function with no filtering. mapFilterE :: (a -> Maybe b) -> Event a -> Event b mapFilterE _ NoEvent = NoEvent mapFilterE f (Event a) = case f a of- Nothing -> NoEvent- Just b -> Event b-+ Nothing -> NoEvent+ Just b -> Event b -- | Enable/disable event occurences based on an external condition. gate :: Event a -> Bool -> Event a
src/FRP/Yampa/EventS.hs view
@@ -16,40 +16,40 @@ -- For signals that carry events, there should be a limit in the number of -- events we can observe in a time period, no matter how much we increase the -- sampling frequency.-module FRP.Yampa.EventS (-- -- * Basic event sources- never, -- :: SF a (Event b)- now, -- :: b -> SF a (Event b)- after, -- :: Time -> b -> SF a (Event b)- repeatedly, -- :: Time -> b -> SF a (Event b)- afterEach, -- :: [(Time,b)] -> SF a (Event b)- afterEachCat, -- :: [(Time,b)] -> SF a (Event [b])- delayEvent, -- :: Time -> SF (Event a) (Event a)- delayEventCat, -- :: Time -> SF (Event a) (Event [a])- edge, -- :: SF Bool (Event ())- iEdge, -- :: Bool -> SF Bool (Event ())- edgeTag, -- :: a -> SF Bool (Event a)- edgeJust, -- :: SF (Maybe a) (Event a)- edgeBy, -- :: (a -> a -> Maybe b) -> a -> SF a (Event b)-- -- * Stateful event suppression- notYet, -- :: SF (Event a) (Event a)- once, -- :: SF (Event a) (Event a)- takeEvents, -- :: Int -> SF (Event a) (Event a)- dropEvents, -- :: Int -> SF (Event a) (Event a)+module FRP.Yampa.EventS+ (+ -- * Basic event sources+ never+ , now+ , after+ , repeatedly+ , afterEach+ , afterEachCat+ , delayEvent+ , delayEventCat+ , edge+ , iEdge+ , edgeTag+ , edgeJust+ , edgeBy - -- * Hybrid SF combinators- snap, -- :: SF a (Event a)- snapAfter, -- :: Time -> SF a (Event a)- sample, -- :: Time -> SF a (Event a)- sampleWindow, -- :: Int -> Time -> SF a (Event [a])+ -- * Stateful event suppression+ , notYet+ , once+ , takeEvents+ , dropEvents - -- * Repetition and switching- recur, -- :: SF a (Event b) -> SF a (Event b)- andThen -- :: SF a (Event b) -> SF a (Event b) -> SF a (Event b)+ -- * Hybrid SF combinators+ , snap+ , snapAfter+ , sample+ , sampleWindow -) where+ -- * Repetition and switching+ , recur+ , andThen+ )+ where import Control.Arrow @@ -64,9 +64,7 @@ infixr 5 `andThen` ---------------------------------------------------------------------------------- Basic event sources-------------------------------------------------------------------------------+-- * Basic event sources -- | Event source that never occurs. {-# ANN never "HLint: ignore Use const" #-}@@ -81,7 +79,6 @@ 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 -- ^ The time /q/ after which the event should be produced@@ -98,9 +95,8 @@ 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-+ 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,@@ -116,25 +112,24 @@ 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)+ 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+ 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/.) delayEvent :: Time -> SF (Event a) (Event a)@@ -142,80 +137,82 @@ | q == 0 = identity | otherwise = delayEventCat q >>> arr (fmap head) - -- | Delay an event by a given delta and catenate events that occur so closely -- so as to be /inseparable/. delayEventCat :: Time -> SF (Event a) (Event [a]) delayEventCat 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)+ where+ tf0 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)+ 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 *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)+ -- 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. -- It is initialised as /up/, meaning that events occuring at time 0 will@@ -228,64 +225,57 @@ -- ('False', meaning that events ocurring at time 0 will be detected). iEdge :: Bool -> SF Bool (Event ()) 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+ 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 = edge >>> arr (`tag` a) - -- | Edge detector particularized for detecting transtitions -- on a 'Maybe' signal from 'Nothing' to 'Just'. 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+ 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. 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))+ 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-------------------------------------------------------------------------------+-- * Stateful event suppression -- | Suppression of initial (at local time 0) event. notYet :: SF (Event a) (Event a) notYet = initially NoEvent - -- | Suppress all but the first event. once :: SF (Event a) (Event a) once = takeEvents 1 - -- | Suppress all but the 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))) - -- | Suppress first n events. dropEvents :: Int -> SF (Event a) (Event a) dropEvents n | n <= 0 = identity@@ -294,27 +284,22 @@ dSwitch (never &&& identity) (const (NoEvent >-- dropEvents (n - 1))) - -- ** Hybrid continuous-to-discrete SF combinators. -- | Event source with a single occurrence at time 0. The value of the event is -- obtained by sampling the input at that time. snap :: SF a (Event a) snap =- -- switch ensures that the entire signal function will become just- -- "constant" once the sample has been taken.- switch (never &&& (identity &&& now () >>^ \(a, e) -> e `tag` a)) now-+ -- switch ensures that the entire signal function will become just+ -- "constant" once the sample has been taken.+ 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-+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)@@ -333,9 +318,9 @@ 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+ where+ updateWindow w as = drop (max (length w' - wl) 0) w'+ where w' = w ++ as -- * Repetition and switching @@ -349,6 +334,3 @@ -- sometimes is more understandable switch-based code. andThen :: SF a (Event b) -> SF a (Event b) -> SF a (Event b) sfe1 `andThen` sfe2 = dSwitch (sfe1 >>^ dup) (const sfe2)---- Vim modeline--- vim:set tabstop=8 expandtab:
src/FRP/Yampa/Hybrid.hs view
@@ -8,25 +8,24 @@ -- Portability : non-portable (GHC extensions) -- -- Discrete to continuous-time signal functions.-module FRP.Yampa.Hybrid (-- -- * Wave-form generation- hold, -- :: a -> SF (Event a) a- dHold, -- :: a -> SF (Event a) a- trackAndHold, -- :: a -> SF (Maybe a) a- dTrackAndHold, -- :: a -> SF (Maybe a) a-- -- * Accumulators- 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)+module FRP.Yampa.Hybrid+ (+ -- * Wave-form generation+ hold+ , dHold+ , trackAndHold+ , dTrackAndHold -) where+ -- * Accumulators+ , accum+ , accumHold+ , dAccumHold+ , accumBy+ , accumHoldBy+ , dAccumHoldBy+ , accumFilter+ )+ where import Control.Arrow @@ -34,9 +33,7 @@ import FRP.Yampa.Event import FRP.Yampa.InternalCore (SF, epPrim) ---------------------------------------------------------------------------------- Wave-form generation-------------------------------------------------------------------------------+-- * Wave-form generation -- | Zero-order hold. --@@ -49,9 +46,8 @@ -- [1,1,2,2,3,3] hold :: a -> SF (Event a) a hold a_init = epPrim f () a_init- where- f _ a = ((), a, a)-+ where+ f _ a = ((), a, a) -- | Zero-order hold with a delay. --@@ -88,9 +84,7 @@ dTrackAndHold :: a -> SF (Maybe a) a dTrackAndHold a_init = trackAndHold a_init >>> iPre a_init ---------------------------------------------------------------------------------- Accumulators-------------------------------------------------------------------------------+-- * Accumulators -- | Given an initial value in an accumulator, -- it returns a signal function that processes@@ -101,21 +95,20 @@ -- accum :: a -> SF (Event (a -> a)) (Event a) accum a_init = epPrim f a_init NoEvent- where- f a g = (a', Event a', NoEvent) -- Accumulator, output if Event,- -- output if no event- where- a' = g a-+ where+ f a g = (a', Event a', NoEvent) -- Accumulator, output if Event,+ -- output if no event+ where+ a' = g a -- | Zero-order hold accumulator (always produces the last outputted value -- until an event arrives). accumHold :: a -> SF (Event (a -> a)) a accumHold a_init = epPrim f a_init a_init- where- f a g = (a', a', a') -- Accumulator, output if Event, output if no event- where- a' = g a+ where+ f a g = (a', a', a') -- Accumulator, output if Event, output if no event+ where+ a' = g a -- | Zero-order hold accumulator with delayed initialization (always produces -- the last outputted value until an event arrives, but the very initial output@@ -126,18 +119,18 @@ -- | Accumulator parameterized by the accumulation function. 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+ where+ f b a = (b', Event b', NoEvent)+ where+ b' = g b a -- | Zero-order hold accumulator parameterized by the accumulation function. 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+ where+ f b a = (b', b', b')+ where+ b' = g b a -- | Zero-order hold accumulator parameterized by the accumulation function -- with delayed initialization (initial output sample is always the@@ -145,19 +138,13 @@ dAccumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b dAccumHoldBy f a_init = accumHoldBy f a_init >>> iPre a_init - -- | Accumulator parameterized by the accumulator function with filtering, -- possibly discarding some of the input events based on whether the second -- component of the result of applying the accumulation function is -- 'Nothing' or 'Just' x for some x. 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)------ Vim modeline--- vim:set tabstop=8 expandtab:+ where+ f c a = case g c a of+ (c', Nothing) -> (c', NoEvent, NoEvent)+ (c', Just b) -> (c', Event b, NoEvent)
src/FRP/Yampa/Integration.hs view
@@ -24,19 +24,19 @@ -- example with other vector types like V2, V1, etc. from the library linear. -- For an example, see -- <https://gist.github.com/walseb/1e0a0ca98aaa9469ab5da04e24f482c2 this gist>.-module FRP.Yampa.Integration (-- -- * Integration- integral, -- :: VectorSpace a s => SF a a- imIntegral, -- :: VectorSpace a s => a -> SF a a- impulseIntegral, -- :: VectorSpace a k => SF (a, Event a) a- count, -- :: Integral b => SF (Event a) (Event b)-- -- * Differentiation- derivative, -- :: VectorSpace a s => SF a a -- Crude!- iterFrom -- :: (a -> a -> DTime -> b -> b) -> b -> SF a b+module FRP.Yampa.Integration+ (+ -- * Integration+ integral+ , imIntegral+ , impulseIntegral+ , count -) where+ -- * Differentiation+ , derivative+ , iterFrom+ )+ where import Control.Arrow import Data.VectorSpace@@ -45,25 +45,22 @@ import FRP.Yampa.Hybrid import FRP.Yampa.InternalCore (SF(..), SF'(..), DTime) ---------------------------------------------------------------------------------- Integration and differentiation-------------------------------------------------------------------------------+-- * Integration and differentiation -- | Integration using the rectangle rule. {-# INLINE integral #-} integral :: VectorSpace a s => SF a a integral = SF {sfTF = tf0}- where- tf0 a0 = (integralAux igrl0 a0, igrl0)-- igrl0 = zeroVector+ where+ 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+ igrl0 = zeroVector + 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@@ -74,19 +71,19 @@ -- new output. 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'), b)+ where+ iterAux b a = (SF' (\ dt a' -> iterAux (f a a' dt b) a'), b) -- | A very crude version of a derivative. It simply divides the -- value difference by the time difference. Use at your own risk. derivative :: VectorSpace a s => SF a a derivative = SF {sfTF = tf0}- where- tf0 a0 = (derivativeAux a0, zeroVector)+ where+ tf0 a0 = (derivativeAux a0, zeroVector) - derivativeAux a_prev = SF' tf -- True- where- tf dt a = (derivativeAux a, (a ^-^ a_prev) ^/ realToFrac dt)+ derivativeAux a_prev = SF' tf -- True+ where+ tf dt a = (derivativeAux a, (a ^-^ a_prev) ^/ realToFrac dt) -- | Integrate the first input signal and add the /discrete/ accumulation (sum) -- of the second, discrete, input signal.@@ -99,7 +96,3 @@ -- [Event 1,NoEvent,Event 2] count :: Integral b => SF (Event a) (Event b) count = accumBy (\n _ -> n + 1) 0----- Vim modeline--- vim:set tabstop=8 expandtab:
src/FRP/Yampa/InternalCore.hs view
@@ -50,48 +50,38 @@ -- -- Finally, see [<#g:26>] for sources of randomness (useful in games). -module FRP.Yampa.InternalCore (- module Control.Arrow,- -- 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-- -- * Basic definitions- -- ** Time- Time, -- [s] Both for time w.r.t. some reference and intervals.- DTime, -- [s] Sampling interval, always > 0.+module FRP.Yampa.InternalCore+ ( module Control.Arrow - -- ** Signal Functions- SF(..), -- Signal Function.+ -- * Basic definitions+ -- ** Time+ , Time+ , DTime - -- ** Future Signal Function- SF'(..), -- Signal Function.- Transition,- sfTF',- sfId,- sfConst,- sfArrG,+ -- ** Signal Functions+ , SF(..) - -- *** Scanning- sfSScan,+ -- ** Future Signal Function+ , SF'(..)+ , Transition+ , sfTF'+ , sfId+ , sfConst+ , sfArrG - -- ** Function descriptions- FunDesc(..),- fdFun,+ -- *** Scanning+ , sfSScan - -- ** Lifting- arrPrim,- arrEPrim, -- For optimization- epPrim+ -- ** Function descriptions+ , FunDesc(..)+ , fdFun -) where+ -- ** Lifting+ , arrPrim+ , arrEPrim+ , epPrim+ )+ where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative (Applicative(..))@@ -106,10 +96,7 @@ import FRP.Yampa.Diagnostics import FRP.Yampa.Event ---------------------------------------------------------------------------------- Basic type definitions with associated utilities--------------------------------------------------------------------------------+-- * Basic type definitions with associated utilities -- | Time is used both for time intervals (duration), and time w.r.t. some -- agreed reference point in time.@@ -117,7 +104,6 @@ -- 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.@@ -129,27 +115,26 @@ -- function from 'Time' to value. data SF a b = SF {sfTF :: a -> Transition a b} - -- | Signal function in "running" state. -- -- It can also be seen as a Future Signal Function, meaning, -- an SF that, given a time delta or a time in the future, it will -- be an SF. 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- SF' :: !(DTime -> a -> Transition a b) -> SF' a b+ 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+ SF' :: !(DTime -> a -> Transition a b) -> SF' a b -- | A transition is a pair of the next state (in the form of a future signal -- function) and the output at the present time step.@@ -164,7 +149,6 @@ sfTF' (SFCpAXA tf _ _ _) = tf sfTF' (SF' tf) = tf - -- | Constructor for a lifted structured function. sfArr :: FunDesc a b -> SF' a b sfArr FDI = sfId@@ -175,28 +159,27 @@ -- | SF constructor for the identity function. sfId :: SF' a a sfId = sf- where- sf = SFArr (\_ a -> (sf, a)) FDI+ where+ sf = SFArr (\_ a -> (sf, a)) FDI -- | SF constructor for the constant function. sfConst :: b -> SF' a b sfConst b = sf- where- sf = SFArr (\_ _ -> (sf, b)) (FDC b)+ where+ sf = SFArr (\_ _ -> (sf, b)) (FDC b) -- 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)+ where+ sf = SFArr (\_ ea -> (sf, case ea of NoEvent -> fne ; _ -> f ea))+ (FDE f fne) -- | SF constructor for a general function. sfArrG :: (a -> b) -> SF' a b sfArrG f = sf- where- sf = SFArr (\_ a -> (sf, f a)) (FDG f)-+ where+ sf = SFArr (\_ a -> (sf, f a)) (FDG f) -- | Versatile zero-order hold SF' with folding. --@@ -209,12 +192,10 @@ -- outputs for the present and the future. 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)+ where+ tf0 NoEvent = (sfEP f c bne, bne)+ tf0 (Event a) = let (c', b, bne') = f c a+ in (sfEP f c' bne', b) -- | Constructor for a zero-order hold SF' with folding. --@@ -227,16 +208,14 @@ -- outputs for the present and the future. 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+ 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 -- | Structured function definition. --@@ -244,10 +223,10 @@ -- specific constructors for the identity, constant and event-based -- functions, helping optimise arrow combinators for special cases. 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+ 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 -- | Turns a function into a structured function. fdFun :: FunDesc a b -> (a -> b)@@ -263,13 +242,13 @@ fdComp (FDC b) fd2 = FDC ((fdFun fd2) b) fdComp _ (FDC c) = FDC c fdComp (FDE f1 f1ne) fd2 = FDE (f2 . f1) (f2 f1ne)- where- f2 = fdFun fd2+ where+ f2 = fdFun fd2 fdComp (FDG f1) (FDE f2 f2ne) = FDG f- where- f a = case f1 a of- NoEvent -> f2ne- f1a -> f2 f1a+ where+ f a = case f1 a of+ NoEvent -> f2ne+ f1a -> f2 f1a fdComp (FDG f1) fd2 = FDG (fdFun fd2 . f1) -- | Parallel application of structured functions.@@ -291,14 +270,13 @@ 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)+ where+ f1f2 NoEvent = f1f2ne+ f1f2 ea@(Event _) = (f1 ea, f2 ea) - f1f2ne = (f1ne, f2ne)+ f1f2ne = (f1ne, f2ne) fdFanOut fd1 fd2 =- FDG (\a -> ((fdFun fd1) a, (fdFun fd2) a))-+ 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.@@ -312,16 +290,13 @@ "vfyNoEv" "Assertion failed: Functions on events must not map NoEvent to Event." ----------------------------------------------------------------------------------- Arrow instance and implementation-------------------------------------------------------------------------------+-- * Arrow instance and implementation #if __GLASGOW_HASKELL__ >= 610 -- | Composition and identity for SFs. instance Control.Category.Category SF where- (.) = flip compPrim- id = SF $ \x -> (sfId,x)+ (.) = flip compPrim+ id = SF $ \x -> (sfId,x) #endif -- | Choice of which SF to run based on the value of a signal.@@ -329,11 +304,11 @@ -- (+++) :: forall b c b' c' -- . SF b c -> SF d e -> SF (Either b d) (Either c e) sfL +++ sfR = SF $ \a ->- case a of- Left b -> let (sf', c) = sfTF sfL b- in (chooseL sf' sfR, Left c)- Right d -> let (sf', e) = sfTF sfR d- in (chooseR sfL sf', Right e)+ case a of+ Left b -> let (sf', c) = sfTF sfL b+ in (chooseL sf' sfR, Left c)+ Right d -> let (sf', e) = sfTF sfR d+ in (chooseR sfL sf', Right e) where @@ -367,20 +342,18 @@ Right d -> let (sf', e) = sfTF' sfCR dt d in (choose sfCL sf', Right e) -- -- | Signal Functions as Arrows. See "The Yampa Arcade", by Courtney, Nilsson -- and Peterson. instance Arrow SF where- arr = arrPrim- first = firstPrim- second = secondPrim- (***) = parSplitPrim- (&&&) = parFanOutPrim+ arr = arrPrim+ first = firstPrim+ second = secondPrim+ (***) = parSplitPrim+ (&&&) = parFanOutPrim #if __GLASGOW_HASKELL__ >= 610 #else- (>>>) = compPrim+ (>>>) = compPrim #endif -- | Functor instance for applied SFs.@@ -393,7 +366,6 @@ pure x = arr (const x) f <*> x = (f &&& x) >>> arr (uncurry ($)) - -- * Lifting. -- | Lifts a pure function into a signal function (applied pointwise).@@ -407,7 +379,6 @@ arrEPrim :: (Event a -> b) -> SF (Event a) b arrEPrim f = SF {sfTF = \a -> (sfArrE f (f NoEvent), f a)} - -- * Composition. -- | SF Composition@@ -420,11 +391,11 @@ -- arr f >>> arr g = arr (g . f) 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+ 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.@@ -441,92 +412,82 @@ cpXX sf1 (SFArr _ fd2) = cpXA sf1 fd2 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')+ 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)+ 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) 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')+ 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') cpXX (SFEP _ f1 s1 bne) (SFEP _ f2 s2 cne) = sfEP f (s1, s2, cne) (vfyNoEv bne cne)- where- -- 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.- 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."+ where+ -- 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.+ 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." cpXX sf1@(SFEP{}) (SFCpAXA _ (FDE f21 f21ne) sf22 fd23) =- cpXX (cpXE sf1 f21 f21ne) (cpXA sf22 fd23)+ cpXX (cpXE sf1 f21 f21ne) (cpXA sf22 fd23) cpXX sf1@(SFEP{}) (SFCpAXA _ (FDG f21) sf22 fd23) =- cpXX (cpXG sf1 f21) (cpXA sf22 fd23)+ cpXX (cpXG sf1 f21) (cpXA sf22 fd23) cpXX (SFCpAXA _ fd11 sf12 (FDE f13 f13ne)) sf2@(SFEP{}) =- cpXX (cpAX fd11 sf12) (cpEX f13 f13ne sf2)+ cpXX (cpAX fd11 sf12) (cpEX f13 f13ne 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+ -- 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 cpXX sf1 sf2 = SF' tf -- False- where- tf dt a = (cpXX sf1' sf2', c)- where- (sf1', b) = (sfTF' sf1) dt a- (sf2', c) = (sfTF' sf2) dt b-+ where+ tf dt a = (cpXX sf1' sf2', c)+ where+ (sf1', b) = (sfTF' sf1) dt a+ (sf2', c) = (sfTF' sf2) dt b 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@@ -537,25 +498,25 @@ 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+ 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 - where- tf dt a = (cpAXAAux fd1 f1 fd3 f3 sf2', f3 c)- where- (sf2', c) = (sfTF' sf2) dt (f1 a)+ where+ tf dt a = (cpAXAAux 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@@ -576,150 +537,141 @@ 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+ cpCXA ((fdFun fd21) b) sf22 fd23 cpCX b sf2 = SFCpAXA tf (FDC b) sf2 FDI- where- tf dt _ = (cpCX b sf2', c)- where- (sf2', c) = (sfTF' sf2) dt b-+ where+ tf dt _ = (cpCX 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-- -- 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- where- tf dt _ = (cpCXAAux fd1 b fd3 f3 sf2', f3 c)- where- (sf2', c) = (sfTF' sf2) dt b-+ where+ -- 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+ where+ tf dt _ = (cpCXAAux 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- where- tf dt a = (cpGXAux fd1 f1 sf2', c)- where- (sf2', c) = (sfTF' sf2) dt (f1 a)-+ 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+ where+ tf dt a = (cpGXAux 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- where- tf dt a = (cpXGAux fd2 f2 sf1', f2 b)- where- (sf1', b) = (sfTF' sf1) dt a-+ 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+ where+ tf dt a = (cpXGAux 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- 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)-+ 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+ 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) 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- where- tf dt a = (cpXEAux fd2 f2 f2ne sf1',- case eb of NoEvent -> f2ne; _ -> f2 eb)- where- (sf1', eb) = (sfTF' sf1) dt a-+ 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+ where+ tf dt a = ( cpXEAux fd2 f2 f2ne sf1'+ , case eb of NoEvent -> f2ne; _ -> f2 eb+ )+ where+ (sf1', eb) = (sfTF' sf1) dt a -- * Widening. @@ -731,43 +683,38 @@ -- (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-+ where+ tf0 ~(a0, c0) = (fpAux sf1, (b0, c0))+ where+ (sf1, b0) = tf10 a0 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- where- tf dt ~(a, c) = (fpAux sf1', (b, c))- where- (sf1', b) = (sfTF' sf1) dt a-+ where+ tf dt ~(a, c) = (fpAux 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-+ where+ tf0 ~(c0, a0) = (spAux sf1, (c0, b0))+ where+ (sf1, b0) = tf10 a0 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- where- tf dt ~(c, a) = (spAux sf1', (c, b))- where- (sf1', b) = (sfTF' sf1) dt a--+ where+ tf dt ~(c, a) = (spAux sf1', (c, b))+ where+ (sf1', b) = (sfTF' sf1) dt a -- * Parallel composition. @@ -781,168 +728,164 @@ -- 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<X><Y> where <X> and <Y> is one of:- -- X - arbitrary signal function- -- A - arbitrary pure arrow- -- C - constant arrow+ where+ tf0 ~(a0, c0) = (psXX sf1 sf2, (b0, d0))+ where+ (sf1, b0) = tf10 a0+ (sf2, d0) = tf20 c0 - 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)- psXX sf1 sf2 = SF' tf- where- tf dt ~(a, c) = (psXX sf1' sf2', (b, d))- where- (sf1', b) = (sfTF' sf1) dt a- (sf2', d) = (sfTF' sf2) dt c+ -- Naming convention: ps<X><Y> where <X> and <Y> is one of:+ -- X - arbitrary signal function+ -- A - arbitrary pure arrow+ -- C - constant arrow - psCX :: b -> SF' c d -> SF' (a,c) (b,d)- psCX b (SFArr _ fd2) = sfArr (fdPar (FDC b) fd2)- psCX b sf2 = SF' tf- where- tf dt ~(_, c) = (psCX b sf2', (b, d))- where- (sf2', d) = (sfTF' sf2) dt c+ 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)+ psXX sf1 sf2 = SF' tf+ where+ tf dt ~(a, c) = (psXX sf1' sf2', (b, d))+ where+ (sf1', b) = (sfTF' sf1) dt a+ (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- where- tf dt ~(a, _) = (psXC sf1' d, (b, d))- where- (sf1', b) = (sfTF' sf1) dt a+ psCX :: b -> SF' c d -> SF' (a,c) (b,d)+ psCX b (SFArr _ fd2) = sfArr (fdPar (FDC b) fd2)+ psCX b sf2 = SF' tf+ where+ tf dt ~(_, c) = (psCX b sf2', (b, d))+ where+ (sf2', d) = (sfTF' sf2) dt c - 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- where- tf dt ~(a, c) = (psAX f1 sf2', (f1 a, 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+ where+ tf dt ~(a, _) = (psXC sf1' d, (b, d))+ where+ (sf1', b) = (sfTF' sf1) dt a - 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- where- tf dt ~(a, c) = (psXA sf1' f2, (b, f2 c))- 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+ where+ tf dt ~(a, c) = (psAX 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+ where+ tf dt ~(a, c) = (psXA sf1' f2, (b, f2 c))+ where+ (sf1', b) = (sfTF' sf1) dt a 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<X><Y> where <X> and <Y> 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)- pfoXX sf1 sf2 = SF' tf- where- tf dt a = (pfoXX sf1' sf2', (b, c))- where- (sf1', b) = (sfTF' sf1) dt a- (sf2', c) = (sfTF' sf2) dt a+ where+ tf0 a0 = (pfoXX sf1 sf2, (b0, c0))+ where+ (sf1, b0) = tf10 a0+ (sf2, c0) = tf20 a0 - pfoIX :: SF' a c -> SF' a (a ,c)- pfoIX (SFArr _ fd2) = sfArr (fdFanOut FDI fd2)- pfoIX sf2 = SF' tf- where- tf dt a = (pfoIX sf2', (a, c))- where- (sf2', c) = (sfTF' sf2) dt a+ -- Naming convention: pfo<X><Y> where <X> and <Y> is one of:+ -- X - arbitrary signal function+ -- A - arbitrary pure arrow+ -- I - identity arrow+ -- C - constant arrow - pfoXI :: SF' a b -> SF' a (b ,a)- pfoXI (SFArr _ fd1) = sfArr (fdFanOut fd1 FDI)- pfoXI sf1 = SF' tf- where- tf dt a = (pfoXI sf1', (b, a))- where- (sf1', b) = (sfTF' sf1) dt a+ 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)+ pfoXX sf1 sf2 = SF' tf+ where+ tf dt a = (pfoXX sf1' sf2', (b, c))+ where+ (sf1', b) = (sfTF' sf1) dt a+ (sf2', c) = (sfTF' sf2) 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- where- tf dt a = (pfoCX b sf2', (b, c))- where- (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+ where+ tf dt a = (pfoIX sf2', (a, 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- where- tf dt a = (pfoXC sf1' c, (b, c))- where- (sf1', b) = (sfTF' sf1) dt a+ pfoXI :: SF' a b -> SF' a (b ,a)+ pfoXI (SFArr _ fd1) = sfArr (fdFanOut fd1 FDI)+ pfoXI sf1 = SF' tf+ where+ tf dt a = (pfoXI sf1', (b, a))+ 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- where- tf dt a = (pfoAX f1 sf2', (f1 a, c))- where- (sf2', c) = (sfTF' sf2) 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+ where+ tf dt a = (pfoCX 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+ where+ tf dt a = (pfoXC sf1' c, (b, c))+ where+ (sf1', b) = (sfTF' sf1) 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- where- tf dt a = (pfoXA sf1' f2, (b, f2 a))- 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+ where+ tf dt a = (pfoAX 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+ where+ tf dt a = (pfoXA sf1' f2, (b, f2 a))+ where+ (sf1', b) = (sfTF' sf1) dt a -- * ArrowLoop instance and implementation -- | Creates a feedback loop without delay. instance ArrowLoop SF where- loop = loopPrim+ 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- where- tf dt a = (loopAux sf1', b)- where- (sf1', (b, c)) = (sfTF' sf1) dt (a, c)+ 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+ where+ tf dt a = (loopAux sf1', b)+ where+ (sf1', (b, c)) = (sfTF' sf1) dt (a, c) -- * Scanning @@ -954,11 +897,8 @@ -- internally. 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')---- Vim modeline--- vim:set tabstop=8 expandtab:+ 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')
src/FRP/Yampa/Loop.hs view
@@ -9,11 +9,13 @@ -- Portability : non-portable -GHC extensions- -- -- Well-initialised loops-module FRP.Yampa.Loop (- -- * 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-) where+module FRP.Yampa.Loop+ (+ -- * Loops with guaranteed well-defined feedback+ loopPre+ , loopIntegral+ )+ where import Control.Arrow import Data.VectorSpace@@ -33,6 +35,3 @@ -- well defined. loopIntegral :: VectorSpace c s => SF (a,c) (b,c) -> SF a b loopIntegral sf = loop (second integral >>> sf)---- Vim modeline--- vim:set tabstop=8 expandtab:
src/FRP/Yampa/Random.hs view
@@ -10,20 +10,18 @@ -- Signals and signal functions with noise and randomness. -- -- The Random number generators are re-exported from "System.Random".-module FRP.Yampa.Random (-- -- * Random number generators- RandomGen(..),- Random(..),-- -- * Noise, random signals, 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)+module FRP.Yampa.Random+ (+ -- * Random number generators+ RandomGen(..)+ , Random(..) -) where+ -- * Noise, random signals, and stochastic event sources+ , noise+ , noiseR+ , occasionally+ )+ where import System.Random (Random (..), RandomGen (..)) @@ -31,32 +29,28 @@ import FRP.Yampa.Event import FRP.Yampa.InternalCore (SF (..), SF' (..), Time) ---------------------------------------------------------------------------------- Noise (i.e. random signal generators) and stochastic processes-------------------------------------------------------------------------------+-- * 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) - streamToSF :: [b] -> SF a b streamToSF [] = intErr "AFRP" "streamToSF" "Empty list!" streamToSF (b:bs) = SF {sfTF = tf0}- where- tf0 _ = (stsfAux bs, b)+ 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)+ stsfAux [] = intErr "AFRP" "streamToSF" "Empty list!"+ -- Invarying since stsfAux [] is an error.+ stsfAux (b:bs) = SF' tf -- True+ where+ tf _ _ = (stsfAux 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@@ -68,24 +62,19 @@ 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.+ 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+ 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)----- Vim modeline--- vim:set tabstop=8 expandtab:
src/FRP/Yampa/Scan.hs view
@@ -13,10 +13,11 @@ -- functions by means of an auxiliary function applied to each input and to an -- accumulator. For comparison with other FRP libraries and with stream -- processing abstractions, think of fold.-module FRP.Yampa.Scan (- sscan, -- :: (b -> a -> b) -> b -> SF a b- sscanPrim, -- :: (c -> a -> Maybe (c, b)) -> c -> b -> SF a b-) where+module FRP.Yampa.Scan+ ( sscan+ , sscanPrim+ )+ where import FRP.Yampa.InternalCore (SF(..), sfSScan) @@ -26,8 +27,8 @@ -- creates a well-formed loop based on a pure, auxiliary function. 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')+ where+ f' b a = let b' = f b a in Just (b', b') -- | Generic version of 'sscan', in which the auxiliary function produces -- an internal accumulator and an "held" output.@@ -38,10 +39,7 @@ -- pure, auxiliary function. 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')---- Vim modeline--- vim:set tabstop=8 expandtab:+ 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')
src/FRP/Yampa/Simulation.hs view
@@ -30,43 +30,30 @@ -- -- This module also includes debugging aids needed to execute signal functions -- step by step, which are used by Yampa's testing facilities.-module FRP.Yampa.Simulation (- -- * Reactimation- reactimate, -- :: IO a- -- -> (Bool -> IO (DTime, Maybe a))- -- -> (Bool -> b -> IO Bool)- -- -> SF a b- -- -> IO ()-- -- ** Low-level reactimation interface- 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- 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)])+module FRP.Yampa.Simulation+ (+ -- * Reactimation+ reactimate - -- * Debugging / Step by step simulation+ -- ** Low-level reactimation interface+ , ReactHandle+ , reactInit+ , react - FutureSF,- evalAtZero,- evalAt,- evalFuture,+ -- * Embedding+ , embed+ , embedSynch+ , deltaEncode+ , deltaEncodeBy + -- * Debugging / Step by step simulation -) where+ , FutureSF+ , evalAtZero+ , evalAt+ , evalFuture+ )+ where import Control.Monad (unless) import Data.IORef@@ -75,10 +62,7 @@ import FRP.Yampa.Diagnostics import FRP.Yampa.InternalCore (DTime, SF (..), SF' (..), sfTF') ----------------------------------------------------------------------------------- Reactimation-------------------------------------------------------------------------------+-- * Reactimation -- | Convenience function to run a signal function indefinitely, using a IO -- actions to obtain new input and process the output.@@ -110,30 +94,28 @@ -- action -> SF a b -- ^ Signal function -> m ()-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' = fromMaybe a ma'- (sf', b') = (sfTF' sf) dt a'- loop sf' a' b'-+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' = fromMaybe a 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+data ReactState a b = ReactState+ { rsActuate :: ReactHandle a b -> Bool -> b -> IO Bool+ , rsSF :: SF' a b+ , rsA :: a+ , rsB :: b } -- | A reference to reactimate's state, maintained across samples.@@ -145,37 +127,34 @@ -> (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- }- )- let r = ReactHandle r'- _ <- actuate r True b0- return r+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+ }+ )+ let r = ReactHandle r'+ _ <- 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 <- readIORef (reactHandle rh)- let ReactState {rsActuate = actuate, rsSF = sf, rsA = a, rsB = _b } = rs-- let a' = fromMaybe a ma'- (sf',b') = (sfTF' sf) dt a'- writeIORef (reactHandle rh) (rs {rsSF = sf',rsA = a',rsB = b'})- done <- actuate rh True b'- return done+react rh (dt,ma') = do+ rs <- readIORef (reactHandle rh)+ let ReactState {rsActuate = actuate, rsSF = sf, rsA = a, rsB = _b } = rs + let a' = fromMaybe a ma'+ (sf',b') = (sfTF' sf) dt a'+ writeIORef (reactHandle rh) (rs {rsSF = sf',rsA = a',rsB = b'})+ done <- actuate rh True b'+ return done ---------------------------------------------------------------------------------- Embedding-------------------------------------------------------------------------------+-- * Embedding -- | Given a signal function and a pair with an initial -- input sample for the input signal, and a list of sampling@@ -185,50 +164,45 @@ -- This is a simplified, purely-functional version of 'reactimate'. 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 = fromMaybe a_prev ma- (sf', b) = (sfTF' sf) dt a+ 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 = fromMaybe a_prev 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. 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)+ where+ tts = scanl (\t (dt, _) -> t + dt) 0 dtas+ bbs@(b:_) = embed sf0 (a0, dtas) - 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)+ tf0 _ = (esAux 0 (zip tts bbs), 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+ 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 -- | Spaces a list of samples by a fixed time delta, avoiding -- unnecessary samples when the input has not changed since@@ -237,16 +211,14 @@ deltaEncode _ [] = usrErr "AFRP" "deltaEncode" "Empty input list." deltaEncode dt aas@(_:_) = deltaEncodeBy (==) dt aas - -- | 'deltaEncode' parameterized by the equality test. 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-+ where+ debAux _ [] = []+ debAux a_prev (a:as) | a `eq` a_prev = Nothing : debAux a as+ | otherwise = Just a : debAux a as -- * Debugging / Step by step simulation @@ -255,7 +227,6 @@ -- newtype FutureSF a b = FutureSF { unsafeSF :: SF' a b } - -- | Evaluate an SF, and return an output and an initialized SF. -- -- /WARN/: Do not use this function for standard simulation. This function is@@ -268,7 +239,6 @@ evalAtZero (SF { sfTF = tf }) a = (b, FutureSF tf' ) where (tf', b) = tf a - -- | Evaluate an initialized SF, and return an output and a continuation. -- -- /WARN/: Do not use this function for standard simulation. This function is@@ -281,7 +251,6 @@ evalAt (FutureSF { unsafeSF = tf }) dt a = (b, FutureSF tf') where (tf', b) = (sfTF' tf) dt a - -- | Given a signal function and time delta, it moves the signal function into -- the future, returning a new uninitialized SF and the initial output. --@@ -297,13 +266,9 @@ evalFuture sf a dt = (b, sf' dt) where (b, sf') = evalStep sf a - -- | Steps the signal function into the future one step. It returns the current -- output, and a signal function that expects, apart from an input, a time -- between samples. evalStep :: SF a b -> a -> (b, DTime -> SF a b) evalStep (SF sf) a = (b, \dt -> SF (sfTF' sf' dt)) where (sf', b) = sf a---- Vim modeline--- vim:set tabstop=8 expandtab:
src/FRP/Yampa/Switches.hs view
@@ -62,60 +62,37 @@ -- and also helps determine the expected behaviour of a combinator by looking -- at its name. For example, 'drpSwitchB' is the decoupled (/d/), recurrent -- (/r/), parallel (/p/) switch with broadcasting (/B/).-module FRP.Yampa.Switches (- -- * Basic switching- 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+module FRP.Yampa.Switches+ (+ -- * Basic switching+ switch, dSwitch+ , rSwitch, drSwitch+ , kSwitch, dkSwitch - -- * Parallel composition\/switching (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\/switching (collections)+ -- ** With broadcasting+ , parB+ , pSwitchB,dpSwitchB+ , rpSwitchB,drpSwitchB - -- ** With helper routing function- 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)- --- -- * Parallel composition\/switching (lists)- --- -- ** 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]+ -- ** With helper routing function+ , par+ , pSwitch, dpSwitch+ , rpSwitch,drpSwitch - -- ** With replication- parC, -- SF a b -> SF [a] [b]+ -- * Parallel composition\/switching (lists)+ --+ -- ** With "zip" routing+ , parZ+ , pSwitchZ+ , dpSwitchZ+ , rpSwitchZ+ , drpSwitchZ -) where+ -- ** With replication+ , parC+ )+ where import Control.Arrow @@ -125,9 +102,8 @@ import FRP.Yampa.InternalCore (DTime, FunDesc (..), SF (..), SF' (..), fdFun, sfArrG, sfConst, sfTF') ---------------------------------------------------------------------------------- Basic switches-------------------------------------------------------------------------------+-- * Basic switches+ -- | Basic switch. -- -- By default, the first signal function is applied. Whenever the second value@@ -146,35 +122,34 @@ -- of switching! 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- where- tf dt a =- case (sfTF' sf1) dt a of- (sf1', (b, NoEvent)) -> (switchAux sf1' k, b)- (_, (_, Event c)) -> sfTF (k c) a+ where+ tf0 a0 =+ case tf10 a0 of+ (sf1, (b0, NoEvent)) -> (switchAux sf1 k, b0)+ (_, (_, Event c0)) -> sfTF (k c0) a0 - -- 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+ -- 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+ where+ tf dt a =+ case (sfTF' sf1) dt a of+ (sf1', (b, NoEvent)) -> (switchAux sf1' k, b)+ (_, (_, Event c)) -> sfTF (k c) a + -- 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. --@@ -201,43 +176,43 @@ -- of switching! 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- 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: 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),+ 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+ ) - b)+ -- 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+ 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: 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. --@@ -249,7 +224,6 @@ rSwitch :: SF a b -> SF (a, Event (SF a b)) b rSwitch sf = switch (first sf) ((noEventSnd >=-) . rSwitch) - -- | Recurring switch with delayed observation. -- -- Uses the given SF until an event comes in the input, in which case the SF in@@ -262,7 +236,6 @@ drSwitch :: SF a b -> SF (a, Event (SF a b)) b drSwitch sf = dSwitch (first sf) ((noEventSnd >=-) . drSwitch) - -- | Call-with-current-continuation switch. -- -- Applies the first SF until the input signal and the output signal, when@@ -273,79 +246,73 @@ -- information on how this switch works. 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-- kSwitchAux (SFArr _ (FDC b)) sfe = kSwitchAuxC1 b sfe- kSwitchAux (SFArr _ fd1) sfe = kSwitchAuxA1 (fdFun fd1) sfe- kSwitchAux sf1 (SFArr _ (FDC NoEvent)) = sf1- kSwitchAux sf1 (SFArr _ fde) = kSwitchAuxAE sf1 (fdFun fde)- 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+ 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 - -- !!! Untested optimization!- kSwitchAuxC1 b (SFArr _ (FDC NoEvent)) = sfConst b- kSwitchAuxC1 b (SFArr _ fde) = kSwitchAuxC1AE b (fdFun fde)- 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+ kSwitchAux (SFArr _ (FDC b)) sfe = kSwitchAuxC1 b sfe+ kSwitchAux (SFArr _ fd1) sfe = kSwitchAuxA1 (fdFun fd1) sfe+ kSwitchAux sf1 (SFArr _ (FDC NoEvent)) = sf1+ kSwitchAux sf1 (SFArr _ fde) = kSwitchAuxAE sf1 (fdFun fde)+ 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!- kSwitchAuxA1 f1 (SFArr _ (FDC NoEvent)) = sfArrG f1- kSwitchAuxA1 f1 (SFArr _ fde) = kSwitchAuxA1AE f1 (fdFun fde)- 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!+ kSwitchAuxC1 b (SFArr _ (FDC NoEvent)) = sfConst b+ kSwitchAuxC1 b (SFArr _ fde) = kSwitchAuxC1AE b (fdFun fde)+ 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!- kSwitchAuxAE (SFArr _ (FDC b)) fe = kSwitchAuxC1AE b fe- kSwitchAuxAE (SFArr _ fd1) fe = kSwitchAuxA1AE (fdFun fd1) 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!+ kSwitchAuxA1 f1 (SFArr _ (FDC NoEvent)) = sfArrG f1+ kSwitchAuxA1 f1 (SFArr _ fde) = kSwitchAuxA1AE f1 (fdFun fde)+ 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!- 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!+ kSwitchAuxAE (SFArr _ (FDC b)) fe = kSwitchAuxC1AE b fe+ kSwitchAuxAE (SFArr _ fd1) fe = kSwitchAuxA1AE (fdFun fd1) 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!- 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+ -- !!! 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. --@@ -359,35 +326,33 @@ -- information on how this switch works. 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)+ 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-------------------------------------------------------------------------------+-- * Parallel composition and switching over collections with broadcasting -- | Tuple a value up with every element of a collection of signal -- functions. broadcast :: Functor col => a -> col sf -> col (a, sf) broadcast a = fmap (\sf -> (a, sf)) - -- | Spatial parallel composition of a signal function collection. -- Given a collection of signal functions, it returns a signal -- function that broadcasts its input signal to every element@@ -455,9 +420,7 @@ 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-------------------------------------------------------------------------------+-- * Parallel composition and switching over collections with general routing -- | Spatial parallel composition of a signal function collection parameterized -- on the routing function.@@ -471,15 +434,13 @@ -- ^ Signal function collection. -> 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)-+ 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 switchers. parAux :: Functor col =>@@ -487,15 +448,13 @@ -> 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)-+ 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@@ -518,30 +477,27 @@ -- ^ Continuation to be invoked once event occurs. -> 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+ 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.@@ -576,33 +532,29 @@ -- switched back in, typically by employing 'dpSwitch' again. -> 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)+ 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. --@@ -625,9 +577,8 @@ -- ^ Initial signal function collection. -> 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')-+ pSwitch (rf . fst) sfs (arr (snd . fst)) $ \sfs' f ->+ noEventSnd >=- rpSwitch rf (f sfs') -- | Recurring parallel switch with delayed observation parameterized on the -- routing function.@@ -651,12 +602,10 @@ -- ^ Initial signal function collection. -> 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')+ dpSwitch (rf . fst) sfs (arr (snd . fst)) $ \sfs' f ->+ noEventSnd >=- drpSwitch rf (f sfs') ------------------------------------------------------------------------------- -- * Parallel composition/switchers with "zip" routing------------------------------------------------------------------------------- -- | Parallel composition of a list of SFs. --@@ -747,7 +696,6 @@ err :: a err = usrErr "FRP.Yampa.Switches" fn "Input list too short." - -- 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@@ -785,13 +733,12 @@ -- Internal definition. Also used in parallel switchers. parCAux :: [SF' a b] -> SF' [a] [b] parCAux sfs = SF' tf- where- tf dt as =- let os = map (\(a,sf) -> sfTF' sf dt a) $ safeZip "parC" as sfs- bs = map snd os- sfcs = map fst os- in- (listSeq sfcs `seq` parCAux sfcs, listSeq bs)+ where+ tf dt as =+ let os = map (\(a,sf) -> sfTF' sf dt a) $ safeZip "parC" as sfs+ bs = map snd os+ sfcs = map fst os+ in (listSeq sfcs `seq` parCAux sfcs, listSeq bs) listSeq :: [a] -> [a] listSeq x = x `seq` (listSeq' x)@@ -799,6 +746,3 @@ listSeq' :: [a] -> [a] listSeq' [] = [] listSeq' rs@(a:as) = a `seq` listSeq' as `seq` rs---- Vim modeline--- vim:set tabstop=8 expandtab:
src/FRP/Yampa/Task.hs view
@@ -10,18 +10,19 @@ -- 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)-) where+module FRP.Yampa.Task+ ( Task+ , mkTask+ , runTask+ , runTask_+ , taskToSF+ , constT+ , sleepT+ , snapT+ , timeOut+ , abortWhen+ )+ where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative (Applicative(..))@@ -36,18 +37,16 @@ infixl 0 `timeOut`, `abortWhen` - -- * The Task type - -- | A task is a partially SF that may terminate with a result. newtype Task a b c =- -- CPS-based representation allowing 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.- Task (forall d . (c -> SF a (Either b d)) -> SF a (Either b d))+ -- CPS-based representation allowing 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.+ 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@@ -57,7 +56,6 @@ mkTask :: SF a (b, Event c) -> Task a b c mkTask st = Task (switch (st >>> first (arr Left))) - -- | Runs a task. -- -- The output from the resulting signal transformer is tagged with Left while@@ -69,7 +67,6 @@ runTask :: Task a b c -> SF a (Either b c) runTask tk = (unTask tk) (constant . Right) - -- | Runs a task that never terminates. -- -- The output becomes undefined once the underlying task has terminated.@@ -80,7 +77,6 @@ >>> arr (either id (usrErr "AFRPTask" "runTask_" "Task terminated!")) - -- | Creates an SF that represents an SF and produces an event -- when the task terminates, and otherwise produces just an output. taskToSF :: Task a b c -> SF a (b, Event c)@@ -88,54 +84,53 @@ >>> (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-+ where+ isEdge (Left _) (Left _) = Nothing+ isEdge (Left _) (Right c) = Just c+ isEdge (Right _) (Right _) = Nothing+ isEdge (Right _) (Left _) = Nothing -- * Functor, Applicative and Monad instance instance Functor (Task a b) where- fmap f tk = Task (\k -> unTask tk (k . f))+ fmap f tk = Task (\k -> unTask tk (k . f)) instance Applicative (Task a b) where- pure x = Task (\k -> k x)- f <*> v = Task (\k -> (unTask f) (\c -> unTask v (k . c)))+ pure x = Task (\k -> k x)+ f <*> v = Task (\k -> (unTask f) (\c -> unTask v (k . c))) instance Monad (Task a b) where- tk >>= f = Task (\k -> unTask tk (\c -> unTask (f c) k))- return x = Task (\k -> k x)+ 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+-- 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+-- 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+-- (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). @@ -145,12 +140,10 @@ 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. --@@ -161,15 +154,13 @@ 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)))+ 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.@@ -185,5 +176,5 @@ -- 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)))+ where+ aux ((b, ec), ed) = (b, (lMerge (fmap Left ec) (fmap Right ed)))
src/FRP/Yampa/Time.hs view
@@ -20,10 +20,11 @@ -- produce the value one (@1@). If you really, really, really need to know the -- time delta, and need to abandon the hybrid\/FRP abstraction, see -- 'FRP.Yampa.Integration.iterFrom'.-module FRP.Yampa.Time (- localTime, -- :: SF a Time- time, -- :: SF a Time, Other name for localTime.-) where+module FRP.Yampa.Time+ ( localTime+ , time+ )+ where import Control.Arrow @@ -38,6 +39,3 @@ -- | Alternative name for localTime. time :: SF a Time time = localTime---- Vim modeline--- vim:set tabstop=8 expandtab:
tests/HaddockCoverage.hs view
@@ -1,4 +1,3 @@------------------------------------------------------------------------------ -- | -- Module : Main (HaddockCoverage) -- Copyright : (C) 2015 Ivan Perez@@ -13,7 +12,6 @@ -- -- Run haddock on a source tree and report if anything in any -- module is not documented.------------------------------------------------------------------------------ module Main where import Control.Applicative
tests/hlint.hs view
@@ -1,4 +1,3 @@------------------------------------------------------------------------------ -- | -- Module : Main (hlint) -- Copyright : (C) 2013 Edward Kmett@@ -8,7 +7,6 @@ -- Portability : portable -- -- This module runs HLint on the lens source tree.------------------------------------------------------------------------------ module Main where import Control.Monad