Yampa (empty) → 0.9.1.1
raw patch · 52 files changed
+7688/−0 lines, 52 filesdep +basedep +haskell98setup-changed
Dependencies added: base, haskell98
Files
- LICENSE.txt +29/−0
- Setup.hs +8/−0
- Yampa.cabal +56/−0
- examples/Setup.lhs +3/−0
- examples/TailgatingDetector/TailgatingDetector.hs +322/−0
- examples/TailgatingDetector/TestTGMain.hs +102/−0
- examples/examples.cabal +20/−0
- src/AFRP.hs +1546/−0
- src/AFRPAffineSpace.hs +41/−0
- src/AFRPDiagnostics.hs +19/−0
- src/AFRPEvent.hs +286/−0
- src/AFRPForceable.hs +76/−0
- src/AFRPGeometry.hs +30/−0
- src/AFRPInternals.hs +37/−0
- src/AFRPMergeableRecord.hs +78/−0
- src/AFRPMiscellany.hs +121/−0
- src/AFRPPoint2.hs +60/−0
- src/AFRPPoint3.hs +67/−0
- src/AFRPTask.hs +219/−0
- src/AFRPUtilities.hs +278/−0
- src/AFRPVector2.hs +100/−0
- src/AFRPVector3.hs +118/−0
- src/AFRPVectorSpace.hs +158/−0
- tests/AFRPTests.hs +176/−0
- tests/AFRPTestsAccum.hs +205/−0
- tests/AFRPTestsArr.hs +52/−0
- tests/AFRPTestsBasicSF.hs +69/−0
- tests/AFRPTestsCOC.hs +56/−0
- tests/AFRPTestsCommon.hs +165/−0
- tests/AFRPTestsComp.hs +71/−0
- tests/AFRPTestsDelay.hs +39/−0
- tests/AFRPTestsDer.hs +55/−0
- tests/AFRPTestsEmbed.hs +61/−0
- tests/AFRPTestsEvSrc.hs +430/−0
- tests/AFRPTestsFirstSecond.hs +125/−0
- tests/AFRPTestsKSwitch.hs +128/−0
- tests/AFRPTestsLaws.hs +89/−0
- tests/AFRPTestsLoop.hs +206/−0
- tests/AFRPTestsLoopIntegral.hs +104/−0
- tests/AFRPTestsLoopLaws.hs +107/−0
- tests/AFRPTestsLoopPre.hs +62/−0
- tests/AFRPTestsPSwitch.hs +325/−0
- tests/AFRPTestsRPSwitch.hs +246/−0
- tests/AFRPTestsRSwitch.hs +144/−0
- tests/AFRPTestsReact.hs +70/−0
- tests/AFRPTestsSwitch.hs +214/−0
- tests/AFRPTestsTask.hs +217/−0
- tests/AFRPTestsUtils.hs +276/−0
- tests/AFRPTestsWFG.hs +103/−0
- tests/Setup.lhs +3/−0
- tests/testAFRP.cabal +45/−0
- tests/testAFRPMain.hs +71/−0
+ LICENSE.txt view
@@ -0,0 +1,29 @@+Copyright (c) 2003, Henrik Nilsson, Antony Courtney and Yale University. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +- Neither name of the copyright holders nor the names of its +contributors may be used to endorse or promote products derived from +this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDERS OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS +OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR +TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,8 @@++module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain+
+ Yampa.cabal view
@@ -0,0 +1,56 @@+Name: Yampa+Version: 0.9.1.1+License: BSD3+License-File: LICENSE.txt+Copyright: Henrik Nilsson, Antony Courtney and Yale University, (c) 2003+Author: Antony Courtney, Paul Hudak, Henrik Nilsson, John Peterson+Maintainer: Antony Courtney <antony@apocalypse.org>, Paul Hudak <paul.hudak@yale.edu>, Henrik Nilsson <nilsson@cs.yale.edu>, John Peterson <peterson-john@cs.yale.edu>+Stability: provisional+Homepage: http://www.haskell.org/yampa/+Category: Reactivity, FRP+Synopsis: Library for programming hybrid systems.+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. So, this library is known as AFRP (Arrowized FRP).+ .+ This package is just cabalizing afrp-0.4. This isn't GADTed version, and doesn't include any extensions. If you want to see and use GADTed version, you must download higher version.+Build-Type: Simple+Tested-With: GHC+Extra-Source-Files:+ tests/AFRPTests.hs, tests/AFRPTestsFirstSecond.hs, tests/AFRPTestsSwitch.hs,+ tests/AFRPTestsAccum.hs, tests/AFRPTestsKSwitch.hs, tests/AFRPTestsTask.hs,+ tests/AFRPTestsArr.hs, tests/AFRPTestsLaws.hs, tests/AFRPTestsUtils.hs,+ tests/AFRPTestsBasicSF.hs, tests/AFRPTestsLoop.hs, tests/AFRPTestsWFG.hs,+ tests/AFRPTestsCOC.hs, tests/AFRPTestsLoopIntegral.hs, tests/AFRPTestsCommon.hs,+ tests/AFRPTestsLoopLaws.hs, tests/AFRPTestsComp.hs, tests/AFRPTestsLoopPre.hs,+ tests/AFRPTestsDelay.hs, tests/AFRPTestsPSwitch.hs, tests/AFRPTestsDer.hs,+ tests/AFRPTestsRPSwitch.hs, tests/AFRPTestsEmbed.hs, tests/AFRPTestsRSwitch.hs,+ tests/AFRPTestsEvSrc.hs, tests/AFRPTestsReact.hs, tests/testAFRPMain.hs,+ tests/Setup.lhs, tests/testAFRP.cabal,++ examples/Setup.lhs, examples/examples.cabal,+ examples/TailgatingDetector/TailgatingDetector.hs,+ examples/TailgatingDetector/TestTGMain.hs++Build-Depends: base, haskell98+GHC-Options : -O2+Hs-Source-Dirs: src+Extensions: MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, PolymorphicComponents, RankNTypes+Exposed-modules:+ AFRP, + AFRPAffineSpace, + AFRPDiagnostics,+ AFRPEvent,+ AFRPForceable,+ AFRPGeometry,+ AFRPInternals,+ AFRPMiscellany,+ AFRPMergeableRecord,+ AFRPPoint2,+ AFRPPoint3,+ AFRPTask,+ AFRPUtilities,+ AFRPVector2,+ AFRPVector3,+ AFRPVectorSpace
+ examples/Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ examples/TailgatingDetector/TailgatingDetector.hs view
@@ -0,0 +1,322 @@+{-+******************************************************************************+* A F R P *+* *+* Module: TailgatingDetector *+* Purpose: AFRP Expressitivity Test *+* Authors: Henrik Nilsson *+* *+* Copyright (c) Yale University, 2003 *+* *+******************************************************************************+-}++-- Context: an autonomous flying vehicle carrying out traffic surveillance+-- through an on-board video camera.+--+-- Objective: finding a tailgater among a group of vehicles traveling along+-- a highway lane. The group is defined by the section of the highway in+-- view and thus changes dynamically as ground vehicles with non-zero+-- relative speed to the flying vehicles enters or leaves the field of+-- vision.+--+-- Simplifying assumptions:+-- * The positive x-axis of the video images is supposed to correspond to the+-- direction of travel.+-- * The flying vehicle is assumed to travel directly over and along the+-- highway lane when looking for tailgaters. The y-coordinate of the+-- highway is thus roughly 0.+-- * It is enough to consider the x-coordinate of ground vehicle positions.+-- Thus the position and velocity types are both just (signed) Double+-- for our purposes.+--+-- I find this example interesting because it makes use of TWO COLLECTION of+-- signal functions, these collections HAVE TO BE DYNAMIC by the very+-- nature of the problem, and it makes use of the the fact that CONTINUATIONS+-- ARE FIRST CLASS ENTITIES in a way which arguably also is justified+-- by the nature of the problem.++module TailgatingDetector where++import List (sortBy, (\\))++import AFRP+import AFRPUtilities+++------------------------------------------------------------------------------+-- Testing framework+------------------------------------------------------------------------------++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, _) ->+ 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]+++-- 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.+-- The UAVStatus signal provides the current flying height and ground speed+-- which allows the perceived position to be scaled to a position in meters+-- relative to the origin directly under the flying vehicle, and the perceived+-- velocity to be transformed to ground velocity.+type CarTracker = SF (Video, UAVStatus) (Car, Event ())++range = 500++-- Creation of video stream subject to field of view and car trackers+-- 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)++ 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+------------------------------------------------------------------------------++-- Looks at the positions of two cars and determines if the first is+-- tailgating the second. Tailgating is assumed to have occurred if:+-- * the first car is behind the second;+-- * the absolute speed of the first car is greater than 5 m/s;+-- * the relative speed of the cars is within 20 % of the absolute speed;+-- * the first car is no more than 5 s behind the second; and+-- * after 30 s, the average distance between the cars normalized by+-- the absolute speed is less than a second.++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` ()++ 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+------------------------------------------------------------------------------++-- Auxiliary definitions++type Id = Int++data MCTCol a = MCTCol Id [(Id, a)]+++instance Functor MCTCol where+ 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+-- to internal collection of car trackers. A tracker is removed as soon+-- as it looses tracking.+--+-- The output consists of the output from the individual trackers, tagged+-- with an assigned identity unique to each tracker.+--+-- I'M GIVING UP ON THIS BIT FOR NOW+-- The external identity event signals that the car being tracked by the+-- tracker tagged by the identity carried by the event is guilty of+-- tailgating. This causes an event carrying the *continuation* of the+-- corresponding tracker to be generated, e.g. allowing the overall+-- controll system to focus on follwing that particular car without first+-- having to start a new tracker (risking misidentification).++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))++ -- 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++ cts_init :: MCTCol CarTracker+ cts_init = MCTCol 0 []++ addCT :: CarTracker -> MCTCol CarTracker -> MCTCol CarTracker+ addCT ct (MCTCol n icts) = MCTCol (n+1) ((n, ct) : icts)++ delCTs :: [Id] -> MCTCol CarTracker -> MCTCol CarTracker+ delCTs is (MCTCol n icts) =+ MCTCol n (filter (flip notElem is . fst) icts)++ 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+------------------------------------------------------------------------------++-- Auxiliary definitions++newtype MTGDCol a = MTGDCol [((Id,Id), a)]+++instance Functor MTGDCol where+ 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+-- the signal function will figure which old tailgating detectors that have+-- to be removed and which new that have to be started based on an initial+-- sample of the new configuration. An event carrying the identity of+-- a tailgater and the one being tailgated is generated when one of the+-- tailgating signal functions generates an event.++mtgd :: SF [(Id, Car)] (Event [(Id, Id)])+mtgd = proc ics -> do+ let ics' = sortBy relPos ics+ 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++ 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++ 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)])+findTailgaters = proc (v, s, ect) -> do+ ics <- mct -< (v, s, ect)+ etgs <- mtgd -< ics+ returnA -< (ics, etgs)
+ examples/TailgatingDetector/TestTGMain.hs view
@@ -0,0 +1,102 @@+{-+******************************************************************************+* A F R P *+* *+* Example: Test TG *+* Purpose: Testing of the tailgating detector. *+* Authors: Henrik Nilsson *+* *+* Copyright (c) Yale University, 2003 *+* *+******************************************************************************+-}++module Main where++import List (sortBy)++import AFRP+import AFRPUtilities+import AFRPInternals -- Just for testing purposes.++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+++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 ()))+++testMCT :: Time -> [(Time, Event [(Id, Car)])]+testMCT t_max = filter (isEvent . snd) $+ takeWhile (\(t, _) -> t <= t_max) $+ embed (localTime+ &&& (uavStatus+ >>> (highway &&& identity >>> mkVideoAndTrackers)+ &&& 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+++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) $+ embed (localTime+ &&& (proc _ -> do+ s <- uavStatus -< ()+ h <- highway -< ()+ (v, ect) <- mkVideoAndTrackers -< (h, s)+ (ics, etgs) <- findTailgaters -< (v,s,ect) + etgs <- mtgd -< ics+ returnA -< (etgs, ics)))+ (deltaEncode smplPer (repeat ()))++ppTestMTGD t = mapM_ (putStrLn . show) (testMTGD t)+++-- We could read the car specification from standard input.+main = ppTestMTGD 2000
+ examples/examples.cabal view
@@ -0,0 +1,20 @@+Name: examples+Version: 0.0+Description: Yampa examples+License: BSD3+License-File: ../LICENSE.txt+Copyright: Henrik Nilsson, Antony Courtney and Yale University, (c) 2003+Author: Antony Courtney, Paul Hudak, Henrik Nilsson, John Peterson+Maintainer: Antony Courtney <antony@apocalypse.org>, Paul Hudak <paul.hudak@yale.edu>, Henrik Nilsson <nilsson@cs.yale.edu>, John Peterson <peterson-john@cs.yale.edu>+Stability: provisional+Homepage: http://www.haskell.org/yampa/+Category: Reactivity, FRP+Synopsis: Yampa examples+Build-Depends: base, haskell98, Yampa >= 0.9.1 && < 0.9.2++Executable: TailgatingDetector+Main-is: TestTGMain.hs+ghc-options: -O+Extensions: Arrows+Hs-Source-Dirs: TailgatingDetector+Other-modules: TailgatingDetector
+ src/AFRP.hs view
@@ -0,0 +1,1546 @@+{- $Id: AFRP.hs,v 1.37 2004/03/22 19:46:40 antony Exp $+******************************************************************************+* A F R P *+* *+* Module: AFRP *+* Purpose: The AFRP core. *+* Authors: Henrik Nilsson and Antony Courtney *+* *+* Copyright (c) Yale University, 2003 *+* *+******************************************************************************+-}++-- ToDo:+-- * Check embedSynch for space leaks. It might be a good idea to force+-- "dropped frames".+-- * The internal "streamToSignal" is interesting, and a version somehow+-- accepting a time stamped stream/assuming equidistant samples, possibly+-- with an interpolation function, might be even more interesting. Perhaps+-- consider a version that applies "cycle" to the supplied list? Note that+-- there is a relation to "embedSynch" since a partial application of+-- "embedSynch" to "identity" would yield something similar. Or it is+-- in some sense the inverse of "embed".+-- * It seems the use of VectorSpace-based integrals causes more ambiguity+-- problems than before. Investigate (comments in AFRPTest.hs).+-- * Maybe "now", "after", "repeatedly" should return ().+-- There could be a bunch of utilities "nowTag", "afterTag", "repeatedlyTag",+-- and "edgeTag". Decide based on API consistency. E.g. edge already+-- returns ().+-- * Reconsider the semantics of "edgeBy". Does not disallow an edge+-- condition that persists between consecutive samples. OTOH, consider+-- a signal that alternates between two discrete values (True, False, say).+-- Surely we could then see edges on every sample. It's not really for us+-- to say whether the edge detecting function does a good job or not?+-- * We should probably introduce a type synonym Frequency here.+-- It might be most natural to give some parameters in terms of frequency+-- (like for "repeatedly" and "occasionally"). On the other hand, there+-- is "after", and it would be good if "after" and "repeatedly" are+-- mutually consitent, if "repeatedly" and "occsaionally" are consitent,+-- and if the user knows that "Time" is the only dimension he or she needs+-- to worry about.+-- * Here's an argument for why "now", "after", etc. should return "()".+-- The event value has to be a static entity anyway in these cases. So,+-- if we need them to something DYNAMIC, then the extra argument is useless.+-- Or if we don't care. If it is decided to change the interface in that+-- way, I guess we could also change Time to Frequency where that makes+-- sense. On the other hand, what's the point of "now" always returning+-- "()"? Would one not usually want to say what to return? If yes, then+-- There is something to be said for making "after" consitent with "now".+-- After all, we should have "now = after 0".+-- * Maybe "reactimate" should be parameterized on the monad type?+-- * Revisit the "reactimate" interfaces along with embedding.+-- * Revisit integration and differentiation. Valery suggests:+--+-- integral :: VectorSpace a s => SF a a+-- integral = (\ a _ dt v -> v ^+^ realToFrac dt *^ a) `iterFrom`+-- zeroVector+--+-- -- non-delayed integration (using the function's value at the current+-- -- time)+-- ndIntegral :: VectorSpace a s => SF a a+-- ndIntegral = (\ _ a' dt v -> v ^+^ realToFrac dt *^ a') `iterFrom`+-- zeroVector+-- +-- derivative :: VectorSpace a s => SF a a+-- derivative = (\ a a' dt _ -> (a' ^-^ a) ^/ realToFrac dt) `iterFrom`+-- zeroVector+-- +-- iterFrom :: (a -> a -> DTime -> b -> b) -> b -> SF a b+-- f `iterFrom` b = SF (iterAux b) where+-- iterAux b a = (SFTIVar (\ dt a' -> iterAux (f a a' dt b) a'), b)+-- See also the original e-mail discussion.++module AFRP (+-- Re-exported module, classes, and types+ module Control.Arrow,+ module AFRPVectorSpace,+ RandomGen(..),+ Random(..),++-- Reverse function composition and arrow plumbing aids+ ( # ), -- :: (a -> b) -> (b -> c) -> (a -> c), infixl 9+ dup, -- :: a -> (a,a)+ swap, -- :: (a,b) -> (b,a)++-- Main types+ Time, -- [s] Both for time w.r.t. some reference and intervals.+ SF, -- Signal Function.+ Event(..), -- Events; conceptually similar to Maybe (but abstract).++-- 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++-- Basic signal functions+ identity, -- :: SF a a+ constant, -- :: b -> SF a b+ localTime, -- :: SF a Time+ time, -- :: SF a Time, Other name for localTime.++-- Initialization+ (-->), -- :: b -> SF a b -> SF a b, infixr 0+ (>--), -- :: a -> SF a b -> SF a b, infixr 0+ (-=>), -- :: (b -> b) -> SF a b -> SF a b infixr 0+ (>=-), -- :: (a -> a) -> SF a b -> SF a b infixr 0+ initially, -- :: a -> SF a a++-- 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)+ edge, -- :: SF Bool (Event ())+ iEdge, -- :: Bool -> SF Bool (Event ())+ edgeTag, -- :: a -> SF Bool (Event a)+ edgeJust, -- :: SF (Maybe a) (Event a)+ edgeBy, -- :: (a -> a -> Maybe b) -> a -> SF a (Event b)++-- Stateful event suppression+ notYet, -- :: SF (Event a) (Event a)+ once, -- :: SF (Event a) (Event a)+ takeEvents, -- :: Int -> SF (Event a) (Event a)+ dropEvents, -- :: Int -> SF (Event a) (Event a)++-- Basic switchers+ switch, dSwitch, -- :: SF a (b, Event c) -> (c -> SF a b) -> SF a b+ rSwitch, drSwitch, -- :: SF a b -> SF (a,Event (SF a b)) b+ kSwitch, dkSwitch, -- :: SF a b+ -- -> SF (a,b) (Event c)+ -- -> (SF a b -> c -> SF a b)+ -- -> SF a b++-- Parallel composition and switching over collections with broadcasting+ parB, -- :: Functor col => col (SF a b) -> SF a (col b)+ pSwitchB,dpSwitchB, -- :: Functor col =>+ -- col (SF a b)+ -- -> SF (a, col b) (Event c)+ -- -> (col (SF a b) -> c -> SF a (col b))+ -- -> SF a (col b)+ rpSwitchB,drpSwitchB,-- :: Functor col =>+ -- col (SF a b)+ -- -> SF (a, Event (col (SF a b)->col (SF a b)))+ -- (col b)++-- Parallel composition and switching over collections with general routing+ par, -- Functor col =>+ -- (forall sf . (a -> col sf -> col (b, sf)))+ -- -> col (SF b c)+ -- -> SF a (col c)+ pSwitch, dpSwitch, -- pSwitch :: Functor col =>+ -- (forall sf . (a -> col sf -> col (b, sf)))+ -- -> col (SF b c)+ -- -> SF (a, col c) (Event d)+ -- -> (col (SF b c) -> d -> SF a (col c))+ -- -> SF a (col c)+ rpSwitch,drpSwitch, -- Functor col =>+ -- (forall sf . (a -> col sf -> col (b, sf)))+ -- -> col (SF b c)+ -- -> SF (a, Event (col (SF b c) -> col (SF b c)))+ -- (col c)++-- Wave-form generation+ hold, -- :: a -> SF (Event a) a+ trackAndHold, -- :: a -> SF (Maybe a) a++-- Accumulators+ accum, -- :: a -> SF (Event (a -> a)) (Event a)+ accumBy, -- :: (b -> a -> b) -> b -> SF (Event a) (Event b)+ accumFilter, -- :: (c -> a -> (c, Maybe b)) -> c+ -- -> SF (Event a) (Event b)++-- Delays+ pre, -- :: SF a a+ iPre, -- :: a -> SF a a++-- Integration and differentiation+ integral, -- :: VectorSpace a s => SF a a+ derivative, -- :: VectorSpace a s => SF a a -- Crude!+ imIntegral, -- :: VectorSpace a s => a -> SF a a++-- Loops with guaranteed well-defined feedback+ loopPre, -- :: c -> SF (a,c) (b,c) -> SF a b+ loopIntegral, -- :: VectorSpace c s => SF (a,c) (b,c) -> SF a b++-- Pointwise functions on events+ noEvent, -- :: Event a+ noEventFst, -- :: (Event a, b) -> (Event c, b)+ noEventSnd, -- :: (a, Event b) -> (a, Event c)+ event, -- :: a -> (b -> a) -> Event b -> a+ fromEvent, -- :: Event a -> a+ isEvent, -- :: Event a -> Bool+ isNoEvent, -- :: Event a -> Bool+ tag, -- :: Event a -> b -> Event b, infixl 8+ attach, -- :: Event a -> b -> Event (a, b), infixl 8+ lMerge, -- :: Event a -> Event a -> Event a, infixl 6+ rMerge, -- :: Event a -> Event a -> Event a, infixl 6+ merge, -- :: Event a -> Event a -> Event a, infixl 6+ mergeBy, -- :: (a -> a -> a) -> Event a -> Event a -> Event a+ mapMerge, -- :: (a -> c) -> (b -> c) -> (a -> b -> c) + -- -> Event a -> Event b -> Event c+ mergeEvents, -- :: [Event a] -> Event a+ catEvents, -- :: [Event a] -> Event [a]+ joinE, -- :: Event a -> Event b -> Event (a,b),infixl 7+ splitE, -- :: Event (a,b) -> (Event a, Event b)+ filterE, -- :: (a -> Bool) -> Event a -> Event a+ mapFilterE, -- :: (a -> Maybe b) -> Event a -> Event b+ gate, -- :: Event a -> Bool -> Event a, infixl 8++-- Noise (random signal) sources and stochastic event sources+ noise, -- :: noise :: (RandomGen g, Random b) =>+ -- g -> SF a b+ noiseR, -- :: noise :: (RandomGen g, Random b) =>+ -- (b,b) -> g -> SF a b+ occasionally, -- :: RandomGen g => g -> Time -> b -> SF a (Event b)++-- Reactimation+ reactimate, -- :: IO a+ -- -> (Bool -> IO (DTime, Maybe a))+ -- -> (Bool -> b -> IO Bool)+ -- -> SF a b+ -- -> IO ()+ ReactHandle,+ reactInit, -- IO a -- init+ -- -> (ReactHandle a b -> Bool -> b -> IO Bool) -- actuate+ -- -> SF a b+ -- -> IO (ReactHandle a b)+-- process a single input sample:+ react, -- ReactHandle a b+ -- -> (DTime,Maybe a)+ -- -> IO Bool++-- Embedding (tentative: will be revisited)+ DTime, -- [s] Sampling interval, always > 0.+ embed, -- :: SF a b -> (a, [(DTime, Maybe a)]) -> [b]+ embedSynch, -- :: SF a b -> (a, [(DTime, Maybe a)]) -> SF Double b+ deltaEncode, -- :: Eq a => DTime -> [a] -> (a, [(DTime, Maybe a)])+ deltaEncodeBy -- :: (a -> a -> Bool) -> DTime -> [a]+ -- -> (a, [(DTime, Maybe a)])+) where++import Monad (unless)+import Random (RandomGen(..), Random(..), randoms, randomRs)++import Control.Arrow+import AFRPDiagnostics+import AFRPMiscellany (( # ), dup, swap)+import AFRPEvent+import AFRPVectorSpace++import Data.IORef++infixr 0 -->, >--, -=>, >=-++------------------------------------------------------------------------------+-- Basic type definitions with associated utilities+------------------------------------------------------------------------------++-- The time type is really a bit boguous, since, as time passes, the minimal+-- interval between two consecutive floating-point-represented time points+-- increases. A better approach is probably to pick a reasonable resolution+-- and represent time and time intervals by Integer (giving the number of+-- "ticks").++-- Time is used both for time intervals (duration), and time w.r.t. some+-- agreed reference point in time. Conceptually, Time = R, i.e. time can be 0+-- or even negative.+type Time = Double -- [s]+++-- DTime is the time type for lengths of sample intervals. Conceptually,+-- DTime = R+ = { x in R | x > 0 }. Don't assume Time and DTime have the+-- same representation.++type DTime = Double -- [s]+++-- Representation of signal function in initial state.+-- (Naming: "TF" stands for Transition Function.)++data SF a b = SF {sfTF :: a -> Transition a b}+++-- Representation of signal function in running state.+-- It would have been nice to have a constructor SFId representing (arr id):+--+-- SFId {sfTF' :: DTime -> a -> Transition a b}+--+-- But it seems as if we need dependent types as soon as we try to exploit+-- that constructor (note that the type above is too general!), and a+-- work-around based on keeping around an extra function as a "proof" that we+-- can do the required coersions, yields codde which is no more efficient+-- than using SFArr in the first place.+-- (Naming: "TIVar" stands for "time-input-variable".)++data SF' a b + = SFConst {sfTF' :: DTime -> a -> Transition a b, sfCVal :: b}+ | SFArr {sfTF' :: DTime -> a -> Transition a b, sfAFun :: a -> b}+ | SFTIVar {sfTF' :: DTime -> a -> Transition a b}+++-- A transition is a pair of the next state (in the form of a signal+-- function) and the output at the present time step.++type Transition a b = (SF' a b, b)+++-- "Smart" constructors. The corresponding "raw" constructors should not+-- be used directly for construction.++sfConst :: b -> SF' a b+sfConst b = sf+ where+ sf = SFConst {sfTF' = \_ _ -> (sf, b), sfCVal = b}+++sfNever :: SF' a (Event b)+sfNever = sfConst NoEvent+++sfId :: SF' a a+sfId = sf+ where+ sf = SFArr {sfTF' = \_ a -> (sf, a), sfAFun = id}+++sfArr :: (a -> b) -> SF' a b+sfArr f = sf+ where+ sf = SFArr {sfTF' = \_ a -> (sf, f a), sfAFun = f}+++-- Freezes a "running" signal function, i.e., turns it into a continuation in+-- the form of a plain signal function.+freeze :: SF' a b -> DTime -> SF a b+freeze sf dt = SF {sfTF = (sfTF' sf) dt}+++freezeCol :: Functor col => col (SF' a b) -> DTime -> col (SF a b)+freezeCol sfs dt = fmap (flip freeze dt) sfs+++------------------------------------------------------------------------------+-- Arrow instance and implementation+------------------------------------------------------------------------------++instance Arrow SF where+ arr = arrPrim+ (>>>) = compPrim+ first = firstPrim+ second = secondPrim+ (***) = parSplitPrim+ (&&&) = parFanOutPrim+++-- Lifting.+arrPrim :: (a -> b) -> SF a b+arrPrim f = SF {sfTF = \a -> (sfArr f, f a)}+++-- Composition.+-- The definition exploits the following identities:+-- sf >>> constant c = constant c+-- constant c >>> arr f = constant (f c)+-- arr f >>> arr g = arr (g . f)+-- (It would have been nice to explit e.g. identity >>> sf = sf, but it would+-- seem that we need dependent types for that.)+compPrim :: SF a b -> SF b c -> SF a c+compPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}+ where+ tf0 a0 = (cpAux sf1 sf2, c0)+ where+ (sf1, b0) = tf10 a0+ (sf2, c0) = tf20 b0++ cpAux _ sf2@(SFConst {}) = sfConst (sfCVal sf2)+ cpAux sf1@(SFConst {}) sf2 = cpAuxC1 (sfCVal sf1) sf2+ cpAux sf1@(SFArr {}) sf2 = cpAuxA1 (sfAFun sf1) sf2+ cpAux sf1 sf2@(SFArr {}) = cpAuxA2 sf1 (sfAFun sf2)+ cpAux sf1 sf2 = SFTIVar {sfTF' = tf}+ where+ tf dt a = (cpAux sf1' sf2', c)+ where+ (sf1', b) = (sfTF' sf1) dt a+ (sf2', c) = (sfTF' sf2) dt b++ cpAuxC1 _ (SFConst {sfCVal = c}) = sfConst c+ cpAuxC1 b (SFArr {sfAFun = f2}) = sfConst (f2 b)+ cpAuxC1 b (SFTIVar {sfTF' = tf2}) = SFTIVar {sfTF' = tf}+ where+ tf dt _ = (cpAuxC1 b sf2', c)+ where+ (sf2', c) = tf2 dt b++ cpAuxA1 _ (SFConst {sfCVal = c}) = sfConst c+ cpAuxA1 f1 (SFArr {sfAFun = f2}) = sfArr (f2 . f1)+ cpAuxA1 f1 (SFTIVar {sfTF' = tf2}) = SFTIVar {sfTF' = tf}+ where+ tf dt a = (cpAuxA1 f1 sf2', c)+ where+ (sf2', c) = tf2 dt (f1 a)++ cpAuxA2 (SFConst {sfCVal = b}) f2 = sfConst (f2 b)+ cpAuxA2 (SFArr {sfAFun = f1}) f2 = sfArr (f2 . f1)+ cpAuxA2 (SFTIVar {sfTF' = tf1}) f2 = SFTIVar {sfTF' = tf}+ where+ tf dt a = (cpAuxA2 sf1' f2, f2 b)+ where+ (sf1', b) = tf1 dt a+++-- Widening.+-- The definition exploits the following identities:+-- first (constant b) = arr (\(_, c) -> (b, c))+-- (first (arr f)) = arr (\(a, c) -> (f a, c))+-- (It would have been nice to exploit first identity = identity, but it would+-- seem that we need dependent types for that.)+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 ++ fpAux (SFConst {sfCVal = b}) = sfArr (\(~(_, c)) -> (b, c))+ fpAux (SFArr {sfAFun = f}) = sfArr (\(~(a, c)) -> (f a, c))+ fpAux sf1 = SFTIVar {sfTF' = tf}+ 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 ++ spAux (SFConst {sfCVal = b}) = sfArr (\(~(c, _)) -> (c, b))+ spAux (SFArr {sfAFun = f}) = sfArr (\(~(c, a)) -> (c, f a))+ spAux sf1 = SFTIVar {sfTF' = tf}+ where+ tf dt ~(c, a) = (spAux sf1', (c, b))+ where+ (sf1', b) = (sfTF' sf1) dt a +++-- Parallel composition.+-- The definition exploits the following identities (which hold for SF):+-- constant b *** constant d = constant (b, d)+-- constant b *** arr f2 = arr (\(_, c) -> (b, f2 c)+-- arr f1 *** constant d = arr (\(a, _) -> (f1 a, d)+-- arr f1 *** arr f2 = arr (\(a, b) -> (f1 a, f2 b)+parSplitPrim :: SF a b -> SF c d -> SF (a,c) (b,d)+parSplitPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}+ where+ tf0 ~(a0, c0) = (psAux sf1 sf2, (b0, d0))+ where+ (sf1, b0) = tf10 a0 + (sf2, d0) = tf20 c0 ++ psAux sf1@(SFConst {}) sf2 = psAuxC1 (sfCVal sf1) sf2+ psAux sf1 sf2@(SFConst {}) = psAuxC2 sf1 (sfCVal sf2)+ psAux sf1@(SFArr {}) sf2 = psAuxA1 (sfAFun sf1) sf2+ psAux sf1 sf2@(SFArr {}) = psAuxA2 sf1 (sfAFun sf2)+ psAux sf1 sf2 = SFTIVar {sfTF' = tf}+ where+ tf dt ~(a, c) = (psAux sf1' sf2', (b, d))+ where+ (sf1', b) = (sfTF' sf1) dt a+ (sf2', d) = (sfTF' sf2) dt c++ psAuxC1 b (SFConst {sfCVal = d}) = sfConst (b, d)+ psAuxC1 b (SFArr {sfAFun = f2}) = sfArr (\(~(_, c)) -> (b, f2 c))+ psAuxC1 b (SFTIVar {sfTF' = tf2}) = SFTIVar {sfTF' = tf}+ where+ tf dt ~(_, c) = (psAuxC1 b sf2', (b, d))+ where+ (sf2', d) = tf2 dt c++ psAuxC2 (SFConst {sfCVal = b}) d = sfConst (b, d)+ psAuxC2 (SFArr {sfAFun = f1}) d = sfArr (\(~(a, _)) -> (f1 a, d))+ psAuxC2 (SFTIVar {sfTF' = tf1}) d = SFTIVar {sfTF' = tf}+ where+ tf dt ~(a, _) = (psAuxC2 sf1' d, (b, d))+ where+ (sf1', b) = tf1 dt a++ psAuxA1 f1 (SFConst {sfCVal = d}) = sfArr (\(~(a,_)) -> (f1 a, d))+ psAuxA1 f1 (SFArr {sfAFun = f2}) = sfArr (\(~(a,c)) -> (f1 a, f2 c))+ psAuxA1 f1 (SFTIVar {sfTF' = tf2}) = SFTIVar {sfTF' = tf}+ where+ tf dt ~(a, c) = (psAuxA1 f1 sf2', (f1 a, d))+ where+ (sf2', d) = tf2 dt c++ psAuxA2 (SFConst {sfCVal = b}) f2 = sfArr (\(~(_,c)) -> (b, f2 c))+ psAuxA2 (SFArr {sfAFun = f1}) f2 = sfArr (\(~(a,c)) -> (f1 a, f2 c))+ psAuxA2 (SFTIVar {sfTF' = tf1}) f2 = SFTIVar {sfTF' = tf}+ where+ tf dt ~(a, c) = (psAuxA2 sf1' f2, (b, f2 c))+ where+ (sf1', b) = tf1 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 = (pfoAux sf1 sf2, (b0, c0))+ where+ (sf1, b0) = tf10 a0 + (sf2, c0) = tf20 a0 ++ pfoAux sf1@(SFConst {}) sf2 = pfoAuxC1 (sfCVal sf1) sf2+ pfoAux sf1 sf2@(SFConst {}) = pfoAuxC2 sf1 (sfCVal sf2)+ pfoAux sf1@(SFArr {}) sf2 = pfoAuxA1 (sfAFun sf1) sf2+ pfoAux sf1 sf2@(SFArr {}) = pfoAuxA2 sf1 (sfAFun sf2)+ pfoAux sf1 sf2 = SFTIVar {sfTF' = tf}+ where+ tf dt a = (pfoAux sf1' sf2', (b, c))+ where+ (sf1', b) = (sfTF' sf1) dt a+ (sf2', c) = (sfTF' sf2) dt a++ pfoAuxC1 b (SFConst {sfCVal = c}) = sfConst (b, c)+ pfoAuxC1 b (SFArr {sfAFun = f2}) = sfArr (\a -> (b, f2 a))+ pfoAuxC1 b (SFTIVar {sfTF' = tf2}) = SFTIVar {sfTF' = tf}+ where+ tf dt a = (pfoAuxC1 b sf2', (b, c))+ where+ (sf2', c) = tf2 dt a++ pfoAuxC2 (SFConst {sfCVal = b}) c = sfConst (b, c)+ pfoAuxC2 (SFArr {sfAFun = f1}) c = sfArr (\a -> (f1 a, c))+ pfoAuxC2 (SFTIVar {sfTF' = tf1}) c = SFTIVar {sfTF' = tf}+ where+ tf dt a = (pfoAuxC2 sf1' c, (b, c))+ where+ (sf1', b) = tf1 dt a++ pfoAuxA1 f1 (SFConst {sfCVal = c}) = sfArr (\a -> (f1 a, c))+ pfoAuxA1 f1 (SFArr {sfAFun = f2}) = sfArr (\a -> (f1 a ,f2 a))+ pfoAuxA1 f1 (SFTIVar {sfTF' = tf2}) = SFTIVar {sfTF' = tf}+ where+ tf dt a = (pfoAuxA1 f1 sf2', (f1 a, c))+ where+ (sf2', c) = tf2 dt a++ pfoAuxA2 (SFConst {sfCVal = b}) f2 = sfArr (\a -> (b, f2 a))+ pfoAuxA2 (SFArr {sfAFun = f1}) f2 = sfArr (\a -> (f1 a, f2 a))+ pfoAuxA2 (SFTIVar {sfTF' = tf1}) f2 = SFTIVar {sfTF' = tf}+ where+ tf dt a = (pfoAuxA2 sf1' f2, (b, f2 a))+ where+ (sf1', b) = tf1 dt a+++------------------------------------------------------------------------------+-- ArrowLoop instance and implementation+------------------------------------------------------------------------------++instance ArrowLoop SF where+ loop = loopPrim+++loopPrim :: SF (a,c) (b,c) -> SF a b+loopPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}+ where+ tf0 a0 = (loopAux sf1, b0)+ where+ (sf1, (b0, c0)) = tf10 (a0, c0)++ loopAux (SFConst {sfCVal = (b, _)}) = sfConst b+ loopAux (SFArr {sfAFun = f1}) = sfArr (\a -> let (b,c) = f1 (a,c)+ in b)+ loopAux sf1 = SFTIVar {sfTF' = tf}+ where+ tf dt a = (loopAux sf1', b)+ where+ (sf1', (b, c)) = (sfTF' sf1) dt (a, c)+++------------------------------------------------------------------------------+-- Basic signal functions+------------------------------------------------------------------------------++-- Identity: identity = arr id+identity :: SF a a+identity = SF {sfTF = \a -> (sfId, a)}+++-- Identity: constant b = arr (const b)+constant :: b -> SF a b+constant b = SF {sfTF = \_ -> (sfConst b, b)}+++-- Outputs the time passed since the signal function instance was started.+localTime :: SF a Time+localTime = constant 1.0 >>> integral+++-- Alternative name for localTime.+time :: SF a Time+time = localTime+++------------------------------------------------------------------------------+-- Initialization+------------------------------------------------------------------------------++-- Initialization operator (cf. Lustre/Lucid Synchrone).+(-->) :: b -> SF a b -> SF a b+b0 --> (SF {sfTF = tf10}) = SF {sfTF = \a0 -> (fst (tf10 a0), b0)}+++-- Input initialization operator.+(>--) :: a -> SF a b -> SF a b+a0 >-- (SF {sfTF = tf10}) = SF {sfTF = \_ -> tf10 a0}+++-- Transform initial output value.+(-=>) :: (b -> b) -> SF a b -> SF a b+f -=> (SF {sfTF = tf10}) =+ SF {sfTF = \a0 -> let (sf1, b0) = tf10 a0 in (sf1, f b0)}+++-- Transform initial input value.+(>=-) :: (a -> a) -> SF a b -> SF a b+f >=- (SF {sfTF = tf10}) = SF {sfTF = \a0 -> tf10 (f a0)}+++-- Override initial value of input signal.+initially :: a -> SF a a+initially = (--> identity)+++------------------------------------------------------------------------------+-- Basic event sources+------------------------------------------------------------------------------++-- Event source which never occurs.+never :: SF a (Event b)+never = SF {sfTF = \_ -> (sfNever, NoEvent)}+++-- Event source with a single occurrence at time 0. The value of the event+-- is given by the function argument.+now :: b -> SF a (Event b)+now b0 = (Event b0 --> never)+++-- Event source with a single occurrence at or as soon after (local) time q+-- as possible.+after :: Time -> b -> SF a (Event b)+after q x = afterEach [(q,x)]+++-- Event source with repeated occurrences with interval q.+-- Note: If the interval is too short w.r.t. the sampling intervals,+-- the result will be that events occur at every sample. However, no more+-- than one event results from any sampling interval, thus avoiding an+-- "event backlog" should sampling become more frequent at some later+-- point in time.+repeatedly :: Time -> b -> SF a (Event b)+repeatedly q x | q > 0 = afterEach qxs+ | otherwise = usrErr "AFRP" "repeatedly" "Non-positive period."+ where+ qxs = (q,x):qxs +++-- Event source with consecutive occurrences at the given intervals.+-- Should more than one event be scheduled to occur in any sampling interval,+-- only the first will in fact occur to avoid an event backlog.+-- Question: Should positive periods except for the first one be required?+-- Note that periods of length 0 will always be skipped except for the first.+-- Right now, periods of length 0 is allowed on the grounds that no attempt+-- is made to forbid simultaneous events elsewhere.+afterEach :: [(Time,b)] -> SF a (Event b)+afterEach [] = never+afterEach ((q,x):qxs)+ | q < 0 = usrErr "AFRP" "afterEach" "Negative period."+ | otherwise = SF {sfTF = tf0}+ where+ tf0 _ = if q <= 0 then+ (scheduleNextEvent 0.0 qxs, Event x)+ else+ (awaitNextEvent (-q) x qxs, NoEvent)++ scheduleNextEvent t [] = sfNever+ scheduleNextEvent t ((q,x):qxs)+ | q < 0 = usrErr "AFRP" "afterEach" "Negative period."+ | t' >= 0 = scheduleNextEvent t' qxs+ | otherwise = awaitNextEvent t' x qxs+ where+ t' = t - q+ awaitNextEvent t x qxs = SFTIVar {sfTF' = tf}+ where+ tf dt _ | t' >= 0 = (scheduleNextEvent t' qxs, Event x)+ | otherwise = (awaitNextEvent t' x qxs, NoEvent)+ where+ t' = t + dt+++-- A rising edge detector. Useful for things like detecting key presses.+-- Note that we initialize the loop with state set to True so that there+-- will not be an occurence at t0 in the logical time frame in which+-- this is started.+edge :: SF Bool (Event ())+edge = iEdge True+++iEdge :: Bool -> SF Bool (Event ())+iEdge i = edgeBy (isBoolRaisingEdge ()) i+++-- Like edge, but parameterized on the tag value.+edgeTag :: a -> SF Bool (Event a)+edgeTag a = edgeBy (isBoolRaisingEdge a) True+++-- Internal utility.+isBoolRaisingEdge :: a -> Bool -> Bool -> Maybe a+isBoolRaisingEdge _ False False = Nothing+isBoolRaisingEdge a False True = Just a+isBoolRaisingEdge _ True True = Nothing+isBoolRaisingEdge _ True False = Nothing+++-- Detects an edge where a maybe signal is changing from nothing to something.+edgeJust :: SF (Maybe a) (Event a)+edgeJust = edgeBy isJustEdge (Just undefined)+ where+ isJustEdge Nothing Nothing = Nothing+ isJustEdge Nothing ma@(Just _) = ma+ isJustEdge (Just _) (Just _) = Nothing+ isJustEdge (Just _) Nothing = Nothing+++-- Edge detector parameterized on the edge detection function and initial+-- state, i.e., the previous input sample. The first argument to the+-- edge detection function is the previous sample, the second the current one.++-- !!! Is this broken!?! Does not disallow an edge condition that persists+-- !!! between consecutive samples. See discussion in ToDo list above.++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 = SFTIVar {sfTF' = tf}+ where+ tf dt a = (ebAux a, maybeToEvent (isEdge a_prev a))+++------------------------------------------------------------------------------+-- Stateful event suppression+------------------------------------------------------------------------------++-- Suppression of initial (at local time 0) event.+notYet :: SF (Event a) (Event a)+notYet = initially NoEvent+++-- Suppress all but first event.+once :: SF (Event a) (Event a)+once = takeEvents 1+++-- Suppress all but first n events.+takeEvents :: Int -> SF (Event a) (Event a)+takeEvents 0 = never+takeEvents (n + 1) = dSwitch (arr dup) (const (NoEvent >-- takeEvents n))+++{-+-- More complicated using "switch" that "dSwitch".+takeEvents :: Int -> SF (Event a) (Event a)+takeEvents 0 = never+takeEvents (n + 1) = switch (never &&& identity) (takeEvents' n)+ where+ takeEvents' 0 a = now a+ takeEvents' (n + 1) a = switch (now a &&& notYet) (takeEvents' n)+-}+++-- Suppress first n events.+-- Here dSwitch or switch does not really matter.+dropEvents :: Int -> SF (Event a) (Event a)+dropEvents 0 = identity+dropEvents (n + 1) = dSwitch (never &&& identity)+ (const (NoEvent >-- dropEvents n))+++------------------------------------------------------------------------------+-- Basic switchers+------------------------------------------------------------------------------++-- Basic switch.+switch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b+switch (SF {sfTF = tf10}) k = SF {sfTF = tf0}+ where+ tf0 a0 =+ case tf10 a0 of+ (sf1, (b0, NoEvent)) -> (switchAux sf1, b0)+ (_, (_, Event c0)) -> sfTF (k c0) a0++ switchAux (SFConst {sfCVal = (b, NoEvent)}) = sfConst b+ switchAux (SFArr {sfAFun = f1}) = switchAuxA1 f1+ switchAux sf1 = SFTIVar {sfTF' = tf}+ where+ tf dt a =+ case (sfTF' sf1) dt a of+ (sf1', (b, NoEvent)) -> (switchAux sf1', 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, SFTIVar overall.+ switchAuxA1 f1 = sf+ where+ sf = SFTIVar {sfTF' = tf}+ tf _ a =+ case f1 a of+ (b, NoEvent) -> (sf, b)+ (_, Event c) -> sfTF (k c) a+++-- Switch with delayed observation.+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+ Event c0 -> fst (sfTF (k c0) a0),+ b0)++ dSwitchAux (SFConst {sfCVal = (b, NoEvent)}) = sfConst b+ dSwitchAux (SFArr {sfAFun = f1}) = dSwitchAuxA1 f1+ dSwitchAux sf1 = SFTIVar {sfTF' = tf}+ where+ tf dt a =+ let (sf1', (b, ec)) = (sfTF' sf1) dt a+ in (case ec of+ NoEvent -> dSwitchAux sf1'+ 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, SFTIVar overall.+ dSwitchAuxA1 f1 = sf+ where+ sf = SFTIVar {sfTF' = tf}+ tf _ a =+ let (b, ec) = f1 a+ in (case ec of+ NoEvent -> sf+ Event c -> fst (sfTF (k c) a),++ b)+++-- Recurring switch.+rSwitch :: SF a b -> SF (a, Event (SF a b)) b+rSwitch sf = switch (first sf) ((noEventSnd >=-) . rSwitch)++{-+-- Old version. New is more efficient. Which one is clearer?+rSwitch :: SF a b -> SF (a, Event (SF a b)) b+rSwitch sf = switch (first sf) rSwitch'+ where+ rSwitch' sf = switch (sf *** notYet) rSwitch'+-}+++-- Recurring switch with delayed observation.+drSwitch :: SF a b -> SF (a, Event (SF a b)) b+drSwitch sf = dSwitch (first sf) ((noEventSnd >=-) . drSwitch)++{-+-- Old version. New is more efficient. Which one is clearer?+drSwitch :: SF a b -> SF (a, Event (SF a b)) b+drSwitch sf = dSwitch (first sf) drSwitch'+ where+ drSwitch' sf = dSwitch (sf *** notYet) drSwitch'+-}+++-- "Call-with-current-continuation" switch.+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 sf1 (SFConst {sfCVal = NoEvent}) = sf1+ kSwitchAux sf1 sfe = SFTIVar {sfTF' = tf}+ 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+++-- kSwitch with delayed observation.+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 (SFConst {sfCVal = NoEvent}) = sf1+ dkSwitchAux sf1 sfe = SFTIVar {sfTF' = tf}+ where+ tf dt a =+ let (sf1', b) = (sfTF' sf1) dt a+ in (case (sfTF' sfe) dt (a, b) of+ (sfe', NoEvent) -> dkSwitchAux sf1' sfe'+ (_, Event c) -> fst (sfTF (k (freeze sf1 dt) c) a),+ b)+++------------------------------------------------------------------------------+-- Parallel composition and switching over collections with broadcasting+------------------------------------------------------------------------------++broadcast :: Functor col => a -> col sf -> col (a, sf)+broadcast a sfs = fmap (\sf -> (a, sf)) sfs+++-- Spatial parallel composition of a signal function collection.+parB :: Functor col => col (SF a b) -> SF a (col b)+parB = par broadcast+++-- Parallel switch (dynamic collection of signal functions spatially composed+-- in parallel).+pSwitchB :: Functor col =>+ col (SF a b) -> SF (a,col b) (Event c) -> (col (SF a b)->c-> SF a (col b))+ -> SF a (col b)+pSwitchB = pSwitch broadcast+++dpSwitchB :: Functor col =>+ col (SF a b) -> SF (a,col b) (Event c) -> (col (SF a b)->c->SF a (col b))+ -> SF a (col b)+dpSwitchB = dpSwitch broadcast+++rpSwitchB :: Functor col =>+ col (SF a b) -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b)+rpSwitchB = rpSwitch broadcast+++drpSwitchB :: Functor col =>+ col (SF a b) -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b)+drpSwitchB = drpSwitch broadcast+++------------------------------------------------------------------------------+-- Parallel composition and switching over collections with general routing+------------------------------------------------------------------------------++-- Spatial parallel composition of a signal function collection parameterized+-- on the routing function.+-- rf ......... Routing function: determines the input to each signal function+-- in the collection. IMPORTANT! The routing function MUST+-- preserve the structure of the signal function collection.+-- sfs0 ....... Signal function collection.+-- Returns the spatial parallel composition of the supplied signal functions.++par :: Functor col =>+ (forall sf . (a -> col sf -> col (b, sf)))+ -> col (SF b c)+ -> SF a (col c)+par rf sfs0 = SF {sfTF = tf0}+ where+ tf0 a0 =+ let bsfs0 = rf a0 sfs0+ sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0+ sfs = fmap fst sfcs0+ cs0 = fmap snd sfcs0+ in+ (parAux rf sfs, cs0)+++-- Internal definition. Also used in parallel swithers.+parAux :: Functor col =>+ (forall sf . (a -> col sf -> col (b, sf)))+ -> col (SF' b c)+ -> SF' a (col c)+parAux rf sfs = SFTIVar {sfTF' = tf}+ where+ tf dt a = + let bsfs = rf a sfs+ sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs+ sfs' = fmap fst sfcs'+ cs = fmap snd sfcs'+ in+ (parAux rf sfs', cs)+++-- Parallel switch parameterized on the routing function. This is the most+-- general switch from which all other (non-delayed) switches in principle+-- can be derived. The signal function collection is spatially composed in+-- parallel and run until the event signal function has an occurrence. Once+-- the switching event occurs, all signal function are "frozen" and their+-- continuations are passed to the continuation function, along with the+-- event value.+-- rf ......... Routing function: determines the input to each signal function+-- in the collection. IMPORTANT! The routing function has an+-- obligation to preserve the structure of the signal function+-- collection.+-- sfs0 ....... Signal function collection.+-- sfe0 ....... Signal function generating the switching event.+-- k .......... Continuation to be invoked once event occurs.+-- Returns the resulting signal function.++pSwitch :: Functor col =>+ (forall sf . (a -> col sf -> col (b, sf)))+ -> col (SF b c)+ -> SF (a, col c) (Event d)+ -> (col (SF b c) -> d -> SF a (col c))+ -> SF a (col c)+pSwitch rf sfs0 sfe0 k = SF {sfTF = tf0}+ where+ tf0 a0 =+ let bsfs0 = rf a0 sfs0+ sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0+ sfs = fmap fst sfcs0+ cs0 = fmap snd sfcs0+ in+ case (sfTF sfe0) (a0, cs0) of+ (sfe, NoEvent) -> (pSwitchAux sfs sfe, cs0)+ (_, Event d0) -> sfTF (k sfs0 d0) a0++ pSwitchAux sfs (SFConst {sfCVal = NoEvent}) = parAux rf sfs+ pSwitchAux sfs sfe = SFTIVar {sfTF' = tf}+ 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.+dpSwitch :: Functor col =>+ (forall sf . (a -> col sf -> col (b, sf)))+ -> col (SF b c)+ -> SF (a, col c) (Event d)+ -> (col (SF b c) -> d -> SF a (col c))+ -> SF a (col c)+dpSwitch rf sfs0 sfe0 k = SF {sfTF = tf0}+ where+ tf0 a0 =+ let bsfs0 = rf a0 sfs0+ sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0+ cs0 = fmap snd sfcs0+ in+ (case (sfTF sfe0) (a0, cs0) of+ (sfe, NoEvent) -> dpSwitchAux (fmap fst sfcs0) sfe+ (_, Event d0) -> fst (sfTF (k sfs0 d0) a0),+ cs0)++ dpSwitchAux sfs (SFConst {sfCVal = NoEvent}) = parAux rf sfs+ dpSwitchAux sfs sfe = SFTIVar {sfTF' = tf}+ where+ tf dt a =+ let bsfs = rf a sfs+ sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs+ cs = fmap snd sfcs'+ in+ (case (sfTF' sfe) dt (a, cs) of+ (sfe', NoEvent) -> dpSwitchAux (fmap fst sfcs')+ sfe'+ (_, Event d) -> fst (sfTF (k (freezeCol sfs dt)+ d)+ a),+ cs)+++-- Recurring parallel switch parameterized on the routing function.+-- rf ......... Routing function: determines the input to each signal function+-- in the collection. IMPORTANT! The routing function has an+-- obligation to preserve the structure of the signal function+-- collection.+-- sfs ........ Initial signal function collection.+-- Returns the resulting signal function.++rpSwitch :: Functor col =>+ (forall sf . (a -> col sf -> col (b, sf)))+ -> col (SF b c) -> SF (a, Event (col (SF b c) -> col (SF b c))) (col c)+rpSwitch rf sfs =+ pSwitch (rf . fst) sfs (arr (snd . fst)) $ \sfs' f ->+ noEventSnd >=- rpSwitch rf (f sfs')+++{-+rpSwitch rf sfs = pSwitch (rf . fst) sfs (arr (snd . fst)) k+ where+ k sfs f = rpSwitch' (f sfs)+ rpSwitch' sfs = pSwitch (rf . fst) sfs (NoEvent --> arr (snd . fst)) k+-}++-- Recurring parallel switch with delayed observation parameterized on the+-- routing function.+drpSwitch :: Functor col =>+ (forall sf . (a -> col sf -> col (b, sf)))+ -> col (SF b c) -> SF (a, Event (col (SF b c) -> col (SF b c))) (col c)+drpSwitch rf sfs =+ dpSwitch (rf . fst) sfs (arr (snd . fst)) $ \sfs' f ->+ noEventSnd >=- drpSwitch rf (f sfs')++{-+drpSwitch rf sfs = dpSwitch (rf . fst) sfs (arr (snd . fst)) k+ where+ k sfs f = drpSwitch' (f sfs)+ drpSwitch' sfs = dpSwitch (rf . fst) sfs (NoEvent-->arr (snd . fst)) k+-}++------------------------------------------------------------------------------+-- Wave-form generation+------------------------------------------------------------------------------++-- Zero-order hold.+hold :: a -> SF (Event a) a+hold a_init = switch (constant a_init &&& identity) ((NoEvent >--) . hold)+++-- Tracks input signal when available, holds last value when disappears.+trackAndHold :: a -> SF (Maybe a) a+trackAndHold a_init = arr (maybe NoEvent Event) >>> hold a_init+++------------------------------------------------------------------------------+-- Accumulators+------------------------------------------------------------------------------++accum :: a -> SF (Event (a -> a)) (Event a)+accum = accumBy (flip ($))++accumBy :: (b -> a -> b) -> b -> SF (Event a) (Event b)+accumBy f b_init = switch (never &&& identity) $ \a -> abAux (f b_init a)+ where+ abAux b = switch (now b &&& notYet) $ \a -> abAux (f b a)+++{-+-- Identity: accumBy f = accumFilter (\b a -> let b' = f b a in (b',Just b'))+accumBy :: (b -> a -> b) -> b -> SF (Event a) (Event b)+accumBy f b_init = SF {sfTF = tf0}+ where+ tf0 NoEvent = (abAux b_init, NoEvent) + tf0 (Event a0) = let b' = f b_init a0+ in (abAux b', Event b')++ abAux b = SFTIVar {sfTF' = tf}+ where+ tf _ NoEvent = (abAux b, NoEvent)+ tf _ (Event a) = let b' = f b a+ in (abAux b', Event b')+-}++{-+accumFilter :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b)+accumFilter f c_init = SF {sfTF = tf0}+ where+ tf0 NoEvent = (afAux c_init, NoEvent) + tf0 (Event a0) = case f c_init a0 of+ (c', Nothing) -> (afAux c', NoEvent)+ (c', Just b0) -> (afAux c', Event b0)++ afAux c = SFTIVar {sfTF' = tf}+ where+ tf _ NoEvent = (afAux c, NoEvent)+ tf _ (Event a) = case f c a of+ (c', Nothing) -> (afAux c', NoEvent)+ (c', Just b) -> (afAux c', Event b)+-}+++accumFilter :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b)+accumFilter f c_init = switch (never &&& identity) $ \a -> afAux (f c_init a)+ where+ afAux (c, Nothing) = switch (never &&& notYet) $ \a -> afAux (f c a)+ afAux (c, Just b) = switch (now b &&& notYet) $ \a -> afAux (f c a)+++------------------------------------------------------------------------------+-- Delays+------------------------------------------------------------------------------++-- Uninitialized delay operator.+-- !!! The seq helps in the dynamic delay line example. But is it a good+-- !!! idea in general? Are there other accumulators which should be seq'ed+-- !!! as well? E.g. accum? Switch? Anywhere else? What's the underlying+-- !!! design principle? What can the user assume?+pre = SF {sfTF = tf0}+ where+ tf0 a0 = (preAux a0, usrErr "AFRP" "pre" "Uninitialized pre operator.")++ preAux a_prev = SFTIVar {sfTF' = tf}+ where+ tf dt a = {- a_prev `seq` -} (preAux a, a_prev)+++-- Initialized delay operator.+iPre :: a -> SF a a+iPre = (--> pre)+++------------------------------------------------------------------------------+-- Integraltion and differentiation+------------------------------------------------------------------------------++-- Integration using the rectangle rule.+integral :: VectorSpace a s => SF a a+integral = SF {sfTF = tf0}+ where+ igrl0 = zeroVector++ tf0 a0 = (integralAux igrl0 a0, igrl0)++ integralAux igrl a_prev = SFTIVar {sfTF' = tf}+ where+ tf dt a = (integralAux igrl' a, igrl')+ where+ igrl' = igrl ^+^ realToFrac dt *^ a_prev++++-- "immediate" integration (using the function's value at the current time)+imIntegral :: VectorSpace a s => a -> SF a a+imIntegral = ((\ _ a' dt v -> v ^+^ realToFrac dt *^ a') `iterFrom`)++iterFrom :: (a -> a -> DTime -> b -> b) -> b -> SF a b+f `iterFrom` b = SF (iterAux b) where+ iterAux b a = (SFTIVar (\ dt a' -> iterAux (f a a' dt b) a'), b)++{-+integral :: Fractional a => SF a a+integral = SF {sfTF = tf0}+ where+ igrl0 = 0.0++ tf0 a0 = (integralAux igrl0 a0, igrl0)++ integralAux igrl a_prev = SFTIVar {sfTF' = tf}+ where+ tf dt a = (integralAux igrl' a, igrl')+ where+ igrl' = igrl + a_prev * realToFrac dt+-}++-- This is extremely crude. Use at your own risk.+derivative :: VectorSpace a s => SF a a+derivative = SF {sfTF = tf0}+ where+ tf0 a0 = (derivativeAux a0, zeroVector)++ derivativeAux a_prev = SFTIVar {sfTF' = tf}+ where+ tf dt a = (derivativeAux a, (a ^-^ a_prev) ^/ realToFrac dt)+++------------------------------------------------------------------------------+-- Loops with guaranteed well-defined feedback+------------------------------------------------------------------------------++loopPre :: c -> SF (a,c) (b,c) -> SF a b+loopPre c_init sf = loop (second (iPre c_init) >>> sf)++++loopIntegral :: VectorSpace c s => SF (a,c) (b,c) -> SF a b+loopIntegral sf = loop (second integral >>> sf)+++------------------------------------------------------------------------------+-- Noise (i.e. random signal generators) and stochastic processes+------------------------------------------------------------------------------++-- Noise (random signal) with default range for type in question;+-- based on "randoms".+noise :: (RandomGen g, Random b) => g -> SF a b+noise g0 = streamToSF (randoms g0)+++-- Noise (random signal) with specified range; based on "randomRs".+noiseR :: (RandomGen g, Random b) => (b,b) -> g -> SF a b+noiseR range g0 = streamToSF (randomRs range g0)+++-- Internal. Not very useful for other purposes since we do not have any+-- control over the intervals between each "sample". Or? A version with+-- time-stamped samples would be similar to embedSynch (applied to identity).+-- The list argument must be a stream (infinite list) at present.++streamToSF :: [b] -> SF a b+streamToSF [] = intErr "AFRP" "streamToSF" "Empty list!"+streamToSF (b:bs) = SF {sfTF = tf0}+ where+ tf0 _ = (stsfAux bs, b)++ stsfAux [] = intErr "AFRP" "streamToSF" "Empty list!"+ stsfAux (b:bs) = SFTIVar {sfTF' = tf}+ 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+-- interval in the case of relatively sparse sampling, thus avoiding an+-- "event backlog" should sampling become more frequent at some later+-- point in time.+-- !!! Maybe it would better to give a frequency? But like this to make+-- !!! consitent with "repeatedly".+occasionally :: RandomGen g => g -> Time -> b -> SF a (Event b)+occasionally g t_avg x | t_avg > 0 = SF {sfTF = tf0}+ | otherwise = usrErr "AFRP" "occasionally"+ "Non-positive average interval."+ where+ -- Generally, if events occur with an average frequency of f, the+ -- probability of at least one event occurring in an interval of t+ -- is given by (1 - exp (-f*t)). The goal in the following is to+ -- decide whether at least one event occurred in the interval of size+ -- dt preceding the current sample point. For the first point,+ -- we can think of the preceding interval as being 0, implying+ -- no probability of an event occurring.++ tf0 _ = (occAux ((randoms g) :: [Double]), NoEvent)++ occAux (r:rs) = SFTIVar {sfTF' = tf}+ where+ tf dt _ = let p = 1 - exp (-(dt/t_avg)) -- Probability for at+ in -- least one event.+ (occAux rs, if r < p then Event x else NoEvent)+++------------------------------------------------------------------------------+-- Reactimation+------------------------------------------------------------------------------++-- Reactimation of a signal function.+-- init ....... IO action for initialization. Will only be invoked once,+-- at (logical) time 0, before first call to "sense".+-- Expected to return the value of input at time 0.+-- sense ...... IO action for sensing of system input.+-- arg. #1 ....... True: action may block, waiting for an OS event.+-- False: action must not block.+-- res. #1 ....... Time interval since previous invocation of the sensing+-- action (or, the first time round, the init action),+-- returned. The interval must be _strictly_ greater+-- than 0. Thus even a non-blocking invocation must+-- ensure that time progresses.+-- res. #2 ....... Nothing: input is unchanged w.r.t. the previously+-- returned input sample.+-- Just i: the input is currently i.+-- It is OK to always return "Just", even if input is+-- unchanged.+-- actuate .... IO action for outputting the system output.+-- arg. #1 ....... True: output may have changed from previous output+-- sample.+-- False: output is definitely unchanged from previous+-- output sample.+-- It is OK to ignore argument #1 and assume that the+-- the output has always changed.+-- arg. #2 ....... Current output sample.+-- result ....... Termination flag. Once True, reactimate will exit+-- the reactimation loop and return to its caller.+-- sf ......... Signal function to reactimate.++reactimate :: IO a+ -> (Bool -> IO (DTime, Maybe a))+ -> (Bool -> b -> IO Bool)+ -> SF a b+ -> IO ()+reactimate init sense actuate (SF {sfTF = tf0}) =+ do+ a0 <- init+ let (sf, b0) = tf0 a0+ loop sf a0 b0+ where+ loop sf a b = do+ done <- actuate True b+ unless (a `seq` b `seq` done) $ do+ (dt, ma') <- sense False+ let a' = maybe a id ma'+ (sf', b') = (sfTF' sf) dt a'+ loop sf' a' b'++-- An API for animating a signal function when some other library+-- needs to own the top-level control flow:++-- reactimate's state, maintained across samples:+data ReactState a b = ReactState {+ rsActuate :: ReactHandle a b -> Bool -> b -> IO Bool,+ rsSF :: SF' a b,+ rsA :: a,+ rsB :: b+ } ++type ReactHandle a b = IORef (ReactState a b)++-- initialize top-level reaction handle+reactInit :: IO a -- init+ -> (ReactHandle a b -> Bool -> b -> IO Bool) -- actuate+ -> SF a b+ -> IO (ReactHandle a b)+reactInit init actuate (SF {sfTF = tf0}) = + do a0 <- init+ let (sf,b0) = tf0 a0+ -- TODO: really need to fix this interface, since right now we+ -- just ignore termination at time 0:+ r <- newIORef (ReactState {rsActuate = actuate, rsSF = sf,+ rsA = a0, rsB = b0 })+ done <- actuate r True b0+ return r++-- process a single input sample:+react :: ReactHandle a b+ -> (DTime,Maybe a)+ -> IO Bool+react rh (dt,ma') = + do rs@(ReactState {rsActuate = actuate,+ rsSF = sf,+ rsA = a,+ rsB = b }) <- readIORef rh+ let a' = maybe a id ma'+ (sf',b') = (sfTF' sf) dt a'+ writeIORef rh (rs {rsSF = sf',rsA = a',rsB = b'})+ done <- actuate rh True b'+ return done +++------------------------------------------------------------------------------+-- Embedding+------------------------------------------------------------------------------++-- New embed interface. We will probably have to revisit this. To run an+-- embedded signal function while retaining full control (e.g. start and+-- stop at will), one would probably need a continuation based interface+-- (as well as a continuation based underlying implementation).+--+-- E.g. here are interesting alternative (or maybe complementary)+-- signatures:+--+-- sample :: SF a b -> SF (Event a) (Event b)+-- sample' :: SF a b -> SF (Event (DTime, a)) (Event b)++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 a_prev sf [] = []+ loop a_prev sf ((dt, ma) : dtas) =+ b : (a `seq` b `seq` (loop a sf' dtas))+ where+ a = maybe a_prev id ma+ (sf', b) = (sfTF' sf) dt a+++-- Synchronous embedding. The embedded signal function is run on the supplied+-- input and time stream at a given (but variable) ratio >= 0 to the outer+-- time flow. When the ratio is 0, the embedded signal function is paused.++-- !!! Should "dropped frames" be forced to avoid space leaks?+-- !!! It's kind of hard to se why, but "frame dropping" was a problem+-- !!! in the old robot simulator. Try to find an example!++embedSynch :: SF a b -> (a, [(DTime, Maybe a)]) -> SF Double b+embedSynch sf0 (a0, dtas) = SF {sfTF = tf0}+ where+ tts = scanl (\t (dt, _) -> t + dt) 0 dtas+ bbs@(b:_) = embed sf0 (a0, dtas)++ tf0 r = (esAux 0 (zip tts bbs), b)++ esAux _ [] = intErr "AFRP" "embedSynch" "Empty list!"+ esAux tp_prev tbtbs = SFTIVar {sfTF' = tf}+ 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 tp tbtbs@[(t, b)] = (b, tbtbs)+ advance tp tbtbtbs@((_, b) : tbtbs@((t', _) : _))+ | tp < t' = (b, tbtbtbs)+ | t' <= tp = advance tp tbtbs+++deltaEncode :: Eq a => DTime -> [a] -> (a, [(DTime, Maybe a)])+deltaEncode _ [] = usrErr "AFRP" "deltaEncode" "Empty input list."+deltaEncode dt aas@(_:_) = deltaEncodeBy (==) dt aas+++deltaEncodeBy :: (a -> a -> Bool) -> DTime -> [a] -> (a, [(DTime, Maybe a)])+deltaEncodeBy _ _ [] = usrErr "AFRP" "deltaEncodeBy" "Empty input list."+deltaEncodeBy eq dt (a0:as) = (a0, zip (repeat dt) (debAux a0 as))+ where+ debAux a_prev [] = []+ debAux a_prev (a:as) | a `eq` a_prev = Nothing : debAux a as+ | otherwise = Just a : debAux a as
+ src/AFRPAffineSpace.hs view
@@ -0,0 +1,41 @@+{- $Id: AFRPAffineSpace.hs,v 1.2 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPAffineSpace * +* Purpose: Affine space type relation. * +* Authors: Henrik Nilsson and Antony Courtney * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPAffineSpace where + +import AFRPVectorSpace + +------------------------------------------------------------------------------ +-- Affine Space type relation +------------------------------------------------------------------------------ + +infix 6 .+^, .-^, .-. + +-- Maybe origin should not be a class method, even though an origin +-- can be assocoated with any affine space. +-- Maybe distance should not be a class method, in which case the constraint +-- on the coefficient space (a) could be Fractional (i.e., a Field), which +-- seems closer to the mathematical definition of affine space, provided +-- the constraint on the coefficient space for VectorSpace is also Fractional. + +-- Minimal instance: origin, .+^, .^. +class (Floating a, VectorSpace v a) => AffineSpace p v a | p -> v, v -> a where + origin :: p + (.+^) :: p -> v -> p + (.-^) :: p -> v -> p + (.-.) :: p -> p -> v + distance :: p -> p -> a + + p .-^ v = p .+^ (negateVector v) + + distance p1 p2 = norm (p1 .-. p2)
+ src/AFRPDiagnostics.hs view
@@ -0,0 +1,19 @@+{- $Id: AFRPDiagnostics.hs,v 1.3 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPDiagnostics * +* Purpose: Standardized error-reporting for AFRP * +* Authors: Henrik Nilsson and Antony Courtney * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPDiagnostics where + +usrErr mn fn msg = error (mn ++ "." ++ fn ++ ": " ++ msg) + +intErr mn fn msg = error ("[internal error] " ++ mn ++ "." ++ fn ++ ": " + ++ msg)
+ src/AFRPEvent.hs view
@@ -0,0 +1,286 @@+{- $Id: AFRPEvent.hs,v 1.17 2003/12/19 15:31:50 henrik Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPEvent * +* Purpose: Definition of AFRP Event type. * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +-- Note on naming conventions used in this module. +-- +-- Names here might have to be rethought. It's really a bit messy. +-- In general, the aim has been short and convenient names (like "tag", +-- "attach", "lMerge") and thus we have tried to stay away from suffixing/ +-- prefixing conventions. E.g. "Event" as a common suffix would be very +-- verbose. +-- +-- However, part of the names come from a desire to stay close to similar +-- functions for the Maybe type. e.g. "event", "fromEvent", "isEvent". +-- In many cases, this use of "Event" can could understood to refer to the +-- *constructor* "Event", not to the type name "Event". Thus this use of +-- event should not be seen as a suffixing-with-type-name convention. But +-- that is obviously not easy to see, and, more over, interpreting "Event" +-- as the name of the type might make equally good or better sense. E.g. +-- "fromEvent" can also be seen as a function taking an event signal, +-- which is a *partial* function on time, to a normal signal. The latter is +-- then undefined when the source event function is undefined. +-- +-- In other cases, it has been necessary to somehow stay out of the way of +-- names used by the prelude or other commonly imported modules/modules +-- which could be expected to be used heavily in AFRP code. In those cases +-- a suffix "E" have been added. Examples are "filterE" (exists in Prelude) +-- and "joinE" (exists in Monad). Maybe the suffix isn't necessary in the +-- last case. +-- +-- Some functions (actually only one currently, mapFilterE") have got an "E" +-- suffix just because they're closely related (by name or semantics) to one +-- which already has an "E" suffix. Another candidate would be "splitE" to +-- complement "joinE". But events carrying pairs could obviously have other +-- sources than a "joinE", so currently it is called "split". +-- +-- 2003-05-19: Actually, have now changed to "splitE" to avoid a clash +-- with the method "split" in the class RandomGen. +-- +-- 2003-05-19: What about "gate"? Stands out compared to e.g. "filterE". +-- +-- Currently the "E" suffix is considered an exception. Maybe we should use +-- completely different names to avoid the "E" suffix. If the functions +-- are not used that often, "Event" might be approriate. Alternatively the +-- suffix "E" should be adopted globaly (except if the name already contains +-- "event" in some form?). +-- +-- Arguably, having both a type "Event" and a constructor "Event" is confusing +-- since there are more than one constructor. But the name "Event" for the +-- constructor is quite apt. It's really the type name that is wrong. But +-- no one has found a better name, and changing it would be a really major +-- undertaking. Yes, the constructor "Event" is not exported, but we still +-- need to talk conceptually about them. On the other hand, if we consider +-- Event-signals as partial functions on time, maybe it isn't so confusing: +-- they just don't have a value between events, so "NoEvent" does not really +-- exist conceptually. +-- +-- ToDo: +-- - Either: reveal NoEvent and Event +-- or: introcuce "event = Event", call what's now "event" "fromEvent", +-- and call what's now called "fromEvent" something else, like +-- "unsafeFromEvent"??? Better, dump it! After all, using current +-- names, "fromEvent = event undefined"! + +module AFRPEvent where + +import AFRPDiagnostics +import AFRPForceable + + +infixl 8 `tag`, `attach`, `gate` +infixl 7 `joinE` +infixl 6 `lMerge`, `rMerge`, `merge` + + +------------------------------------------------------------------------------ +-- The Event type +------------------------------------------------------------------------------ + +-- The type Event represents a single possible event occurrence. +-- It is isomorphic to Maybe, but its constructors are not exposed outside +-- the AFRP implementation. +-- There could possibly be further constructors, but note that the NeverEvent- +-- idea does not work, at least not in the current AFRP implementation. +-- Also note that it unfortunately is possible to partially break the +-- abstractions through judicious use of e.g. snap and switching. + +data Event a = NoEvent + | Event a + + +-- Make the NoEvent constructor available. Useful e.g. for initialization, +-- ((-->) & friends), and it's easily available anyway (e.g. mergeEvents []). +noEvent :: Event a +noEvent = NoEvent + + +-- Suppress any event in the first component of a pair. +noEventFst :: (Event a, b) -> (Event c, b) +noEventFst (_, b) = (NoEvent, b) + + +-- Suppress any event in the second component of a pair. +noEventSnd :: (a, Event b) -> (a, Event c) +noEventSnd (a, _) = (a, NoEvent) + + +------------------------------------------------------------------------------ +-- Eq instance +------------------------------------------------------------------------------ + +-- Right now, we could derive this instance. But that could possibly change. + +instance Eq a => Eq (Event a) where + NoEvent == NoEvent = True + (Event x) == (Event y) = x == y + _ == _ = False + + +------------------------------------------------------------------------------ +-- Ord instance +------------------------------------------------------------------------------ + +instance Ord a => Ord (Event a) where + compare NoEvent NoEvent = EQ + compare NoEvent (Event _) = LT + compare (Event _) NoEvent = GT + compare (Event x) (Event y) = compare x y + + +------------------------------------------------------------------------------ +-- Functor instance +------------------------------------------------------------------------------ + +instance Functor Event where + fmap f NoEvent = NoEvent + fmap f (Event a) = Event (f a) + + +------------------------------------------------------------------------------ +-- Forceable instance +------------------------------------------------------------------------------ + +instance Forceable a => Forceable (Event a) where + force ea@NoEvent = ea + force ea@(Event a) = force a `seq` ea + + +------------------------------------------------------------------------------ +-- Internal utilities for event construction +------------------------------------------------------------------------------ + +-- These utilities are to be considered strictly internal to AFRP for the +-- time being. + +maybeToEvent :: Maybe a -> Event a +maybeToEvent Nothing = NoEvent +maybeToEvent (Just a) = Event a + + +------------------------------------------------------------------------------ +-- Utility functions similar to those available for Maybe +------------------------------------------------------------------------------ + +-- An event-based version of the maybe function. +event :: a -> (b -> a) -> Event b -> a +event a _ NoEvent = a +event _ f (Event b) = f b + +fromEvent :: Event a -> a +fromEvent (Event a) = a +fromEvent NoEvent = usrErr "AFRP" "fromEvent" "Not an event." + +isEvent :: Event a -> Bool +isEvent NoEvent = False +isEvent (Event _) = True + +isNoEvent :: Event a -> Bool +isNoEvent = not . isEvent + + +------------------------------------------------------------------------------ +-- Event tagging +------------------------------------------------------------------------------ + +-- Tags an (occurring) event with a value ("replacing" the old value). +tag :: Event a -> b -> Event b +e `tag` b = fmap (const b) e + + +-- Attaches an extra value to the value of an occurring event. +attach :: Event a -> b -> Event (a, b) +e `attach` b = fmap (\a -> (a, b)) e + + +------------------------------------------------------------------------------ +-- Event merging (disjunction) and joining (conjunction) +------------------------------------------------------------------------------ + +-- Left-biased event merge. +lMerge :: Event a -> Event a -> Event a +le `lMerge` re = event re Event le + + +-- Right-biased event merge. +rMerge :: Event a -> Event a -> Event a +le `rMerge` re = event le Event re + + +-- Unbiased event merge: simultaneous occurrence is an error. +merge :: Event a -> Event a -> Event a +merge = mergeBy (usrErr "AFRP" "merge" "Simultaneous event occurrence.") + + +-- Event merge paramterezied on the conflict resolution function. +mergeBy :: (a -> a -> a) -> Event a -> Event a -> Event a +mergeBy _ NoEvent NoEvent = NoEvent +mergeBy _ le@(Event _) NoEvent = le +mergeBy _ NoEvent re@(Event _) = re +mergeBy resolve (Event l) (Event r) = Event (resolve l r) + + +-- A generic event merge utility: +mapMerge :: (a -> c) -> (b -> c) -> (a -> b -> c) + -> Event a -> Event b -> Event c +mapMerge _ _ _ NoEvent NoEvent = NoEvent +mapMerge lf _ _ (Event l) NoEvent = Event (lf l) +mapMerge _ rf _ NoEvent (Event r) = Event (rf r) +mapMerge _ _ lrf (Event l) (Event r) = Event (lrf l r) + +-- Merging of a list of events; foremost event has priority. +mergeEvents :: [Event a] -> Event a +mergeEvents = foldr lMerge NoEvent + + +-- Collects simultaneous event occurrences; no event if none. +catEvents :: [Event a] -> Event [a] +catEvents eas = case [ a | Event a <- eas ] of + [] -> NoEvent + as -> Event as + + +-- Join (conjucntion) of two events. +joinE :: Event a -> Event b -> Event (a,b) +joinE NoEvent _ = NoEvent +joinE _ NoEvent = NoEvent +joinE (Event l) (Event r) = Event (l,r) + + +-- Split event carrying pairs into two events. +splitE :: Event (a,b) -> (Event a, Event b) +splitE NoEvent = (NoEvent, NoEvent) +splitE (Event (a,b)) = (Event a, Event b) + + +------------------------------------------------------------------------------ +-- Event filtering +------------------------------------------------------------------------------ + +-- Filter out events that don't satisfy some predicate. +filterE :: (a -> Bool) -> Event a -> Event a +filterE p e@(Event a) = if (p a) then e else NoEvent +filterE _ NoEvent = NoEvent + + +-- Combined event mapping and filtering. +mapFilterE :: (a -> Maybe b) -> Event a -> Event b +mapFilterE _ NoEvent = NoEvent +mapFilterE f (Event a) = case f a of + Nothing -> NoEvent + Just b -> Event b + + +-- Enable/disable event occurences based on an external condition. +gate :: Event a -> Bool -> Event a +_ `gate` False = NoEvent +e `gate` True = e
+ src/AFRPForceable.hs view
@@ -0,0 +1,76 @@+{- $Id: AFRPForceable.hs,v 1.2 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPForceable * +* Purpose: Hyperstrict evaluation. * +* Author: Zhanyong Wan * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPForceable where + + +class Forceable a where + force :: a -> a + + +instance Forceable Int where + force = id + + +instance Forceable Integer where + force = id + + +instance Forceable Double where + force = id + + +instance Forceable Float where + force = id + + +instance Forceable Bool where + force = id + + +instance Forceable () where + force = id + + +instance Forceable Char where + force = id + + +instance (Forceable a, Forceable b) => Forceable (a, b) where + force p@(a, b) = force a `seq` force b `seq` p + + +instance (Forceable a, Forceable b, Forceable c) => Forceable (a, b, c) where + force p@(a, b, c) = force a `seq` force b `seq` force c `seq` p + + +instance (Forceable a, Forceable b, Forceable c, Forceable d) => + Forceable (a, b, c, d) where + force p@(a, b, c, d) = + force a `seq` force b `seq` force c `seq` force d `seq` p + + +instance (Forceable a, Forceable b, Forceable c, Forceable d, Forceable e) => + Forceable (a, b, c, d, e) where + force p@(a, b, c, d, e) = + force a `seq` force b `seq` force c `seq` force d `seq` force e `seq` p + + +instance (Forceable a) => Forceable [a] where + force nil@[] = nil + force xs@(x:xs') = force x `seq` force xs' `seq` xs + + +instance (Forceable a) => Forceable (Maybe a) where + force mx@Nothing = mx + force mx@(Just x) = force x `seq` mx
+ src/AFRPGeometry.hs view
@@ -0,0 +1,30 @@+{- $Id: AFRPGeometry.hs,v 1.3 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPGeometry * +* Purpose: Basic geometrical abstractions. * +* Authors: Henrik Nilsson and Antony Courtney * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPGeometry ( + module AFRPVectorSpace, + module AFRPAffineSpace, + module AFRPVector2, + module AFRPVector3, + module AFRPPoint2, + module AFRPPoint3 +) where + +import AFRPVectorSpace +import AFRPAffineSpace +import AFRPVector2 +import AFRPVector3 +import AFRPPoint2 +import AFRPPoint3 + +
+ src/AFRPInternals.hs view
@@ -0,0 +1,37 @@+{- $Id: AFRPInternals.hs,v 1.2 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPInternals * +* Purpose: An interface giving access to some of the internal * +* details of the AFRP implementation. * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +-- This interface is indended to be used when the need arises to break +-- abstraction barriers, e.g. for interfacing AFRP to the real world, for +-- debugging purposes, or the like. Be aware that the internal details +-- may change. Relying on this interface means that your code is not +-- insulated against such changes. + +module AFRPInternals ( + Event(..) -- The event type, its constructors, and instances. +) where + +import AFRPEvent + + +------------------------------------------------------------------------------ +-- Extra Event instances +------------------------------------------------------------------------------ + +instance Show a => Show (Event a) where + showsPrec d NoEvent = showString "NoEvent" + showsPrec d (Event a) = showParen (d >= 10) + (showString "Event " . showsPrec 10 a) + +
+ src/AFRPMergeableRecord.hs view
@@ -0,0 +1,78 @@+{- $Id: AFRPMergeableRecord.hs,v 1.4 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPMergeableRecord * +* Purpose: Framework for record merging. * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +-- Idea: +-- MergeableRecord is intended to be a super class for classes providing +-- update operations on records. The ADT induced by such a set of operations +-- can be considered a "mergeable record", which can be merged into larger +-- mergeable records essentially by function composition. Finalization turns +-- a mergeable record into a record. +-- +-- Typical use: +-- Given +-- +-- data Foo = Foo {l1 :: T1, l2 :: T2} +-- +-- one define a mergeable record type (MR Foo) by the following instance: +-- +-- instance MergeableRecord Foo where +-- mrDefault = Foo {l1 = v1_dflt, l2 = v2_dflt} +-- +-- Typically, one would also provide definitions for setting the fields, +-- possibly (but not necessarily) overloaded: +-- +-- instance HasL1 Foo where +-- setL1 v = mrMake (\foo -> foo {l1 = v}) +-- +-- Now Foo records can be created as follows: +-- +-- let foo1 = setL1 v1 +-- ... +-- let foo2 = setL2 v2 ~+~ foo1 +-- ... +-- let foo<N> = setL1 vN ~+~ foo<N-1> +-- let fooFinal = mrFinalize foo<N> + +module AFRPMergeableRecord ( + MergeableRecord(..), + MR, -- Abstract + mrMake, + (~+~), + mrMerge, + mrFinalize +) where + +class MergeableRecord a where + mrDefault :: a + + +-- Type constructor for mergeable records. +newtype MergeableRecord a => MR a = MR (a -> a) + + +-- Construction of a mergeable record. +mrMake :: MergeableRecord a => (a -> a) -> MR a +mrMake f = (MR f) + + +-- Merge two mergeable records. Left "overrides" in case of conflict. +(~+~) :: MergeableRecord a => MR a -> MR a -> MR a +(MR f1) ~+~ (MR f2) = MR (f1 . f2) + +mrMerge :: MergeableRecord a => MR a -> MR a -> MR a +mrMerge = (~+~) + + +-- Finalization: turn a mergeable record into a record. +mrFinalize :: MergeableRecord a => MR a -> a +mrFinalize (MR f) = f mrDefault
+ src/AFRPMiscellany.hs view
@@ -0,0 +1,121 @@+{- $Id: AFRPMiscellany.hs,v 1.4 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPMiscellany * +* Purpose: Collection of entities that really should be part * +* of the Haskell 98 prelude or simply have no better * +* home. * +* Authors: Henrik Nilsson and Antony Courtney * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPMiscellany ( +-- Reverse function composition + ( # ), -- :: (a -> b) -> (b -> c) -> (a -> c), infixl 9 + +-- Arrow plumbing aids + dup, -- :: a -> (a,a) + swap, -- :: (a,b) -> (b,a) + +-- Maps over lists of pairs + mapFst, -- :: (a -> b) -> [(a,c)] -> [(b,c)] + mapSnd, -- :: (a -> b) -> [(c,a)] -> [(c,b)] + +-- Generalized tuple selectors + sel3_1, sel3_2, sel3_3, + sel4_1, sel4_2, sel4_3, sel4_4, + sel5_1, sel5_2, sel5_3, sel5_4, sel5_5, + +-- Floating point utilities + fDiv, -- :: (RealFrac a, Integral b) => a -> a -> b + fMod, -- :: RealFrac a => a -> a -> a + fDivMod -- :: (RealFrac a, Integral b) => a -> a -> (b, a) +) where + +infixl 9 # +infixl 7 `fDiv`, `fMod` + + +------------------------------------------------------------------------------ +-- Reverse function composition +------------------------------------------------------------------------------ + +( # ) :: (a -> b) -> (b -> c) -> (a -> c) +f # g = g . f + + +------------------------------------------------------------------------------ +-- Arrow plumbing aids +------------------------------------------------------------------------------ + +dup :: a -> (a,a) +dup x = (x,x) + +swap :: (a,b) -> (b,a) +swap ~(x,y) = (y,x) + + +------------------------------------------------------------------------------ +-- Maps over lists of pairs +------------------------------------------------------------------------------ + +mapFst :: (a -> b) -> [(a,c)] -> [(b,c)] +mapFst f [] = [] +mapFst f ((x, y) : xys) = (f x, y) : mapFst f xys + +mapSnd :: (a -> b) -> [(c,a)] -> [(c,b)] +mapSnd f [] = [] +mapSnd f ((x, y) : xys) = (x, f y) : mapSnd f xys + + +------------------------------------------------------------------------------ +-- Generalized tuple selectors +------------------------------------------------------------------------------ + +-- Triples + +sel3_1 (x,_,_) = x +sel3_2 (_,x,_) = x +sel3_3 (_,_,x) = x + + +-- 4-tuples + +sel4_1 (x,_,_,_) = x +sel4_2 (_,x,_,_) = x +sel4_3 (_,_,x,_) = x +sel4_4 (_,_,_,x) = x + + +-- 5-tuples + +sel5_1 (x,_,_,_,_) = x +sel5_2 (_,x,_,_,_) = x +sel5_3 (_,_,x,_,_) = x +sel5_4 (_,_,_,x,_) = x +sel5_5 (_,_,_,_,x) = x + + +------------------------------------------------------------------------------ +-- Floating point utilities +------------------------------------------------------------------------------ + +-- Floating-point div and modulo operators. + +fDiv :: (RealFrac a, Integral b) => a -> a -> b +fDiv x y = fst (fDivMod x y) + + +fMod :: RealFrac a => a -> a -> a +fMod x y = snd (fDivMod x y) + + +fDivMod :: (RealFrac a, Integral b) => a -> a -> (b, a) +fDivMod x y = (q, r) + where + q = (floor (x/y)) + r = x - fromIntegral q * y
+ src/AFRPPoint2.hs view
@@ -0,0 +1,60 @@+{- $Id: AFRPPoint2.hs,v 1.3 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPPoint2 * +* Purpose: 2D point abstraction (R^2). * +* Authors: Henrik Nilsson and Antony Courtney * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPPoint2 ( + module AFRPVectorSpace, + module AFRPAffineSpace, + module AFRPVector2, + Point2(..), -- Non-abstract, instance of AffineSpace + point2X, -- :: RealFloat a => Point2 a -> a + point2Y -- :: RealFloat a => Point2 a -> a +) where + +import AFRPVectorSpace +import AFRPAffineSpace +import AFRPVector2 +import AFRPForceable + +------------------------------------------------------------------------------ +-- 2D point, constructors and selectors. +------------------------------------------------------------------------------ + +data RealFloat a => Point2 a = Point2 !a !a deriving Eq + +point2X :: RealFloat a => Point2 a -> a +point2X (Point2 x _) = x + +point2Y :: RealFloat a => Point2 a -> a +point2Y (Point2 _ y) = y + + +------------------------------------------------------------------------------ +-- Affine space instance +------------------------------------------------------------------------------ + +instance RealFloat a => AffineSpace (Point2 a) (Vector2 a) a where + origin = Point2 0 0 + + (Point2 x y) .+^ v = Point2 (x + vector2X v) (y + vector2Y v) + + (Point2 x y) .-^ v = Point2 (x - vector2X v) (y - vector2Y v) + + (Point2 x1 y1) .-. (Point2 x2 y2) = vector2 (x1 - x2) (y1 - y2) + + +------------------------------------------------------------------------------ +-- Forceable instance +------------------------------------------------------------------------------ + +instance RealFloat a => Forceable (Point2 a) where + force = id
+ src/AFRPPoint3.hs view
@@ -0,0 +1,67 @@+{- $Id: AFRPPoint3.hs,v 1.3 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPPoint3 * +* Purpose: 3D point abstraction (R^3). * +* Authors: Henrik Nilsson and Antony Courtney * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPPoint3 ( + module AFRPVectorSpace, + module AFRPAffineSpace, + module AFRPVector3, + Point3(..), -- Non-abstract, instance of AffineSpace + point3X, -- :: RealFloat a => Point3 a -> a + point3Y, -- :: RealFloat a => Point3 a -> a + point3Z -- :: RealFloat a => Point3 a -> a +) where + +import AFRPVectorSpace +import AFRPAffineSpace +import AFRPVector3 +import AFRPForceable + +------------------------------------------------------------------------------ +-- 3D point, constructors and selectors. +------------------------------------------------------------------------------ + +data RealFloat a => Point3 a = Point3 !a !a !a deriving Eq + +point3X :: RealFloat a => Point3 a -> a +point3X (Point3 x _ _) = x + +point3Y :: RealFloat a => Point3 a -> a +point3Y (Point3 _ y _) = y + +point3Z :: RealFloat a => Point3 a -> a +point3Z (Point3 _ _ z) = z + + +------------------------------------------------------------------------------ +-- Affine space instance +------------------------------------------------------------------------------ + +instance RealFloat a => AffineSpace (Point3 a) (Vector3 a) a where + origin = Point3 0 0 0 + + (Point3 x y z) .+^ v = + Point3 (x + vector3X v) (y + vector3Y v) (z + vector3Z v) + + (Point3 x y z) .-^ v = + Point3 (x - vector3X v) (y - vector3Y v) (z - vector3Z v) + + (Point3 x1 y1 z1) .-. (Point3 x2 y2 z2) = + vector3 (x1 - x2) (y1 - y2) (z1 - z2) + + +------------------------------------------------------------------------------ +-- Forceable instance +------------------------------------------------------------------------------ + +instance RealFloat a => Forceable (Point3 a) where + force = id
+ src/AFRPTask.hs view
@@ -0,0 +1,219 @@+{- $Id: AFRPTask.hs,v 1.6 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTask * +* Purpose: Task abstraction on top of signal transformers. * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPTask ( + Task, + mkTask, -- :: SF a (b, Event c) -> Task a b c + runTask, -- :: Task a b c -> SF a (Either b c) -- Might change. + runTask_, -- :: Task a b c -> SF a b + taskToSF, -- :: Task a b c -> SF a (b, Event c) -- Might change. + constT, -- :: b -> Task a b c + sleepT, -- :: Time -> b -> Task a b () + snapT, -- :: Task a b a + timeOut, -- :: Task a b c -> Time -> Task a b (Maybe c) + abortWhen, -- :: Task a b c -> SF a (Event d) -> Task a b (Either c d) + repeatUntil,-- :: Monad m => m a -> (a -> Bool) -> m a + for, -- :: Monad m => a -> (a -> a) -> (a -> Bool) -> m b -> m () + forAll, -- :: Monad m => [a] -> (a -> m b) -> m () + forEver -- :: Monad m => m a -> m b +) where + +import AFRP +import AFRPUtilities (snap) +import AFRPDiagnostics + +infixl 0 `timeOut`, `abortWhen`, `repeatUntil` + + +------------------------------------------------------------------------------ +-- The Task type +------------------------------------------------------------------------------ + +-- CPS-based representation allowing a termination to be detected. +-- (Note the rank 2 polymorphic type!) +-- The representation can be changed if necessary, but the Monad laws +-- follow trivially in this case. +newtype Task a b c = + Task (forall d . (c -> SF a (Either b d)) -> SF a (Either b d)) + + +unTask :: Task a b c -> ((c -> SF a (Either b d)) -> SF a (Either b d)) +unTask (Task f) = f + + +mkTask :: SF a (b, Event c) -> Task a b c +mkTask st = Task (switch (st >>> first (arr Left))) + + +-- "Runs" a task (unusually bad name?). The output from the resulting +-- signal transformer is tagged with Left while the underlying task is +-- running. Once the task has terminated, the output goes constant with +-- the value Right x, where x is the value of the terminating event. +runTask :: Task a b c -> SF a (Either b c) +runTask tk = (unTask tk) (\c -> constant (Right c)) + + +-- Runs a task. The output becomes undefined once the underlying task has +-- terminated. Convenient e.g. for tasks which are known not to terminate. +runTask_ :: Task a b c -> SF a b +runTask_ tk = runTask tk + >>> arr (either id (usrErr "AFRPTask" "runTask_" + "Task terminated!")) + + +-- Seems as if the following is convenient after all. Suitable name??? +-- Maybe that implies a representation change for Tasks? +-- Law: mkTask (taskToSF task) = task (but not (quite) vice versa.) +taskToSF :: Task a b c -> SF a (b, Event c) +taskToSF tk = runTask tk + >>> (arr (either id ((usrErr "AFRPTask" "runTask_" + "Task terminated!"))) + &&& edgeBy isEdge (Left undefined)) + where + isEdge (Left _) (Left _) = Nothing + isEdge (Left _) (Right c) = Just c + isEdge (Right _) (Right _) = Nothing + isEdge (Right _) (Left _) = Nothing + + +------------------------------------------------------------------------------ +-- Monad instance +------------------------------------------------------------------------------ + +instance Monad (Task a b) where + tk >>= f = Task (\k -> (unTask tk) (\c -> unTask (f c) k)) + return x = Task (\k -> k x) + +{- +Let's check the monad laws: + + t >>= return + = \k -> t (\c -> return c k) + = \k -> t (\c -> (\x -> \k -> k x) c k) + = \k -> t (\c -> (\x -> \k' -> k' x) c k) + = \k -> t (\c -> k c) + = \k -> t k + = t + QED + + return x >>= f + = \k -> (return x) (\c -> f c k) + = \k -> (\k -> k x) (\c -> f c k) + = \k -> (\k' -> k' x) (\c -> f c k) + = \k -> (\c -> f c k) x + = \k -> f x k + = f x + QED + + (t >>= f) >>= g + = \k -> (t >>= f) (\c -> g c k) + = \k -> (\k' -> t (\c' -> f c' k')) (\c -> g c k) + = \k -> t (\c' -> f c' (\c -> g c k)) + = \k -> t (\c' -> (\x -> \k' -> f x (\c -> g c k')) c' k) + = \k -> t (\c' -> (\x -> f x >>= g) c' k) + = t >>= (\x -> f x >>= g) + QED + +No surprises (obviously, since this is essentially just the CPS monad). +-} + + +------------------------------------------------------------------------------ +-- Basic tasks +------------------------------------------------------------------------------ + +-- Non-terminating task with constant output b. +constT :: b -> Task a b c +constT b = mkTask (constant b &&& never) + + +-- "Sleeps" for t seconds with constant output b. +sleepT :: Time -> b -> Task a b () +sleepT t b = mkTask (constant b &&& after t ()) + + +-- Takes a "snapshot" of the input and terminates immediately with the input +-- value as the result. No time passes; law: +-- +-- snapT >> snapT = snapT +-- +snapT :: Task a b a +snapT = mkTask (constant (intErr "AFRPTask" "snapT" "Bad switch?") &&& snap) + + +------------------------------------------------------------------------------ +-- Basic tasks combinators +------------------------------------------------------------------------------ + +-- Impose a time out on a task. +timeOut :: Task a b c -> Time -> Task a b (Maybe c) +tk `timeOut` t = mkTask ((taskToSF tk &&& after t ()) >>> arr aux) + where + aux ((b, ec), et) = (b, (lMerge (fmap Just ec) + (fmap (const Nothing) et))) + + +-- Run a "guarding" event source (SF a (Event b)) in parallel with a +-- (possibly non-terminating) task. The task will be aborted at the +-- first occurrence of the event source (if it has not terminated itself +-- before that). Useful for separating sequencing and termination concerns. +-- E.g. we can do something "useful", but in parallel watch for a (exceptional) +-- condition which should terminate that activity, whithout having to check +-- for that condition explicitly during each and every phase of the activity. +-- Example: tsk `abortWhen` lbp +abortWhen :: Task a b c -> SF a (Event d) -> Task a b (Either c d) +tk `abortWhen` est = mkTask ((taskToSF tk &&& est) >>> arr aux) + where + aux ((b, ec), ed) = (b, (lMerge (fmap Left ec) (fmap Right ed))) + + +------------------------------------------------------------------------------ +-- Loops +------------------------------------------------------------------------------ + +-- These are general monadic combinators. Maybe they don't really belong here. + +-- Repeat m until result satisfies the predicate p +repeatUntil :: Monad m => m a -> (a -> Bool) -> m a +m `repeatUntil` p = m >>= \x -> if not (p x) then repeatUntil m p else return x + + +-- C-style for-loop. +-- Example: for 0 (+1) (>=10) ... +for :: Monad m => a -> (a -> a) -> (a -> Bool) -> m b -> m () +for i f p m = if p i then m >> for (f i) f p m else return () + + +-- Perform the monadic operation for each element in the list. +forAll :: Monad m => [a] -> (a -> m b) -> m () +forAll = flip mapM_ + + +-- Repeat m for ever. +forEver :: Monad m => m a -> m b +forEver m = m >> forEver m + + +-- Alternatives/other potentially useful signatures: +-- until :: a -> (a -> M a) -> (a -> Bool) -> M a +-- for: a -> b -> (a -> b -> a) -> (a -> b -> Bool) -> (a -> b -> M b) -> M b +-- while??? It could be: +-- while :: a -> (a -> Bool) -> (a -> M a) -> M a + + +------------------------------------------------------------------------------ +-- Monad transformers? +------------------------------------------------------------------------------ + +-- What about monad transformers if we want to compose this monad with +-- other capabilities???
+ src/AFRPUtilities.hs view
@@ -0,0 +1,278 @@+{- $Id: AFRPUtilities.hs,v 1.8 2003/12/19 15:31:50 henrik Exp $+******************************************************************************+* A F R P *+* *+* Module: AFRPUtilities *+* Purpose: Derived utility definitions. *+* Authors: Antony Courtney and Henrik Nilsson *+* *+* Copyright (c) Yale University, 2003 *+* *+******************************************************************************+-}++-- ToDo:+-- * Possibly add+-- impulse :: VectorSpace a k => a -> Event a+-- But to do that, we need access to Event, which we currently do not have.+-- * The general arrow utilities should be moved to a module+-- AFRPArrowUtilities.+-- * I'm not sure structuring the AFRP "core" according to what is+-- core functionality and what's not is all that useful. There are+-- many cases where we want to implement combinators that fairly+-- easily could be implemented in terms of others as primitives simply+-- because we expect that that implementation is going to be much more+-- efficient, and that the combinators are used sufficiently often to+-- warrant doing this. E.g. "switch" should be a primitive, even though+-- it could be derived from "pSwitch".+-- * Reconsider "recur". If an event source has an immediate occurrence,+-- we'll get into a loop. For example: recur now. Maybe suppress+-- initial occurrences? Initial occurrences are rather pointless in this+-- case anyway.+++module AFRPUtilities (++-- Liftings+ arr2, -- :: Arrow a => (b->c->d) -> a (b,c) d+ arr3, -- :: Arrow a => (b->c->d->e) -> a (b,c,d) e+ arr4, -- :: Arrow a => (b->c->d->e->f) -> a (b,c,d,e) f+ arr5, -- :: Arrow a => (b->c->d->e->f->g) -> a (b,c,d,e,f) g+ lift0, -- :: Arrow a => c -> a b c+ lift1, -- :: Arrow a => (c->d) -> (a b c->a b d)+ lift2, -- :: Arrow a => (c->d->e) -> (a b c->a b d->a b e)+ lift3, -- :: Arrow a => (c->d->e->f) -> (a b c-> ... ->a b f)+ lift4, -- :: Arrow a => (c->d->e->f->g) -> (a b c->...->a b g)+ lift5, -- :: Arrow a => (c->d->e->f->g->h)->(a b c->...a b h)++-- Event sources+ snap, -- :: SF a (Event a)+ snapAfter, -- :: Time -> SF a (Event a)+ sample, -- :: Time -> SF a (Event a)+ recur, -- :: SF a (Event b) -> SF a (Event b)++-- Parallel composition/switchers with "zip" routing+ parZ, -- [SF a b] -> SF [a] [b]+ pSwitchZ, -- [SF a b] -> SF ([a],[b]) (Event c)+ -- -> ([SF a b] -> c -> SF [a] [b]) -> SF [a] [b]+ dpSwitchZ, -- [SF a b] -> SF ([a],[b]) (Event c)+ -- -> ([SF a b] -> c ->SF [a] [b]) -> SF [a] [b]+ rpSwitchZ, -- [SF a b] -> SF ([a], Event ([SF a b]->[SF a b])) [b]+ drpSwitchZ, -- [SF a b] -> SF ([a], Event ([SF a b]->[SF a b])) [b]++-- Guards and automata-oriented combinators+ provided, -- :: (a -> Bool) -> SF a b -> SF a b -> SF a b++-- Wave-form generation+ dHold, -- :: a -> SF (Event a) a+ dTrackAndHold, -- :: a -> SF (Maybe a) a++-- Accumulators+ accumHold, -- :: a -> SF (Event (a -> a)) a+ dAccumHold, -- :: a -> SF (Event (a -> a)) a+ accumHoldBy, -- :: (b -> a -> b) -> b -> SF (Event a) b+ dAccumHoldBy, -- :: (b -> a -> b) -> b -> SF (Event a) b+ count, -- :: Integral b => SF (Event a) (Event b)++-- Delays+ fby, -- :: b -> SF a b -> SF a b, infixr 0++-- Integrals+ impulseIntegral -- :: VectorSpace a k => SF (a, Event a) a+) where++import AFRPDiagnostics+import AFRP++infixr 0 `fby`++++------------------------------------------------------------------------------+-- Liftings+------------------------------------------------------------------------------++arr2 :: Arrow a => (b -> c -> d) -> a (b, c) d+arr2 = arr . uncurry+++arr3 :: Arrow a => (b -> c -> d -> e) -> a (b, c, d) e+arr3 = arr . \h (b, c, d) -> h b c d+++arr4 :: Arrow a => (b -> c -> d -> e -> f) -> a (b, c, d, e) f+arr4 = arr . \h (b, c, d, e) -> h b c d e+++arr5 :: Arrow a => (b -> c -> d -> e -> f -> g) -> a (b, c, d, e, f) g+arr5 = arr . \h (b, c, d, e, f) -> h b c d e f+++lift0 :: Arrow a => c -> a b c+lift0 c = arr (const c)+++lift1 :: Arrow a => (c -> d) -> (a b c -> a b d)+lift1 f = \a -> a >>> arr f+++lift2 :: Arrow a => (c -> d -> e) -> (a b c -> a b d -> a b e)+lift2 f = \a1 a2 -> a1 &&& a2 >>> arr2 f+++lift3 :: Arrow a => (c -> d -> e -> f) -> (a b c -> a b d -> a b e -> a b f)+lift3 f = \a1 a2 a3 -> (lift2 f) a1 a2 &&& a3 >>> arr2 ($)+++lift4 :: Arrow a => (c->d->e->f->g) -> (a b c->a b d->a b e->a b f->a b g)+lift4 f = \a1 a2 a3 a4 -> (lift3 f) a1 a2 a3 &&& a4 >>> arr2 ($)+++lift5 :: Arrow a =>+ (c->d->e->f->g->h) -> (a b c->a b d->a b e->a b f->a b g->a b h)+lift5 f = \a1 a2 a3 a4 a5 ->(lift4 f) a1 a2 a3 a4 &&& a5 >>> arr2 ($)+++------------------------------------------------------------------------------+-- Event sources+------------------------------------------------------------------------------++-- Event source with a single occurrence at time 0. The value of the event+-- is obtained by sampling the input at that time.+snap :: SF a (Event a)+snap = switch (never &&& (identity &&& now () >>^ \(a, e) -> e `tag` a)) now+++-- Event source with a single occurrence at or as soon after (local) time t_ev+-- as possible. The value of the event is obtained by sampling the input a+-- that time.+snapAfter :: Time -> SF a (Event a)+snapAfter t_ev = switch (never+ &&& (identity+ &&& after t_ev () >>^ \(a, e) -> e `tag` a))+ now+++-- Sample a signal at regular intervals.+sample :: Time -> SF a (Event a)+sample p_ev = identity &&& repeatedly p_ev () >>^ \(a, e) -> e `tag` a+++-- Makes an event source recurring by restarting it as soon as it has an+-- occurrence.+recur :: SF a (Event b) -> SF a (Event b)+recur sfe = switch (never &&& sfe) recurAux+ where+ recurAux b = switch (now b &&& sfe) recurAux+++------------------------------------------------------------------------------+-- Parallel composition/switchers with "zip" routing+------------------------------------------------------------------------------++safeZip :: String -> [a] -> [b] -> [(a,b)]+safeZip fn as bs = safeZip' as bs+ where+ safeZip' as [] = []+ safeZip' as (b:bs) = (head' as, b) : safeZip' (tail' as) bs++ head' [] = err+ head' (a:_) = a++ tail' [] = err+ tail' (_:as) = as++ err = usrErr "AFRPUtilities" fn "Input list too short."+++parZ :: [SF a b] -> SF [a] [b]+parZ = par (safeZip "parZ")+++pSwitchZ :: [SF a b] -> SF ([a],[b]) (Event c) -> ([SF a b] -> c -> SF [a] [b])+ -> SF [a] [b]+pSwitchZ = pSwitch (safeZip "pSwitchZ")+++dpSwitchZ :: [SF a b] -> SF ([a],[b]) (Event c) -> ([SF a b] -> c ->SF [a] [b])+ -> SF [a] [b]+dpSwitchZ = dpSwitch (safeZip "dpSwitchZ")+++rpSwitchZ :: [SF a b] -> SF ([a], Event ([SF a b] -> [SF a b])) [b]+rpSwitchZ = rpSwitch (safeZip "rpSwitchZ")+++drpSwitchZ :: [SF a b] -> SF ([a], Event ([SF a b] -> [SF a b])) [b]+drpSwitchZ = drpSwitch (safeZip "drpSwitchZ")+++------------------------------------------------------------------------------+-- Guards and automata-oriented combinators+------------------------------------------------------------------------------++-- Runs sft only when the predicate p is satisfied, otherwise runs sff.+provided :: (a -> Bool) -> SF a b -> SF a b -> SF a b+provided p sft sff =+ switch (constant undefined &&& snap) $ \a0 ->+ if p a0 then stt else stf+ where+ stt = switch (sft &&& (not . p ^>> edge)) (const stf)+ stf = switch (sff &&& (p ^>> edge)) (const stt)+++------------------------------------------------------------------------------+-- Wave-form generation+------------------------------------------------------------------------------++-- Zero-order hold with delay.+-- Identity: dHold a0 = hold a0 >>> iPre a0).+dHold :: a -> SF (Event a) a+dHold a0 = dSwitch (constant a0 &&& identity) dHold'+ where+ dHold' a = dSwitch (constant a &&& notYet) dHold'+++dTrackAndHold :: a -> SF (Maybe a) a+dTrackAndHold a_init = trackAndHold a_init >>> iPre a_init+++------------------------------------------------------------------------------+-- Accumulators+------------------------------------------------------------------------------++accumHold :: a -> SF (Event (a -> a)) a+accumHold a_init = accum a_init >>> hold a_init+++dAccumHold :: a -> SF (Event (a -> a)) a+dAccumHold a_init = accum a_init >>> dHold a_init+++accumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b+accumHoldBy f b_init = accumBy f b_init >>> hold b_init+++dAccumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b+dAccumHoldBy f b_init = accumBy f b_init >>> dHold b_init+++count :: Integral b => SF (Event a) (Event b)+count = accumBy (\n _ -> n + 1) 0+++------------------------------------------------------------------------------+-- Delays+------------------------------------------------------------------------------++-- Lucid-Synchrone-like initialized delay (read "followed by").+fby :: b -> SF a b -> SF a b+b0 `fby` sf = b0 --> sf >>> pre+++------------------------------------------------------------------------------+-- Integrals+------------------------------------------------------------------------------++impulseIntegral :: VectorSpace a k => SF (a, Event a) a+impulseIntegral = (integral *** accumHoldBy (^+^) zeroVector) >>^ uncurry (^+^)
+ src/AFRPVector2.hs view
@@ -0,0 +1,100 @@+{- $Id: AFRPVector2.hs,v 1.5 2004/03/22 19:46:40 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPVector2 * +* Purpose: 2D vector abstraction (R^2). * +* Authors: Henrik Nilsson and Antony Courtney * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPVector2 ( + module AFRPVectorSpace, + Vector2, -- Abstract, instance of VectorSpace + vector2, -- :: RealFloat a => a -> a -> Vector2 a + vector2X, -- :: RealFloat a => Vector2 a -> a + vector2Y, -- :: RealFloat a => Vector2 a -> a + vector2XY, -- :: RealFloat a => Vector2 a -> (a, a) + vector2Polar, -- :: RealFloat a => a -> a -> Vector2 a + vector2Rho, -- :: RealFloat a => Vector2 a -> a + vector2Theta, -- :: RealFloat a => Vector2 a -> a + vector2RhoTheta, -- :: RealFloat a => Vector2 a -> (a, a) + vector2Rotate -- :: RealFloat a => a -> Vector2 a -> Vector2 a +) where + +import AFRPVectorSpace +import AFRPForceable + + +------------------------------------------------------------------------------ +-- 2D vector, constructors and selectors. +------------------------------------------------------------------------------ + +-- Restrict coefficient space to RealFloat (rather than Floating) for now. +-- While unclear if a complex coefficient space would be useful (and if the +-- result really would be a 2d vector), the only thing causing trouble is the +-- use of atan2 in vector2Theta. Maybe atan2 can be generalized? + +data RealFloat a => Vector2 a = Vector2 !a !a deriving (Eq,Show) + +vector2 :: RealFloat a => a -> a -> Vector2 a +vector2 x y = Vector2 x y + +vector2X :: RealFloat a => Vector2 a -> a +vector2X (Vector2 x _) = x + +vector2Y :: RealFloat a => Vector2 a -> a +vector2Y (Vector2 _ y) = y + +vector2XY :: RealFloat a => Vector2 a -> (a, a) +vector2XY (Vector2 x y) = (x, y) + +vector2Polar :: RealFloat a => a -> a -> Vector2 a +vector2Polar rho theta = Vector2 (rho * cos theta) (rho * sin theta) + +vector2Rho :: RealFloat a => Vector2 a -> a +vector2Rho (Vector2 x y) = sqrt (x * x + y * y) + +vector2Theta :: RealFloat a => Vector2 a -> a +vector2Theta (Vector2 x y) = atan2 y x + +vector2RhoTheta :: RealFloat a => Vector2 a -> (a, a) +vector2RhoTheta v = (vector2Rho v, vector2Theta v) + +------------------------------------------------------------------------------ +-- Vector space instance +------------------------------------------------------------------------------ + +instance RealFloat a => VectorSpace (Vector2 a) a where + zeroVector = Vector2 0 0 + + a *^ (Vector2 x y) = Vector2 (a * x) (a * y) + + (Vector2 x y) ^/ a = Vector2 (x / a) (y / a) + + negateVector (Vector2 x y) = (Vector2 (-x) (-y)) + + (Vector2 x1 y1) ^+^ (Vector2 x2 y2) = Vector2 (x1 + x2) (y1 + y2) + + (Vector2 x1 y1) ^-^ (Vector2 x2 y2) = Vector2 (x1 - x2) (y1 - y2) + + (Vector2 x1 y1) `dot` (Vector2 x2 y2) = x1 * x2 + y1 * y2 + + +------------------------------------------------------------------------------ +-- Additional operations +------------------------------------------------------------------------------ + +vector2Rotate :: RealFloat a => a -> Vector2 a -> Vector2 a +vector2Rotate theta' v = vector2Polar (vector2Rho v) (vector2Theta v + theta') + + +------------------------------------------------------------------------------ +-- Forceable instance +------------------------------------------------------------------------------ + +instance RealFloat a => Forceable (Vector2 a) where + force = id
+ src/AFRPVector3.hs view
@@ -0,0 +1,118 @@+{- $Id: AFRPVector3.hs,v 1.3 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPVector3 * +* Purpose: 3D vector abstraction (R^3). * +* Authors: Henrik Nilsson and Antony Courtney * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPVector3 ( + module AFRPVectorSpace, + Vector3, -- Abstract, instance of VectorSpace + vector3, -- :: RealFloat a => a -> a -> a -> Vector3 a + vector3X, -- :: RealFloat a => Vector3 a -> a + vector3Y, -- :: RealFloat a => Vector3 a -> a + vector3Z, -- :: RealFloat a => Vector3 a -> a + vector3XYZ, -- :: RealFloat a => Vector3 a -> (a, a, a) + vector3Spherical, -- :: RealFloat a => a -> a -> a -> Vector3 a + vector3Rho, -- :: RealFloat a => Vector3 a -> a + vector3Theta, -- :: RealFloat a => Vector3 a -> a + vector3Phi, -- :: RealFloat a => Vector3 a -> a + vector3RhoThetaPhi, -- :: RealFloat a => Vector3 a -> (a, a, a) + vector3Rotate -- :: RealFloat a => a -> a -> Vector3 a -> Vector3 a +) where + +import AFRPVectorSpace +import AFRPForceable + +------------------------------------------------------------------------------ +-- 3D vector, constructors and selectors. +------------------------------------------------------------------------------ + +-- Restrict coefficient space to RealFloat (rather than Floating) for now. +-- While unclear if a complex coefficient space would be useful (and if the +-- result really would be a 3d vector), the only thing causing trouble is the +-- use of atan2 in vector3Theta and vector3Phi. Maybe atan2 can be generalized? + +data RealFloat a => Vector3 a = Vector3 !a !a !a deriving Eq + +vector3 :: RealFloat a => a -> a -> a -> Vector3 a +vector3 x y z = Vector3 x y z + +vector3X :: RealFloat a => Vector3 a -> a +vector3X (Vector3 x _ _) = x + +vector3Y :: RealFloat a => Vector3 a -> a +vector3Y (Vector3 _ y _) = y + +vector3Z :: RealFloat a => Vector3 a -> a +vector3Z (Vector3 _ _ z) = z + +vector3XYZ :: RealFloat a => Vector3 a -> (a, a, a) +vector3XYZ (Vector3 x y z) = (x, y, z) + +vector3Spherical :: RealFloat a => a -> a -> a -> Vector3 a +vector3Spherical rho theta phi = + Vector3 (rhoSinPhi * cos theta) (rhoSinPhi * sin theta) (rho * cos phi) + where + rhoSinPhi = rho * sin phi + +vector3Rho :: RealFloat a => Vector3 a -> a +vector3Rho (Vector3 x y z) = sqrt (x * x + y * y + z * z) + +vector3Theta :: RealFloat a => Vector3 a -> a +vector3Theta (Vector3 x y _) = atan2 y x + +vector3Phi :: RealFloat a => Vector3 a -> a +vector3Phi v@(Vector3 x y z) = acos (z / vector3Rho v) + +vector3RhoThetaPhi :: RealFloat a => Vector3 a -> (a, a, a) +vector3RhoThetaPhi (Vector3 x y z) = (rho, theta, phi) + where + rho = sqrt (x * x + y * y + z * z) + theta = atan2 y x + phi = acos (z / rho) + + +------------------------------------------------------------------------------ +-- Vector space instance +------------------------------------------------------------------------------ + +instance RealFloat a => VectorSpace (Vector3 a) a where + zeroVector = Vector3 0 0 0 + + a *^ (Vector3 x y z) = Vector3 (a * x) (a * y) (a * z) + + (Vector3 x y z) ^/ a = Vector3 (x / a) (y / a) (z / a) + + negateVector (Vector3 x y z) = (Vector3 (-x) (-y) (-z)) + + (Vector3 x1 y1 z1) ^+^ (Vector3 x2 y2 z2) = Vector3 (x1+x2) (y1+y2) (z1+z2) + + (Vector3 x1 y1 z1) ^-^ (Vector3 x2 y2 z2) = Vector3 (x1-x2) (y1-y2) (z1-z2) + + (Vector3 x1 y1 z1) `dot` (Vector3 x2 y2 z2) = x1 * x2 + y1 * y2 + z1 * z2 + + +------------------------------------------------------------------------------ +-- Additional operations +------------------------------------------------------------------------------ + +vector3Rotate :: RealFloat a => a -> a -> Vector3 a -> Vector3 a +vector3Rotate theta' phi' v = + vector3Spherical (vector3Rho v) + (vector3Theta v + theta') + (vector3Phi v + phi') + + +------------------------------------------------------------------------------ +-- Forceable instance +------------------------------------------------------------------------------ + +instance RealFloat a => Forceable (Vector3 a) where + force = id
+ src/AFRPVectorSpace.hs view
@@ -0,0 +1,158 @@+{- $Id: AFRPVectorSpace.hs,v 1.2 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPVectorSpace * +* Purpose: Vector space type relation and basic instances. * +* Authors: Henrik Nilsson and Antony Courtney * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPVectorSpace where + +------------------------------------------------------------------------------ +-- Vector space type relation +------------------------------------------------------------------------------ + +infixr *^ +infixl ^/ +infix 7 `dot` +infixl 6 ^+^, ^-^ + +-- Maybe norm and normalize should not be class methods, in which case +-- the constraint on the coefficient space (a) should (or, at least, could) +-- be Fractional (roughly a Field) rather than Floating. + +-- Minimal instance: zeroVector, (*^), (^+^), dot +class Floating a => VectorSpace v a | v -> a where + zeroVector :: v + (*^) :: a -> v -> v + (^/) :: v -> a -> v + negateVector :: v -> v + (^+^) :: v -> v -> v + (^-^) :: v -> v -> v + dot :: v -> v -> a + norm :: v -> a + normalize :: v -> v + + v ^/ a = (1/a) *^ v + + negateVector v = (-1) *^ v + + v1 ^-^ v2 = v1 ^+^ v1 -- (negateVector v2) + + norm v = sqrt (v `dot` v) + + normalize v = if nv /= 0 then v ^/ nv else error "normalize: zero vector" + where + nv = norm v + +------------------------------------------------------------------------------ +-- Vector space instances for Float and Double +------------------------------------------------------------------------------ + +instance VectorSpace Float Float where + zeroVector = 0 + + a *^ x = a * x + + x ^/ a = x / a + + negateVector x = (-x) + + x1 ^+^ x2 = x1 + x2 + + x1 ^-^ x2 = x1 - x2 + + x1 `dot` x2 = x1 * x2 + + +instance VectorSpace Double Double where + zeroVector = 0 + + a *^ x = a * x + + x ^/ a = x / a + + negateVector x = (-x) + + x1 ^+^ x2 = x1 + x2 + + x1 ^-^ x2 = x1 - x2 + + x1 `dot` x2 = x1 * x2 + + +------------------------------------------------------------------------------ +-- Vector space instances for small tuples of Floating +------------------------------------------------------------------------------ + +instance Floating a => VectorSpace (a,a) a where + zeroVector = (0,0) + + a *^ (x,y) = (a * x, a * y) + + (x,y) ^/ a = (x / a, y / a) + + negateVector (x,y) = (-x, -y) + + (x1,y1) ^+^ (x2,y2) = (x1 + x2, y1 + y2) + + (x1,y1) ^-^ (x2,y2) = (x1 - x2, y1 - y2) + + (x1,y1) `dot` (x2,y2) = x1 * x2 + y1 * y2 + + +instance Floating a => VectorSpace (a,a,a) a where + zeroVector = (0,0,0) + + a *^ (x,y,z) = (a * x, a * y, a * z) + + (x,y,z) ^/ a = (x / a, y / a, z / a) + + negateVector (x,y,z) = (-x, -y, -z) + + (x1,y1,z1) ^+^ (x2,y2,z2) = (x1+x2, y1+y2, z1+z2) + + (x1,y1,z1) ^-^ (x2,y2,z2) = (x1-x2, y1-y2, z1-z2) + + (x1,y1,z1) `dot` (x2,y2,z2) = x1 * x2 + y1 * y2 + z1 * z2 + + +instance Floating a => VectorSpace (a,a,a,a) a where + zeroVector = (0,0,0,0) + + a *^ (x,y,z,u) = (a * x, a * y, a * z, a * u) + + (x,y,z,u) ^/ a = (x / a, y / a, z / a, u / a) + + negateVector (x,y,z,u) = (-x, -y, -z, -u) + + (x1,y1,z1,u1) ^+^ (x2,y2,z2,u2) = (x1+x2, y1+y2, z1+z2, u1+u2) + + (x1,y1,z1,u1) ^-^ (x2,y2,z2,u2) = (x1-x2, y1-y2, z1-z2, u1-u2) + + (x1,y1,z1,u1) `dot` (x2,y2,z2,u2) = x1 * x2 + y1 * y2 + z1 * z2 + u1 * u2 + + +instance Floating a => VectorSpace (a,a,a,a,a) a where + zeroVector = (0,0,0,0,0) + + a *^ (x,y,z,u,v) = (a * x, a * y, a * z, a * u, a * v) + + (x,y,z,u,v) ^/ a = (x / a, y / a, z / a, u / a, v / a) + + negateVector (x,y,z,u,v) = (-x, -y, -z, -u, -v) + + (x1,y1,z1,u1,v1) ^+^ (x2,y2,z2,u2,v2) = (x1+x2, y1+y2, z1+z2, u1+u2, v1+v2) + + (x1,y1,z1,u1,v1) ^-^ (x2,y2,z2,u2,v2) = (x1-x2, y1-y2, z1-z2, u1-u2, v1-v2) + + (x1,y1,z1,u1,v1) `dot` (x2,y2,z2,u2,v2) = + x1 * x2 + y1 * y2 + z1 * z2 + u1 * u2 + v1 * v2 + + +
+ tests/AFRPTests.hs view
@@ -0,0 +1,176 @@+{- $Id: AFRPTests.hs,v 1.27 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTests * +* Purpose: AFRP regression tests. * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +-- TODO: +-- * Add test cases for AFRP. There should be at least one test case for each +-- "non-trivial" entity exported from AFRP. +-- +-- * Make tests cases for after and repeatedly more robust. Must not +-- fail due to small discrepancies in floating point implementation. +-- +-- 01-May-2002: evsrc_t7 currently fails in hugs. +-- +-- * Restructure test cases for papallel composition and switches to reflect +-- AFRP structure better. Separate test cases for the generic definitions? +-- There are some test cases for AFRPUtils. Not intended to be exhaustive. +-- +-- VectorSpace has caused some ambiguity problems. See e.g. looplaws_t2, +-- switch_t1a. + +module AFRPTests where + +import AFRP +import AFRPTask (forAll) + +import AFRPTestsCommon +import AFRPTestsArr +import AFRPTestsComp +import AFRPTestsFirstSecond +import AFRPTestsLaws +import AFRPTestsLoop +import AFRPTestsLoopLaws +import AFRPTestsBasicSF +import AFRPTestsEvSrc +import AFRPTestsCOC +import AFRPTestsSwitch +import AFRPTestsKSwitch +import AFRPTestsRSwitch +import AFRPTestsPSwitch +import AFRPTestsRPSwitch +import AFRPTestsWFG +import AFRPTestsAccum +import AFRPTestsDelay +import AFRPTestsDer +import AFRPTestsLoopPre +import AFRPTestsLoopIntegral +import AFRPTestsReact +import AFRPTestsEmbed +import AFRPTestsUtils +import AFRPTestsTask + + +------------------------------------------------------------------------------ +-- Global test and error reporting +------------------------------------------------------------------------------ + +allGood = arr_tr + && comp_tr + && first_tr + && second_tr + && laws_tr + && loop_tr + && looplaws_tr + && basicsf_tr + && evsrc_tr + && coc_tr + && switch_tr + && kswitch_tr + && rswitch_tr + && pswitch_tr + && rpswitch_tr + && wfg_tr + && accum_tr + && delay_tr + && der_tr + && loopPre_tr + && loopIntegral_tr + && react_tr + && embed_tr + && utils_tr + && task_tr + + +all_trs = + [ ("arr", arr_trs), + ("comp", comp_trs), + ("first", first_trs), + ("second", second_trs), + ("laws", laws_trs), + ("loop", loop_trs), + ("looplaws", looplaws_trs), + ("basicsf", basicsf_trs), + ("evsrc", evsrc_trs), + ("coc", coc_trs), + ("switch", switch_trs), + ("kswitch", kswitch_trs), + ("rswitch", rswitch_trs), + ("pswitch", pswitch_trs), + ("rpswitch", rpswitch_trs), + ("wfg", wfg_trs), + ("accum", accum_trs), + ("delay", delay_trs), + ("der", der_trs), + ("loopPre", loopPre_trs), + ("loopIntegral", loopIntegral_trs), + ("react", react_trs), + ("embed", embed_trs), + ("utils", utils_trs), + ("task", task_trs) + ] + + +failedTests = + [ format n i | (n, trs) <- all_trs, (i, tr) <- zip [0..] trs, not tr ] + where + format n i = "Test " ++ n ++ "_t" ++ show i ++ " failed." + + +runRegTests :: IO () +runRegTests = do + putStrLn "" + putStrLn "Running the AFRP regression tests ..." + if allGood then + putStrLn "All tests succeeded!" + else + forAll failedTests putStrLn + + +runSpaceTests :: IO () +runSpaceTests = do + putStrLn "" + putStrLn "Running the AFRP space tests ..." + putStrLn "Testing the space behaviour. This may take a LONG time." + putStrLn "Observe the process size using some tool like top." + putStrLn "The process should not grow significantly." + putStrLn "Emitted success/failure indications signify termination" + putStrLn "and whether or not the right result was obtained. They do" + putStrLn "not necessarily indicate that the space behaviour is correct" + putStrLn "(i.e., absence of leaks)." + putStrLn "" + rst "arr" 0 arr_st0 arr_st0r + rst "arr" 1 arr_st1 arr_st1r + rst "loop" 0 loop_st0 loop_st0r + rst "loop" 1 loop_st1 loop_st1r + rst "rswitch" 0 rswitch_st0 rswitch_st0r + rst "pswitch" 0 pswitch_st0 pswitch_st0r + rst "pswitch" 1 pswitch_st1 pswitch_st1r + rst "rpswitch" 0 rpswitch_st0 rpswitch_st0r + rst "accum" 0 accum_st0 accum_st0r + rst "accum" 1 accum_st1 accum_st1r + where + rst n i st str = do + putStrLn ("Running " ++ n ++ "_st" ++ show i ++ " ...") + if st ~= str then + putStrLn "Success!" + else + -- We probably won't get here in case of a (space) failure ... + putStrLn "Failure!" + +-- AC: here because I had trouble running ghci: +-- fixTest :: IO () +-- fixTest = +-- let vs = loop_t17 +-- in putStrLn ("loop_t17 output: " ++ show vs) + + +
+ tests/AFRPTestsAccum.hs view
@@ -0,0 +1,205 @@+{- $Id: AFRPTestsAccum.hs,v 1.2 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTestsAccum * +* Purpose: Test cases for accumulators * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPTestsAccum ( + accum_tr, + accum_trs, + accum_st0, + accum_st0r, + accum_st1, + accum_st1r +) where + +import Maybe (fromJust) + +import AFRP +import AFRPInternals (Event(NoEvent, Event)) + +import AFRPTestsCommon + +------------------------------------------------------------------------------ +-- Test cases for accumulators +------------------------------------------------------------------------------ + +accum_inp1 = (fromJust (head delta_inp), zip (repeat 1.0) (tail delta_inp)) + where + delta_inp = + [Just NoEvent, Nothing, Just (Event (+1.0)), Just NoEvent, + Just (Event (+2.0)), Just NoEvent, Nothing, Nothing, + Just (Event (*3.0)), Just (Event (+5.0)), Nothing, Just NoEvent, + Just (Event (/2.0)), Just NoEvent, Nothing, Nothing] + ++ repeat Nothing + +accum_inp2 = (fromJust (head delta_inp), zip (repeat 1.0) (tail delta_inp)) + where + delta_inp = + [Just (Event (+1.0)), Just NoEvent, Nothing, Nothing, + Just (Event (+2.0)), Just NoEvent, Nothing, Nothing, + Just (Event (*3.0)), Just (Event (+5.0)), Nothing, Just NoEvent, + Just (Event (/2.0)), Just NoEvent, Nothing, Nothing] + ++ repeat Nothing + +accum_inp3 = deltaEncode 1.0 $ + [NoEvent, NoEvent, Event 1.0, NoEvent, + Event 2.0, NoEvent, NoEvent, NoEvent, + Event 3.0, Event 5.0, Event 5.0, NoEvent, + Event 0.0, NoEvent, NoEvent, NoEvent] + ++ repeat NoEvent + +accum_inp4 = deltaEncode 1.0 $ + [Event 1.0, NoEvent, NoEvent, NoEvent, + Event 2.0, NoEvent, NoEvent, NoEvent, + Event 3.0, Event 5.0, Event 5.0, NoEvent, + Event 0.0, NoEvent, NoEvent, NoEvent] + ++ repeat NoEvent + + +accum_t0 :: [Event Double] +accum_t0 = take 16 $ embed (accum 0.0) accum_inp1 + +accum_t0r = + [NoEvent, NoEvent, Event 1.0, NoEvent, + Event 3.0, NoEvent, NoEvent, NoEvent, + Event 9.0, Event 14.0, Event 19.0, NoEvent, + Event 9.5, NoEvent, NoEvent, NoEvent] + + +accum_t1 :: [Event Double] +accum_t1 = take 16 $ embed (accum 0.0) accum_inp2 + +accum_t1r = + [Event 1.0, NoEvent, NoEvent, NoEvent, + Event 3.0, NoEvent, NoEvent, NoEvent, + Event 9.0, Event 14.0, Event 19.0, NoEvent, + Event 9.5, NoEvent, NoEvent, NoEvent] + + +accum_t2 :: [Event Int] +accum_t2 = take 16 $ embed (accumBy (\a d -> a + floor d) 0) accum_inp3 + +accum_t2r :: [Event Int] +accum_t2r = + [NoEvent, NoEvent, Event 1, NoEvent, + Event 3, NoEvent, NoEvent, NoEvent, + Event 6, Event 11, Event 16, NoEvent, + Event 16, NoEvent, NoEvent, NoEvent] + + +accum_t3 :: [Event Int] +accum_t3 = take 16 $ embed (accumBy (\a d -> a + floor d) 0) accum_inp4 + +accum_t3r :: [Event Int] +accum_t3r = + [Event 1, NoEvent, NoEvent, NoEvent, + Event 3, NoEvent, NoEvent, NoEvent, + Event 6, Event 11, Event 16, NoEvent, + Event 16, NoEvent, NoEvent, NoEvent] + + +accum_accFiltFun1 a d = + let a' = a + floor d + in + if even a' then + (a', Just (a' > 10, a')) + else + (a', Nothing) + +accum_t4 :: [Event (Bool,Int)] +accum_t4 = take 16 $ embed (accumFilter accum_accFiltFun1 0) accum_inp3 + +accum_t4r :: [Event (Bool,Int)] +accum_t4r = + [NoEvent, NoEvent, NoEvent, NoEvent, + NoEvent, NoEvent, NoEvent, NoEvent, + Event (False,6), NoEvent, Event (True,16), NoEvent, + Event (True,16), NoEvent, NoEvent, NoEvent] + + +accum_accFiltFun2 a d = + let a' = a + floor d + in + if odd a' then + (a', Just (a' > 10, a')) + else + (a', Nothing) + +accum_t5 :: [Event (Bool,Int)] +accum_t5 = take 16 $ embed (accumFilter accum_accFiltFun2 0) accum_inp4 + +accum_t5r :: [Event (Bool,Int)] +accum_t5r = + [Event (False,1), NoEvent, NoEvent, NoEvent, + Event (False,3), NoEvent, NoEvent, NoEvent, + NoEvent, Event (True,11), NoEvent, NoEvent, + NoEvent, NoEvent, NoEvent, NoEvent] + + +-- This can be seen as the definition of accumFilter +accumFilter2 :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b) +accumFilter2 f c_init = + switch (never &&& attach c_init) afAux + where + afAux (c, a) = + case f c a of + (c', Nothing) -> switch (never &&& (notYet>>>attach c')) afAux + (c', Just b) -> switch (now b &&& (notYet>>>attach c')) afAux + + attach :: b -> SF (Event a) (Event (b, a)) + attach c = arr (fmap (\a -> (c, a))) + +accum_t6 :: [Event (Bool,Int)] +accum_t6 = take 16 $ embed (accumFilter2 accum_accFiltFun1 0) accum_inp3 + +accum_t6r = accum_t4 -- Should agree! + +accum_t7 :: [Event (Bool,Int)] +accum_t7 = take 16 $ embed (accumFilter2 accum_accFiltFun2 0) accum_inp4 + +accum_t7r = accum_t5 -- Should agree! + + +accum_trs = + [ accum_t0 == accum_t0r, + accum_t1 == accum_t1r, + accum_t2 == accum_t2r, + accum_t3 == accum_t3r, + accum_t4 == accum_t4r, + accum_t5 == accum_t5r, + accum_t6 == accum_t6r, + accum_t7 == accum_t7r + ] + +accum_tr = and accum_trs + + +accum_st0 :: Double +accum_st0 = testSFSpaceLeak 1000000 + (repeatedly 1.0 1.0 + >>> accumBy (+) 0.0 + >>> hold (-99.99)) + +accum_st0r = 249999.0 + + +accum_st1 :: Double +accum_st1 = testSFSpaceLeak 1000000 + (arr dup + >>> first (repeatedly 1.0 1.0) + >>> arr (\(e,a) -> tag e a) + >>> accumFilter accumFun 0.0 + >>> hold (-99.99)) + where + accumFun c a | even (floor a) = (c+a, Just (c+a)) + | otherwise = (c, Nothing) + +accum_st1r = 6.249975e10
+ tests/AFRPTestsArr.hs view
@@ -0,0 +1,52 @@+{- $Id: AFRPTestsArr.hs,v 1.2 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTestsArr * +* Purpose: Test cases for arr * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPTestsArr ( + arr_trs, + arr_tr, + arr_st0, + arr_st0r, + arr_st1, + arr_st1r +) where + +import AFRP + +import AFRPTestsCommon + +------------------------------------------------------------------------------ +-- Test cases for arr +------------------------------------------------------------------------------ + +arr_t0 = testSF1 (arr (+1)) +arr_t0r = + [1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0,16.0, + 17.0,18.0,19.0,20.0,21.0,22.0,23.0,24.0,25.0] + +arr_t1 = testSF2 (arr (+1)) +arr_t1r = + [1.0,1.0,1.0,1.0,1.0,2.0,2.0,2.0,2.0,2.0,3.0,3.0,3.0,3.0,3.0,4.0,4.0,4.0, + 4.0,4.0,5.0,5.0,5.0,5.0,5.0] + +arr_trs = + [ arr_t0 ~= arr_t0r, + arr_t1 ~= arr_t1r + ] + +arr_tr = and arr_trs + +arr_st0 = testSFSpaceLeak 2000000 (arr (+1)) +arr_st0r = 1000000.5 + +arr_st1 = testSFSpaceLeak 2000000 identity +arr_st1r = 999999.5
+ tests/AFRPTestsBasicSF.hs view
@@ -0,0 +1,69 @@+{- $Id: AFRPTestsBasicSF.hs,v 1.2 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTestsBasicSF * +* Purpose: Test cases for basic signal functions * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPTestsBasicSF (basicsf_trs, basicsf_tr) where + +import AFRP + +import AFRPTestsCommon + +------------------------------------------------------------------------------ +-- Test cases for basic signal functions and initialization +------------------------------------------------------------------------------ + +basicsf_t0 :: [Double] +basicsf_t0 = testSF1 identity +basicsf_t0r = + [0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 8.0, 9.0, + 10.0, 11.0, 12.0, 13.0, 14.0, 15.0, 16.0, 17.0, 18.0, 19.0, + 20.0, 21.0, 22.0, 23.0, 24.0] + + +basicsf_t1 :: [Double] +basicsf_t1 = testSF1 (constant 42.0) +basicsf_t1r = + [42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, + 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, + 42.0, 42.0, 42.0, 42.0, 42.0] + +basicsf_t2 :: [Double] +basicsf_t2 = testSF1 localTime +basicsf_t2r = + [0.0, 0.25, 0.5, 0.75, 1.0, 1.25, 1.5, 1.75, 2.0, 2.25, + 2.5, 2.75, 3.0, 3.25, 3.5, 3.75, 4.0, 4.25, 4.5, 4.75, + 5.0, 5.25, 5.5, 5.75, 6.0] + +basicsf_t3 :: [Double] +basicsf_t3 = testSF1 time +basicsf_t3r = + [0.0, 0.25, 0.5, 0.75, 1.0, 1.25, 1.5, 1.75, 2.0, 2.25, + 2.5, 2.75, 3.0, 3.25, 3.5, 3.75, 4.0, 4.25, 4.5, 4.75, + 5.0, 5.25, 5.5, 5.75, 6.0] + +basicsf_t4 :: [Double] +basicsf_t4 = testSF1 (initially 42.0) +basicsf_t4r = + [42.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 8.0, 9.0, + 10.0, 11.0, 12.0, 13.0, 14.0, 15.0, 16.0, 17.0, 18.0, 19.0, + 20.0, 21.0, 22.0, 23.0, 24.0] + + +basicsf_trs = + [ basicsf_t0 ~= basicsf_t0r, + basicsf_t1 ~= basicsf_t1r, + basicsf_t2 ~= basicsf_t2r, + basicsf_t3 ~= basicsf_t3r, + basicsf_t4 ~= basicsf_t4r + ] + +basicsf_tr = and basicsf_trs
+ tests/AFRPTestsCOC.hs view
@@ -0,0 +1,56 @@+{- $Id: AFRPTestsCOC.hs,v 1.2 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTestsCOC * +* Purpose: Test cases for collection-oriented combinators * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPTestsCOC (coc_tr, coc_trs) where + +import AFRP + +import AFRPTestsCommon + +------------------------------------------------------------------------------ +-- Test cases for collection-oriented combinators +------------------------------------------------------------------------------ + +coc_inp1 = deltaEncode 0.1 [0.0, 0.5 ..] + +coc_t0 :: [[Double]] +coc_t0 = take 20 $ embed (parB [constant 1.0, identity, integral]) coc_inp1 + +coc_t0r = + [[1.0, 0.0, 0.00], + [1.0, 0.5, 0.00], + [1.0, 1.0, 0.05], + [1.0, 1.5, 0.15], + [1.0, 2.0, 0.30], + [1.0, 2.5, 0.50], + [1.0, 3.0, 0.75], + [1.0, 3.5, 1.05], + [1.0, 4.0, 1.40], + [1.0, 4.5, 1.80], + [1.0, 5.0, 2.25], + [1.0, 5.5, 2.75], + [1.0, 6.0, 3.30], + [1.0, 6.5, 3.90], + [1.0, 7.0, 4.55], + [1.0, 7.5, 5.25], + [1.0, 8.0, 6.00], + [1.0, 8.5, 6.80], + [1.0, 9.0, 7.65], + [1.0, 9.5, 8.55]] + + +coc_trs = + [ coc_t0 ~= coc_t0r + ] + +coc_tr = and coc_trs
+ tests/AFRPTestsCommon.hs view
@@ -0,0 +1,165 @@+{- $Id: AFRPTestsCommon.hs,v 1.2 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTestsCommon * +* Purpose: Common definitions for the regression test modules. * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPTestsCommon where + +import Data.IORef (IORef, newIORef, writeIORef, readIORef) +import System.IO.Unsafe (unsafePerformIO) + +import AFRP +import AFRPInternals (Event(NoEvent, Event)) + +------------------------------------------------------------------------------ +-- Rough equality with instances +------------------------------------------------------------------------------ + +-- Rough equality. Only intended to be good enough for test cases in this +-- module. + +class REq a where + (~=) :: a -> a -> Bool + +epsilon :: Fractional a => a +epsilon = 0.0001 + +instance REq Float where + x ~= y = abs (x - y) < epsilon -- A relative measure should be used. + +instance REq Double where + x ~= y = abs (x - y) < epsilon -- A relative measure should be used. + +instance REq Int where + (~=) = (==) + +instance REq Integer where + (~=) = (==) + +instance REq Bool where + (~=) = (==) + +instance REq Char where + (~=) = (==) + +instance REq () where + () ~= () = True + +instance (REq a, REq b) => REq (a,b) where + (x1,x2) ~= (y1,y2) = x1 ~= y1 && x2 ~= y2 + +instance (REq a, REq b, REq c) => REq (a,b,c) where + (x1,x2,x3) ~= (y1,y2,y3) = x1 ~= y1 && x2 ~= y2 && x3 ~= y3 + +instance (REq a, REq b, REq c, REq d) => REq (a,b,c,d) where + (x1,x2,x3,x4) ~= (y1,y2,y3,y4) = x1 ~= y1 + && x2 ~= y2 + && x3 ~= y3 + && x4 ~= y4 + +instance (REq a, REq b, REq c, REq d, REq e) => REq (a,b,c,d,e) where + (x1,x2,x3,x4,x5) ~= (y1,y2,y3,y4,y5) = x1 ~= y1 + && x2 ~= y2 + && x3 ~= y3 + && x4 ~= y4 + +instance REq a => REq (Maybe a) where + Nothing ~= Nothing = True + (Just x) ~= (Just y) = x ~= y + _ ~= _ = False + +instance REq a => REq (Event a) where + NoEvent ~= NoEvent = True + (Event x) ~= (Event y) = x ~= y + _ ~= _ = False + +instance (REq a, REq b) => REq (Either a b) where + (Left x) ~= (Left y) = x ~= y + (Right x) ~= (Right y) = x ~= y + _ ~= _ = False + +instance REq a => REq [a] where + [] ~= [] = True + (x:xs) ~= (y:ys) = x ~= y && xs ~= ys + _ ~= _ = False + + +------------------------------------------------------------------------------ +-- Testing utilities +------------------------------------------------------------------------------ + +testSF1 :: SF Double a -> [a] +testSF1 sf = take 25 (embed sf (deltaEncodeBy (~=) 0.25 [0.0..])) + + +testSF2 :: SF Double a -> [a] +testSF2 sf = take 25 (embed sf (deltaEncodeBy (~=) 0.25 input)) + where + -- The initial 0.0 is just for result compatibility with an older + -- version. + input = 0.0 : [ fromIntegral (b `div` freq) | b <- [1..] ] + freq = 5 + + +------------------------------------------------------------------------------ +-- Test harness for space behaviour +------------------------------------------------------------------------------ + +{- +-- Test for space leaks. +-- Carefully defined in an attempt to defeat fully lazy lambda lifting. +-- Seems to work, but may be unsafe if the compiler decides to optimize +-- aggressively. +testSFSpaceLeak :: Int -> SF Double a -> a +testSFSpaceLeak n sf = embed sf (deltaEncodeBy (~=) 0.25 [(seq n 0.0)..]) !! n +-} + + +-- Using embed/deltaEncode seems to be a bad idea since fully lazy +-- lambda lifting often results in lifting a big input list to the top +-- level in the form of a CAF. Using reactimate and avoiding constructing +-- input/output lists should be more robust. + +testSFSpaceLeak :: Int -> SF Double a -> a +testSFSpaceLeak n sf = unsafePerformIO $ do + countr <- newIORef 0 + inputr <- newIORef undefined + outputr <- newIORef undefined + let init = do + let input0 = 0.0 + writeIORef inputr input0 + count <- readIORef countr + writeIORef countr (count + 1) + return input0 + sense _ = do + input <- readIORef inputr + let input' = input + 0.5 + writeIORef inputr input' + count <- readIORef countr + writeIORef countr (count + 1) + return (0.25, Just input') + actuate _ output = do + writeIORef outputr output + input <- readIORef inputr + count <- readIORef countr + return (count >= n) + reactimate init sense actuate sf + output <- readIORef outputr + return output + + +------------------------------------------------------------------------------ +-- Some utilities used for testing laws +------------------------------------------------------------------------------ + +fun_prod f g = \(x,y) -> (f x, g y) +assoc ((a,b),c) = (a,(b,c)) +assoc_inv (a,(b,c)) = ((a,b),c)
+ tests/AFRPTestsComp.hs view
@@ -0,0 +1,71 @@+{- $Id: AFRPTestsComp.hs,v 1.2 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTestsComp * +* Purpose: Test cases for (>>>) * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPTestsComp (comp_tr, comp_trs) where + +import AFRP + +import AFRPTestsCommon + +------------------------------------------------------------------------------ +-- Test cases for comp +------------------------------------------------------------------------------ + +comp_t0 = testSF1 ((arr (+1)) >>> (arr (+2))) +comp_t0r :: [Double] +comp_t0r = + [3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0,16.0,17.0, + 18.0,19.0,20.0,21.0,22.0,23.0,24.0,25.0,26.0,27.0] + +comp_t1 = testSF2 ((arr (+1)) >>> (arr (+2))) +comp_t1r :: [Double] +comp_t1r = + [3.0,3.0,3.0,3.0,3.0,4.0,4.0,4.0,4.0,4.0,5.0,5.0,5.0,5.0,5.0, + 6.0,6.0,6.0,6.0,6.0,7.0,7.0,7.0,7.0,7.0] + +comp_t2 = testSF1 ((constant 5.0) >>> (arr (+1))) +comp_t2r :: [Double] +comp_t2r = + [6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0, + 6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0] + +comp_t3 = testSF2 ((constant 5.0) >>> (arr (+1))) +comp_t3r :: [Double] +comp_t3r = + [6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0, + 6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0,6.0] + +-- Integration by the rectangle rule or trapezoid rule makes no difference. +comp_t4 = testSF1 ((constant 2.0) >>> integral) +comp_t4r :: [Double] +comp_t4r = + [0.0,0.5,1.0,1.5,2.0,2.5,3.0,3.5,4.0,4.5,5.0,5.5,6.0,6.5,7.0,7.5,8.0,8.5, + 9.0,9.5,10.0,10.5,11.0,11.5,12.0] + +-- Same result as above. +comp_t5 = testSF2 ((constant 2.0) >>> integral) +comp_t5r :: [Double] +comp_t5r = + [0.0,0.5,1.0,1.5,2.0,2.5,3.0,3.5,4.0,4.5,5.0,5.5,6.0,6.5,7.0,7.5,8.0,8.5, + 9.0,9.5,10.0,10.5,11.0,11.5,12.0] + +comp_trs = + [ comp_t0 ~= comp_t0r, + comp_t1 ~= comp_t1r, + comp_t2 ~= comp_t2r, + comp_t3 ~= comp_t3r, + comp_t4 ~= comp_t4r, + comp_t5 ~= comp_t5r + ] + +comp_tr = and comp_trs
+ tests/AFRPTestsDelay.hs view
@@ -0,0 +1,39 @@+{- $Id: AFRPTestsDelay.hs,v 1.2 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTestsDelay * +* Purpose: Test cases for delays * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPTestsDelay (delay_tr, delay_trs) where + +import AFRP + +import AFRPTestsCommon + +------------------------------------------------------------------------------ +-- Test cases for delays +------------------------------------------------------------------------------ + +delay_t0 = testSF1 (iPre 17) +delay_t0r = + [17.0,0.0,1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0, + 15.0,16.0,17.0,18.0,19.0,20.0,21.0,22.0,23.0] + +delay_t1 = testSF2 (iPre 17) +delay_t1r = + [17.0,0.0,0.0,0.0,0.0,0.0,1.0,1.0,1.0,1.0,1.0,2.0,2.0,2.0,2.0,2.0, + 3.0,3.0,3.0,3.0,3.0,4.0,4.0,4.0,4.0] + +delay_trs = + [ delay_t0 ~= delay_t0r, + delay_t1 ~= delay_t1r + ] + +delay_tr = and delay_trs
+ tests/AFRPTestsDer.hs view
@@ -0,0 +1,55 @@+{- $Id: AFRPTestsDer.hs,v 1.2 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTestsDer * +* Purpose: Test cases for derivative * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPTestsDer (der_tr, der_trs) where + +import AFRP + +import AFRPTestsCommon + +------------------------------------------------------------------------------ +-- Test cases for derivative +------------------------------------------------------------------------------ + +der_step = 0.001 +der_N = 1000 + +der_t0 :: [Double] +der_t0 = take der_N $ -- First value is always 0 + embed derivative + (deltaEncode der_step + [sin(2 * pi * t) | t <- [0.0, der_step ..]]) +{- +-- For stepsize 0.1 +der_t0r :: [Double] +der_t0r = + [ 0.0000, 5.8779, 3.6327, 0.0000, -3.6327, + -5.8779, -5.8779, -3.6327, 0.0000, 3.6327, + 5.8779, 5.8779, 3.6327, 0.0000, -3.6327, + -5.8779, -5.8779, -3.6327, 0.0000, 3.6327] +-} + +der_t0r :: [Double] +der_t0r = take der_N $ + [2 * pi * cos (2 * pi * t) | t <- [0.0, der_step ..]] + +-- We're happy if we are in the right ball park. +der_t0_max_diff = (maximum (zipWith (\x y -> abs (x - y)) + (tail der_t0) + (tail der_t0r))) + +der_trs = + [ der_t0_max_diff < 0.05 + ] + +der_tr = and der_trs
+ tests/AFRPTestsEmbed.hs view
@@ -0,0 +1,61 @@+{- $Id: AFRPTestsEmbed.hs,v 1.2 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTestsEmbed * +* Purpose: Test cases for embedding * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPTestsEmbed (embed_tr, embed_trs) where + +import AFRP + +import AFRPTestsCommon + +------------------------------------------------------------------------------ +-- Test cases for embedding +------------------------------------------------------------------------------ + +embed_ratio :: SF a Double +embed_ratio = switch (constant 1.0 &&& after 5.0 ()) $ \_ -> + switch (constant 0.0 &&& after 5.0 ()) $ \_ -> + constant 3.0 + +embed_sf :: SF a Double +embed_sf = localTime >>> integral + +embed_t0 = take 20 $ embed (embed_ratio + >>> embedSynch embed_sf + (deltaEncode 0.01 (repeat ()))) + (deltaEncode 1.0 (repeat ())) + +embed_t0r = + [ 0.0000, 0.4851, 1.9701, 4.4850, 7.9800, + 7.9800, 7.9800, 7.9800, 7.9800, 7.9800, + 24.4650, 49.9500, 84.4350, 127.9200, 180.2151, + 241.6701, 312.1251, 391.5801, 480.03510, 577.4901] + + +embed_t1 = take 20 $ embed (embed_ratio + >>> embedSynch embed_sf + (deltaEncode 0.5 (replicate 30 ()))) + (deltaEncode 1.0 (repeat ())) + +embed_t1r = + [ 0.00, 0.25, 1.50, 3.75, 7.00, + 7.00, 7.00, 7.00, 7.00, 7.00, + 22.75, 47.50, 81.25, 101.50, 101.50, + 101.50, 101.50, 101.50, 101.50, 101.50] + +embed_trs = + [ embed_t0 ~= embed_t0r, + embed_t1 ~= embed_t1r + ] + + +embed_tr = and embed_trs
+ tests/AFRPTestsEvSrc.hs view
@@ -0,0 +1,430 @@+{- $Id: AFRPTestsEvSrc.hs,v 1.3 2003/12/19 15:32:22 henrik Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTestsEvSrc * +* Purpose: Test cases for event sources * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPTestsEvSrc (evsrc_trs, evsrc_tr) where + +import AFRP +import AFRPInternals (Event(NoEvent, Event)) + +import AFRPTestsCommon + +------------------------------------------------------------------------------ +-- Test cases for basic event sources and stateful event suppression +------------------------------------------------------------------------------ + +evsrc_t0 :: [Event ()] +evsrc_t0 = testSF1 never + +evsrc_t0r = + [NoEvent, NoEvent, NoEvent, NoEvent, -- 0.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 1.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 2.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 3.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 4.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 5.0 s + NoEvent] + + +evsrc_t1 :: [Event Int] +evsrc_t1 = testSF1 (now 42) + +evsrc_t1r :: [Event Int] +evsrc_t1r = + [Event 42, NoEvent, NoEvent, NoEvent, -- 0.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 1.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 2.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 3.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 4.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 5.0 s + NoEvent] + + +evsrc_t2 :: [Event Int] +evsrc_t2 = testSF1 (after 0.0 42) +evsrc_t2r :: [Event Int] +evsrc_t2r = + [Event 42, NoEvent, NoEvent, NoEvent, -- 0.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 1.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 2.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 3.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 4.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 5.0 s + NoEvent] + + +evsrc_t3 :: [Event Int] +evsrc_t3 = testSF1 (after 3.0 42) + +evsrc_t3r :: [Event Int] +evsrc_t3r = + [NoEvent, NoEvent, NoEvent, NoEvent, -- 0.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 1.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 2.0 s + Event 42, NoEvent, NoEvent, NoEvent, -- 3.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 4.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 5.0 s + NoEvent] + + +evsrc_t4 :: [Event Int] +evsrc_t4 = testSF1 (after 3.01 42) + +evsrc_t4r :: [Event Int] +evsrc_t4r = + [NoEvent, NoEvent, NoEvent, NoEvent, -- 0.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 1.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 2.0 s + NoEvent, Event 42, NoEvent, NoEvent, -- 3.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 4.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 5.0 s + NoEvent] + + +evsrc_t5 :: [Event Int] +evsrc_t5 = testSF1 (repeatedly 0.795 42) + +evsrc_t5r :: [Event Int] +evsrc_t5r = + [NoEvent, NoEvent, NoEvent, NoEvent, -- 0.0 s + Event 42, NoEvent, NoEvent, Event 42, -- 1.0 s + NoEvent, NoEvent, Event 42, NoEvent, -- 2.0 s + NoEvent, Event 42, NoEvent, NoEvent, -- 3.0 s + Event 42, NoEvent, NoEvent, NoEvent, -- 4.0 s + Event 42, NoEvent, NoEvent, Event 42, -- 5.0 s + NoEvent] + +evsrc_t6 :: [Event Int] +evsrc_t6 = testSF1 (repeatedly 0.30 42) + +evsrc_t6r :: [Event Int] +evsrc_t6r = + [NoEvent, NoEvent, Event 42, Event 42, -- 0.0 s + Event 42, Event 42, Event 42, NoEvent, -- 1.0 s + Event 42, Event 42, Event 42, Event 42, -- 2.0 s + Event 42, NoEvent, Event 42, Event 42, -- 3.0 s + Event 42, Event 42, Event 42, NoEvent, -- 4.0 s + Event 42, Event 42, Event 42, Event 42, -- 5.0 s + Event 42] + +evsrc_t7 :: [Event Int] +evsrc_t7 = testSF1 (repeatedly 0.24 42) + +evsrc_t7r :: [Event Int] +evsrc_t7r = + [NoEvent, Event 42, Event 42, Event 42, -- 0.0 s + Event 42, Event 42, Event 42, Event 42, -- 1.0 s + Event 42, Event 42, Event 42, Event 42, -- 2.0 s + Event 42, Event 42, Event 42, Event 42, -- 3.0 s + Event 42, Event 42, Event 42, Event 42, -- 4.0 s + Event 42, Event 42, Event 42, Event 42, -- 5.0 s + Event 42] + + +evsrc_t8 :: [Event Int] +evsrc_t8 = testSF1 (afterEach [(0.00, 1), (0.00, 2), (0.01, 3), (0.23, 4), + (0.02, 5), (0.75, 6), (0.10, 7), (0.10, 8), + (0.10, 9), (2.00, 10)]) + +evsrc_t8r :: [Event Int] +evsrc_t8r = + [Event 1, Event 3, Event 5, NoEvent, -- 0.0 s + NoEvent, Event 6, Event 9, NoEvent, -- 1.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 2.0 s + NoEvent, NoEvent, Event 10, NoEvent, -- 3.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 4.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 5.0 s + NoEvent] + + +evsrc_t9 :: [Event Int] +evsrc_t9 = testSF1 (afterEach [(2.03, 0), + (0.00, 1), (0.00, 2), (0.01, 3), (0.23, 4), + (0.02, 5), (0.75, 6), (0.10, 7), (0.10, 8), + (0.10, 9), (2.00, 10)]) + +evsrc_t9r :: [Event Int] +evsrc_t9r = + [NoEvent, NoEvent, NoEvent, NoEvent, -- 0.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 1.0 s + NoEvent, Event 0, Event 4, NoEvent, -- 2.0 s + NoEvent, Event 6, Event 9, NoEvent, -- 3.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 4.0 s + NoEvent, NoEvent, Event 10, NoEvent, -- 5.0 s + NoEvent] + + +evsrc_t10 :: [Event ()] +evsrc_t10 = testSF1 (localTime >>> arr (>=0) >>> edge) + +evsrc_t10r = + [NoEvent, NoEvent, NoEvent, NoEvent, -- 0.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 1.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 2.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 3.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 4.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 5.0 s + NoEvent] + + +evsrc_t11 :: [Event ()] +evsrc_t11 = testSF1 (localTime >>> arr (>=4.26) >>> edge) + +evsrc_t11r = + [NoEvent, NoEvent, NoEvent, NoEvent, -- 0.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 1.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 2.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 3.0 s + NoEvent, NoEvent, Event (), NoEvent, -- 4.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 5.0 s + NoEvent] + + +-- Raising edge detector. +evsrc_isEdge False False = Nothing +evsrc_isEdge False True = Just () +evsrc_isEdge True True = Nothing +evsrc_isEdge True False = Nothing + + +evsrc_t12 :: [Event ()] +evsrc_t12 = testSF1 (localTime >>> arr (>=0) >>> edgeBy evsrc_isEdge False) + +evsrc_t12r = + [Event (), NoEvent, NoEvent, NoEvent, -- 0.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 1.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 2.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 3.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 4.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 5.0 s + NoEvent] + +evsrc_t13 :: [Event ()] +evsrc_t13 = testSF1 (localTime >>> arr (>=4.26) >>> edgeBy evsrc_isEdge False) + +evsrc_t13r = + [NoEvent, NoEvent, NoEvent, NoEvent, -- 0.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 1.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 2.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 3.0 s + NoEvent, NoEvent, Event (), NoEvent, -- 4.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 5.0 s + NoEvent] + +-- Raising and falling edge detector. +evsrc_isEdge2 False False = Nothing +evsrc_isEdge2 False True = Just True +evsrc_isEdge2 True True = Nothing +evsrc_isEdge2 True False = Just False + +evsrc_t14 :: [Event Bool] +evsrc_t14 = testSF1 (localTime + >>> arr (\t -> t >=2.01 && t <= 4.51) + >>> edgeBy evsrc_isEdge2 True) + +evsrc_t14r = + [Event False, NoEvent, NoEvent, NoEvent, -- 0.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 1.0 s + NoEvent, Event True, NoEvent, NoEvent, -- 2.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 3.0 s + NoEvent, NoEvent, NoEvent, Event False, -- 4.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 5.0 s + NoEvent] + +evsrc_t15 :: [Event Int] +evsrc_t15 = testSF1 (now 17 &&& repeatedly 0.795 42 + >>> arr (uncurry merge) + >>> notYet) + +evsrc_t15r :: [Event Int] +evsrc_t15r = + [NoEvent, NoEvent, NoEvent, NoEvent, -- 0.0 s + Event 42, NoEvent, NoEvent, Event 42, -- 1.0 s + NoEvent, NoEvent, Event 42, NoEvent, -- 2.0 s + NoEvent, Event 42, NoEvent, NoEvent, -- 3.0 s + Event 42, NoEvent, NoEvent, NoEvent, -- 4.0 s + Event 42, NoEvent, NoEvent, Event 42, -- 5.0 s + NoEvent] + + +evsrc_t16 :: [Event Int] +evsrc_t16 = testSF1 (now 42 >>> once) + +evsrc_t16r :: [Event Int] +evsrc_t16r = + [Event 42, NoEvent, NoEvent, NoEvent, -- 0.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 1.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 2.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 3.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 4.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 5.0 s + NoEvent] + + +evsrc_t17 :: [Event Int] +evsrc_t17 = testSF1 (repeatedly 0.8 42 >>> once) + +evsrc_t17r :: [Event Int] +evsrc_t17r = + [NoEvent, NoEvent, NoEvent, NoEvent, -- 0.0 s + Event 42, NoEvent, NoEvent, NoEvent, -- 1.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 2.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 3.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 4.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 5.0 s + NoEvent] + + +evsrc_t18 :: [Event Int] +evsrc_t18 = testSF1 (now 42 >>> takeEvents 0) + +evsrc_t18r :: [Event Int] +evsrc_t18r = + [NoEvent, NoEvent, NoEvent, NoEvent, -- 0.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 1.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 2.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 3.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 4.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 5.0 s + NoEvent] + + +evsrc_t19 :: [Event Int] +evsrc_t19 = testSF1 (now 42 >>> takeEvents 1) + +evsrc_t19r :: [Event Int] +evsrc_t19r = + [Event 42, NoEvent, NoEvent, NoEvent, -- 0.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 1.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 2.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 3.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 4.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 5.0 s + NoEvent] + + +evsrc_t20 :: [Event Int] +evsrc_t20 = testSF1 (repeatedly 0.8 42 >>> takeEvents 4) + +evsrc_t20r :: [Event Int] +evsrc_t20r = + [NoEvent, NoEvent, NoEvent, NoEvent, -- 0.0 s + Event 42, NoEvent, NoEvent, Event 42, -- 1.0 s + NoEvent, NoEvent, Event 42, NoEvent, -- 2.0 s + NoEvent, Event 42, NoEvent, NoEvent, -- 3.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 4.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 5.0 s + NoEvent] + + +evsrc_t21 :: [Event Int] +evsrc_t21 = testSF1 (repeatedly 0.2 42 >>> takeEvents 4) + +evsrc_t21r :: [Event Int] +evsrc_t21r = + [NoEvent, Event 42, Event 42, Event 42, -- 0.0 s + Event 42, NoEvent, NoEvent, NoEvent, -- 1.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 2.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 3.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 4.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 5.0 s + NoEvent] + + +evsrc_t22 :: [Event Int] +evsrc_t22 = testSF1 (now 42 >>> dropEvents 0) + +evsrc_t22r :: [Event Int] +evsrc_t22r = + [Event 42, NoEvent, NoEvent, NoEvent, -- 0.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 1.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 2.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 3.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 4.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 5.0 s + NoEvent] + + +evsrc_t23 :: [Event Int] +evsrc_t23 = testSF1 (now 42 >>> dropEvents 1) + +evsrc_t23r :: [Event Int] +evsrc_t23r = + [NoEvent, NoEvent, NoEvent, NoEvent, -- 0.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 1.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 2.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 3.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 4.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 5.0 s + NoEvent] + + +evsrc_t24 :: [Event Int] +-- Drop 5 events to get rid of the event at 4.0 s which may or may not happen +-- exactly there. +evsrc_t24 = testSF1 (repeatedly 0.8 42 >>> dropEvents 5) + +evsrc_t24r :: [Event Int] +evsrc_t24r = + [NoEvent, NoEvent, NoEvent, NoEvent, -- 0.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 1.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 2.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 3.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 4.0 s + Event 42, NoEvent, NoEvent, Event 42, -- 5.0 s + NoEvent] + + +evsrc_t25 :: [Event Int] +evsrc_t25 = testSF1 (repeatedly 0.2 42 >>> dropEvents 4) + +evsrc_t25r :: [Event Int] +evsrc_t25r = + [NoEvent, NoEvent, NoEvent, NoEvent, -- 0.0 s + NoEvent, Event 42, Event 42, Event 42, -- 1.0 s + Event 42, Event 42, Event 42, Event 42, -- 2.0 s + Event 42, Event 42, Event 42, Event 42, -- 3.0 s + Event 42, Event 42, Event 42, Event 42, -- 4.0 s + Event 42, Event 42, Event 42, Event 42, -- 5.0 s + Event 42] + + +evsrc_trs = + [ evsrc_t0 ~= evsrc_t0r, + evsrc_t1 ~= evsrc_t1r, + evsrc_t2 ~= evsrc_t2r, + evsrc_t3 ~= evsrc_t3r, + evsrc_t4 ~= evsrc_t4r, + evsrc_t5 ~= evsrc_t5r, + evsrc_t6 ~= evsrc_t6r, + evsrc_t7 ~= evsrc_t7r, + evsrc_t8 ~= evsrc_t8r, + evsrc_t9 ~= evsrc_t9r, + evsrc_t10 ~= evsrc_t10r, + evsrc_t11 ~= evsrc_t11r, + evsrc_t12 ~= evsrc_t12r, + evsrc_t13 ~= evsrc_t13r, + evsrc_t14 ~= evsrc_t14r, + evsrc_t15 ~= evsrc_t15r, + evsrc_t16 ~= evsrc_t16r, + evsrc_t17 ~= evsrc_t17r, + evsrc_t18 ~= evsrc_t18r, + evsrc_t19 ~= evsrc_t19r, + evsrc_t20 ~= evsrc_t20r, + evsrc_t21 ~= evsrc_t21r, + evsrc_t22 ~= evsrc_t22r, + evsrc_t23 ~= evsrc_t23r, + evsrc_t24 ~= evsrc_t24r, + evsrc_t25 ~= evsrc_t25r + ] + +evsrc_tr = and evsrc_trs
+ tests/AFRPTestsFirstSecond.hs view
@@ -0,0 +1,125 @@+{- $Id: AFRPTestsFirstSecond.hs,v 1.2 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTestsArr * +* Purpose: Test cases for first and second * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPTestsFirstSecond (first_trs, first_tr, second_trs, second_tr) where + +import AFRP + +import AFRPTestsCommon + +------------------------------------------------------------------------------ +-- Test cases for first +------------------------------------------------------------------------------ + +first_t0 :: [(Int,Double)] +first_t0 = testSF1 (arr dup >>> first (constant 7)) +first_t0r :: [(Int,Double)] +first_t0r = + [(7,0.0), (7,1.0), (7,2.0), (7,3.0), (7,4.0), + (7,5.0), (7,6.0), (7,7.0), (7,8.0), (7,9.0), + (7,10.0), (7,11.0), (7,12.0), (7,13.0), (7,14.0), + (7,15.0), (7,16.0), (7,17.0), (7,18.0), (7,19.0), + (7,20.0), (7,21.0), (7,22.0), (7,23.0), (7,24.0)] + +first_t1 :: [(Int,Double)] +first_t1 = testSF2 (arr dup >>> first (constant 7)) +first_t1r :: [(Int,Double)] +first_t1r = + [(7,0.0), (7,0.0), (7,0.0), (7,0.0), (7,0.0), + (7,1.0), (7,1.0), (7,1.0), (7,1.0), (7,1.0), + (7,2.0), (7,2.0), (7,2.0), (7,2.0), (7,2.0), + (7,3.0), (7,3.0), (7,3.0), (7,3.0), (7,3.0), + (7,4.0), (7,4.0), (7,4.0), (7,4.0), (7,4.0)] + +first_t2 :: [(Double,Double)] +first_t2 = testSF1 (arr dup >>> first (arr (+1))) +first_t2r = + [(1.0,0.0), (2.0,1.0), (3.0,2.0), (4.0,3.0), (5.0,4.0), + (6.0,5.0), (7.0,6.0), (8.0,7.0), (9.0,8.0), (10.0,9.0), + (11.0,10.0), (12.0,11.0), (13.0,12.0), (14.0,13.0), (15.0,14.0), + (16.0,15.0), (17.0,16.0), (18.0,17.0), (19.0,18.0), (20.0,19.0), + (21.0,20.0), (22.0,21.0), (23.0,22.0), (24.0,23.0), (25.0,24.0)] + +first_t3 :: [(Double,Double)] +first_t3 = testSF2 (arr dup >>> first (arr (+1))) +first_t3r = + [(1.0,0.0), (1.0,0.0), (1.0,0.0), (1.0,0.0), (1.0,0.0), + (2.0,1.0), (2.0,1.0), (2.0,1.0), (2.0,1.0), (2.0,1.0), + (3.0,2.0), (3.0,2.0), (3.0,2.0), (3.0,2.0), (3.0,2.0), + (4.0,3.0), (4.0,3.0), (4.0,3.0), (4.0,3.0), (4.0,3.0), + (5.0,4.0), (5.0,4.0), (5.0,4.0), (5.0,4.0), (5.0,4.0)] + +first_t4 :: [(Double,Double)] +first_t4 = testSF1 (arr dup >>> first integral) +first_t4r = + [(0.0,0.0), (0.0,1.0), (0.25,2.0), (0.75,3.0), (1.5,4.0), + (2.5,5.0), (3.75,6.0), (5.25,7.0), (7.0,8.0), (9.0,9.0), + (11.25,10.0), (13.75,11.0), (16.5,12.0), (19.5,13.0), (22.75,14.0), + (26.25,15.0), (30.0,16.0), (34.0,17.0), (38.25,18.0), (42.75,19.0), + (47.5,20.0), (52.5,21.0), (57.75,22.0), (63.25,23.0), (69.0,24.0)] + +first_t5 :: [(Double,Double)] +first_t5 = testSF2 (arr dup >>> first integral) +first_t5r = + [(0.0,0.0), (0.0,0.0), (0.0,0.0), (0.0,0.0), (0.0,0.0), + (0.0,1.0), (0.25,1.0), (0.5,1.0), (0.75,1.0), (1.0,1.0), + (1.25,2.0), (1.75,2.0), (2.25,2.0), (2.75,2.0), (3.25,2.0), + (3.75,3.0), (4.5,3.0), (5.25,3.0), (6.0,3.0), (6.75,3.0), + (7.5,4.0), (8.5,4.0), (9.5,4.0), (10.5,4.0), (11.5,4.0)] + +first_trs = + [ first_t0 ~= first_t0r, + first_t1 ~= first_t1r, + first_t2 ~= first_t2r, + first_t3 ~= first_t3r, + first_t4 ~= first_t4r, + first_t5 ~= first_t5r + ] + +first_tr = and first_trs + + +------------------------------------------------------------------------------ +-- Test cases for second +------------------------------------------------------------------------------ + +-- These should mirror the test cases for first. + +second_t0 :: [(Int,Double)] +second_t0 = testSF1 (arr dup >>> second (constant 7) >>> arr swap) + +second_t1 :: [(Int,Double)] +second_t1 = testSF2 (arr dup >>> second (constant 7) >>> arr swap) + +second_t2 :: [(Double,Double)] +second_t2 = testSF1 (arr dup >>> second (arr (+1)) >>> arr swap) + +second_t3 :: [(Double,Double)] +second_t3 = testSF2 (arr dup >>> second (arr (+1)) >>> arr swap) + +second_t4 :: [(Double,Double)] +second_t4 = testSF1 (arr dup >>> second integral >>> arr swap) + +second_t5 :: [(Double,Double)] +second_t5 = testSF2 (arr dup >>> second integral >>> arr swap) + +second_trs = + [ second_t0 ~= first_t0r, + second_t1 ~= first_t1r, + second_t2 ~= first_t2r, + second_t3 ~= first_t3r, + second_t4 ~= first_t4r, + second_t5 ~= first_t5r + ] + +second_tr = and second_trs
+ tests/AFRPTestsKSwitch.hs view
@@ -0,0 +1,128 @@+{- $Id: AFRPTestsKSwitch.hs,v 1.2 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTestsKSwitch * +* Purpose: Test cases for kSwitch and dkSwitch * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPTestsKSwitch (kswitch_tr, kswitch_trs) where + +import AFRP + +import AFRPTestsCommon + +------------------------------------------------------------------------------ +-- Test cases for kSwitch and dkSwitch +------------------------------------------------------------------------------ + +kswitch_inp1 = deltaEncode 0.1 [0.0, 0.5 ..] + +whenSndGE :: Ord b => b -> c -> SF (a, b) (Event c) +whenSndGE b c = arr snd >>> arr (>= b) >>> edge >>> arr (`tag` c) + + +kswitch_t0 :: [Double] +kswitch_t0 = take 20 $ embed sf kswitch_inp1 + where + sf = + kSwitch integral (whenSndGE 0.2 (-1.0)) $ \sf1 x -> + kSwitch (integral >>> arr (+x)) (whenSndGE 1.0 (1.0)) $ \_ _ -> + sf1 + +kswitch_t0r = + [ 0.00, 0.00, 0.05, 0.15, -1.00, + -0.80, -0.55, -0.25, 0.10, 0.50, + 0.95, 0.30, 0.85, 1.45, 2.10, + 2.80, 3.55, 4.35, 5.20, 6.10] + + +kswitch_t1 :: [Double] +kswitch_t1 = take 20 $ embed sf kswitch_inp1 + where + sf = + dkSwitch integral (whenSndGE 0.2 (-1.0)) $ \sf1 x -> + dkSwitch (integral >>> arr (+x)) (whenSndGE 1.0 (1.0)) $ \_ _ -> + sf1 + +kswitch_t1r = + [ 0.00, 0.00, 0.05, 0.15, 0.30, + -0.80, -0.55, -0.25, 0.10, 0.50, + 0.95, 1.45, 0.85, 1.45, 2.10, + 2.80, 3.55, 4.35, 5.20, 6.10] + + +kswitch_t2 :: [Double] +kswitch_t2 = take 20 $ embed sf kswitch_inp1 + where + sf = + kSwitch integral (now (-1.0)) $ \sf1 x -> + kSwitch (integral >>> arr (+x)) (whenSndGE 1.0 (1.0)) $ \_ _ -> + sf1 + +kswitch_t2r = + [-1.00, -1.00, -0.95, -0.85, -0.70, + -0.50, -0.25, 0.05, 0.40, 0.80, + 0.00, 0.50, 1.05, 1.65, 2.30, + 3.00, 3.75, 4.55, 5.40, 6.30] + + +kswitch_t3 :: [Double] +kswitch_t3 = take 20 $ embed sf kswitch_inp1 + where + sf = + dkSwitch integral (now (-1.0)) $ \sf1 x -> + dkSwitch (integral >>> arr (+x)) (whenSndGE 1.0 (1.0)) $ \_ _ -> + sf1 + +kswitch_t3r = + [ 0.00, -1.00, -0.95, -0.85, -0.70, + -0.50, -0.25, 0.05, 0.40, 0.80, + 1.25, 0.50, 1.05, 1.65, 2.30, + 3.00, 3.75, 4.55, 5.40, 6.30] + + +-- The correct strictness properties of dkSwitch are crucial here. +-- kSwitch does not work. +kswitch_t4 = take 40 $ + embed (loop $ + dkSwitch sf (sfe 0.55 (-1.0)) $ \sf1 x -> + dkSwitch (sf >>> arr2 (+x)) (sfe 0.05 8.0) $ \sf2 y -> + dkSwitch sf1 (sfe 2.0 (-2.0)) $ \_ z -> + sf2 >>> arr2 (+(y + z)) + ) + (deltaEncode 0.1 (repeat ())) + where + sf :: SF (a, Double) (Double, Double) + sf = constant 1.0 >>> integral >>> arr dup + + sfe :: Double -> Double -> SF ((a, Double), b) (Event Double) + sfe x e = arr fst >>> whenSndGE x e + + arr2 f = arr (\(x,y) -> (f x, f y)) + +kswitch_t4r = + [ 0.0, 0.1, 0.2, 0.3, 0.4, + 0.5, 0.6, -0.9, -0.8, -0.7, + -0.6, -0.5, -0.4, -0.3, -0.2, + -0.1, 0.0, 0.1, 0.7, 0.8, + 0.9, 1.0, 1.1, 1.2, 1.3, + 1.4, 1.5, 1.6, 1.7, 1.8, + 1.9, 2.0, 6.2, 6.3, 6.4, + 6.5, 6.6, 6.7, 6.8, 6.9] + + +kswitch_trs = + [ kswitch_t0 ~= kswitch_t0r, + kswitch_t1 ~= kswitch_t1r, + kswitch_t2 ~= kswitch_t2r, + kswitch_t3 ~= kswitch_t3r, + kswitch_t4 ~= kswitch_t4r + ] + +kswitch_tr = and kswitch_trs
+ tests/AFRPTestsLaws.hs view
@@ -0,0 +1,89 @@+{- $Id: AFRPTestsLaws.hs,v 1.2 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTestsLaws * +* Purpose: Test cases based on the arrow laws * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPTestsLaws (laws_trs, laws_tr) where + +import AFRP + +import AFRPTestsCommon + +------------------------------------------------------------------------------ +-- Test cases based on the arrow laws +------------------------------------------------------------------------------ + +-- For a description of the laws, see e.g. Ross Paterson: Embedding a Class of +-- Domain-Specific Languages in a Functional Language. +-- Only a very rudimentary sanity check. Obviously not intended to "prove" +-- this implementation indeed do respect the laws. + +laws_t0_lhs :: [Double] +laws_t0_lhs = testSF1 (arr id >>> integral) +laws_t0_rhs :: [Double] +laws_t0_rhs = testSF1 (integral) + +laws_t1_lhs :: [Double] +laws_t1_lhs = testSF1 (integral >>> arr id) +laws_t1_rhs :: [Double] +laws_t1_rhs = testSF1 (integral) + +laws_t2_lhs :: [Double] +laws_t2_lhs = testSF1 ((integral >>> arr (*0.5)) >>> integral) +laws_t2_rhs :: [Double] +laws_t2_rhs = testSF1 (integral >>> (arr (*0.5) >>> integral)) + +laws_t3_lhs :: [Double] +laws_t3_lhs = testSF1 (arr ((*2.5) . (+3.0))) +laws_t3_rhs :: [Double] +laws_t3_rhs = testSF1 (arr (+3.0) >>> arr (*2.5)) + +laws_t4_lhs :: [(Double, Double)] +laws_t4_lhs = testSF1 (arr dup >>> first (arr (*2.5))) +laws_t4_rhs :: [(Double, Double)] +laws_t4_rhs = testSF1 (arr dup >>> arr (fun_prod (*2.5) id)) + +laws_t5_lhs :: [(Double, Double)] +laws_t5_lhs = testSF1 (arr dup >>> (first (integral >>> arr (+3.0)))) +laws_t5_rhs :: [(Double, Double)] +laws_t5_rhs = testSF1 (arr dup >>> (first integral >>> first (arr (+3.0)))) + +laws_t6_lhs :: [(Double, Double)] +laws_t6_lhs = testSF1 (arr dup >>> (first integral>>>arr (fun_prod id (+3.0)))) +laws_t6_rhs :: [(Double, Double)] +laws_t6_rhs = testSF1 (arr dup >>> (arr (fun_prod id (+3.0))>>>first integral)) + +laws_t7_lhs :: [Double] +laws_t7_lhs = testSF1 (arr dup >>> (first integral >>> arr fst)) +laws_t7_rhs :: [Double] +laws_t7_rhs = testSF1 (arr dup >>> (arr fst >>> integral)) + +laws_t8_lhs :: [(Double, (Double, ()))] +laws_t8_lhs = testSF1 (arr (\x -> ((x,x),())) + >>> (first (first integral) >>> arr assoc)) +laws_t8_rhs :: [(Double, (Double, ()))] +laws_t8_rhs = testSF1 (arr (\x -> ((x,x),())) + >>> (arr assoc >>> first integral)) + + +laws_trs = + [ laws_t0_lhs ~= laws_t0_rhs, + laws_t1_lhs ~= laws_t1_rhs, + laws_t2_lhs ~= laws_t2_rhs, + laws_t3_lhs ~= laws_t3_rhs, + laws_t4_lhs ~= laws_t4_rhs, + laws_t5_lhs ~= laws_t5_rhs, + laws_t6_lhs ~= laws_t6_rhs, + laws_t7_lhs ~= laws_t7_rhs, + laws_t8_lhs ~= laws_t8_rhs + ] + +laws_tr = and laws_trs
+ tests/AFRPTestsLoop.hs view
@@ -0,0 +1,206 @@+{- $Id: AFRPTestsLoop.hs,v 1.6 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTestsLoop * +* Purpose: Test cases for loop * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPTestsLoop (loop_trs, loop_tr, loop_st0, loop_st0r, + loop_st1, loop_st1r) where + +import AFRP + +import AFRPTestsCommon + +------------------------------------------------------------------------------ +-- Test cases for loop +------------------------------------------------------------------------------ + +loop_acc :: SF (Double, Double) (Double, Double) +loop_acc = arr (\(x, y)->(x+y, x+y)) + +loop_t0 :: [Double] +loop_t0 = testSF1 (loop (constant (42.0, 43.0))) +loop_t0r = + [42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, + 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, + 42.0, 42.0, 42.0, 42.0, 42.0] + +loop_t1 :: [Double] +loop_t1 = testSF1 (loop identity) +loop_t1r = + [0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 8.0, 9.0, + 10.0, 11.0, 12.0, 13.0, 14.0, 15.0, 16.0, 17.0, 18.0, 19.0, + 20.0, 21.0, 22.0, 23.0, 24.0] + +loop_t2 :: [Time] +loop_t2 = testSF1 (loop (first localTime)) +loop_t2r = + [0.0, 0.25, 0.5, 0.75, 1.0, + 1.25, 1.5, 1.75, 2.0, 2.25, + 2.5, 2.75, 3.0, 3.25, 3.5, + 3.75, 4.0, 4.25, 4.5, 4.75, + 5.0, 5.25, 5.5, 5.75, 6.0] + +-- AC, 10-March-2002: I think this is the simplest test that will +-- fail with AltST. +loop_t3 :: [Time] +loop_t3 = testSF1 (loop (second (iPre 0))) +loop_t3r = + [0.0, 1.0, 2.0, 3.0, 4.0, + 5.0, 6.0, 7.0, 8.0, 9.0, + 10.0, 11.0, 12.0, 13.0, 14.0, + 15.0, 16.0, 17.0, 18.0, 19.0, + 20.0, 21.0, 22.0, 23.0, 24.0] + +loop_t4 :: [Double] +loop_t4 = testSF1 (loop (second (iPre 0) >>> loop_acc)) +loop_t4r = + [0.0, 1.0, 3.0, 6.0, 10.0, + 15.0, 21.0, 28.0, 36.0, 45.0, + 55.0, 66.0, 78.0, 91.0, 105.0, + 120.0, 136.0, 153.0, 171.0, 190.0, + 210.0, 231.0, 253.0, 276.0, 300.0] + +loop_t5 :: [Double] +loop_t5 = testSF2 (loop (second (iPre 0) >>> loop_acc)) +loop_t5r = + [0.0, 0.0, 0.0, 0.0, 0.0, + 1.0, 2.0, 3.0, 4.0, 5.0, + 7.0, 9.0, 11.0, 13.0, 15.0, + 18.0, 21.0, 24.0, 27.0, 30.0, + 34.0, 38.0, 42.0, 46.0, 50.0] + +loop_t6 :: [Double] +loop_t6 = testSF1 (loop (iPre (0,0) >>> first localTime >>> loop_acc)) +loop_t6r = + [0.0, 0.25, 0.75, 1.5, 2.5, + 3.75, 5.25, 7.0, 9.0, 11.25, + 13.75, 16.5, 19.5, 22.75, 26.25, + 30.0, 34.0, 38.25, 42.75, 47.5, + 52.5, 57.75, 63.25, 69.0, 75.0] + +loop_t7 :: [Double] +loop_t7 = testSF1 (loop (loop_acc >>> second (iPre 0))) +loop_t7r = loop_t4r + +loop_t8 :: [Double] +loop_t8 = testSF2 (loop (loop_acc >>> second (iPre 0))) +loop_t8r = loop_t5r + +loop_t9 :: [Double] +loop_t9 = testSF1 (loop (first localTime >>> loop_acc >>> iPre (0,0))) +loop_t9r = + [0.0, 0.0, 0.25, 0.75, 1.5, + 2.5, 3.75, 5.25, 7.0, 9.0, + 11.25, 13.75, 16.5, 19.5, 22.75, + 26.25, 30.0, 34.0, 38.25, 42.75, + 47.5, 52.5, 57.75, 63.25, 69.0] + +loop_t10 :: [Double] +loop_t10 = testSF1 (loop (loop_acc >>> second (iPre 0) >>> identity)) +loop_t10r = loop_t4r + +loop_t11 :: [Double] +loop_t11 = testSF2 (loop (loop_acc >>> second (iPre 0) >>> identity)) +loop_t11r = loop_t5r + +loop_t12 :: [Double] +loop_t12 = testSF1 (loop (first localTime + >>> loop_acc + >>> iPre (0,0) + >>> identity)) +loop_t12r = loop_t9r + +-- Computation of approximation to exp 0, exp 1, ..., exp 5 by integration. +-- Values as given by using exp directly: +-- 1.0, 2.71828, 7.38906, 20.0855, 54.5981, 148.413 +loop_t13 :: [Double] +loop_t13 = + let + es = embed (loop (second integral >>> arr (\(_, x) -> (x + 1, x + 1)))) + (deltaEncode 0.001 (repeat ())) + in + [es!!0, es!!1000, es!!2000, es!!3000, es!!4000, es!!5000] +loop_t13r = [1.0,2.71692, 7.38167, 20.05544, 54.48911, 148.04276] + +loop_t14 :: [Double] +loop_t14 = + let + es = embed (loop (arr (\(_, x) -> (x + 1, x + 1)) >>> second integral)) + (deltaEncode 0.001 (repeat ())) + in + [es!!0, es!!1000, es!!2000, es!!3000, es!!4000, es!!5000] +loop_t14r = loop_t13r + +loop_t15 :: [Double] +loop_t15 = + let + es = embed (loop (arr (\(_, x) -> (x + 1, x + 1)) + >>> second integral + >>> identity)) + (deltaEncode 0.001 (repeat ())) + in + [es!!0, es!!1000, es!!2000, es!!3000, es!!4000, es!!5000] +loop_t15r = loop_t13r + +-- A generator for factorial: The least-fixed point of this function is +-- the factorial function. + +factGen f n = if (n==0) then 1 else n*f(n-1) + +-- Can we use loop to construct a fixed point? +loop_t16 :: [Int] +loop_t16 = testSF1 (loop $ arr (\ (_,f) -> (f 4,factGen f))) +loop_t16r = + [24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24] + +-- A simple loop test taken from MiniYampa: +-- This results in pulling on the fed-back output during evaluation, because +-- switch is strict in its input sample: +loop_t17 :: [Double] +loop_t17 = testSF1 (loop $ second $ (switch identity (const (arr fst))) >>> arr (\x -> (x,noEvent)) >>> (iPre (25, noEvent))) +loop_t17r = + [0.0,1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0, + 16.0,17.0,18.0,19.0,20.0,21.0,22.0,23.0,24.0] + +loop_trs = + [ loop_t0 ~= loop_t0r, + loop_t1 ~= loop_t1r, + loop_t2 ~= loop_t2r, + loop_t3 ~= loop_t3r, + loop_t4 ~= loop_t4r, + loop_t5 ~= loop_t5r, + loop_t6 ~= loop_t6r, + loop_t7 ~= loop_t7r, + loop_t8 ~= loop_t8r, + loop_t9 ~= loop_t9r, + loop_t10 ~= loop_t10r, + loop_t11 ~= loop_t11r, + loop_t12 ~= loop_t12r, + loop_t13 ~= loop_t13r, + loop_t14 ~= loop_t14r, + loop_t15 ~= loop_t15r, + loop_t16 ~= loop_t16r, + loop_t17 ~= loop_t17r + ] + +loop_tr = and loop_trs + +loop_st0 = testSFSpaceLeak 2000000 + (loop (second (iPre 0) >>> loop_acc)) +loop_st0r = 9.999995e11 + +-- A simple loop test taken from MiniYampa: +-- This results in pulling on the fed-back output during evaluation, because +-- switch is strict in its input sample: +loop_st1 :: Double +loop_st1 = testSFSpaceLeak 2000000 + (loop $ second $ (switch identity (const (arr fst))) >>> arr (\x -> (x + x + x + x + x + x + x,noEvent)) >>> (iPre (25, noEvent))) +loop_st1r = 999999.5
+ tests/AFRPTestsLoopIntegral.hs view
@@ -0,0 +1,104 @@+{- $Id: AFRPTestsLoopIntegral.hs,v 1.2 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTestsLoopIntegral * +* Purpose: Test cases for loopIntegral * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPTestsLoopIntegral (loopIntegral_tr, loopIntegral_trs) where + +import AFRP + +import AFRPTestsCommon + +------------------------------------------------------------------------------ +-- Test cases for loopIntegral +------------------------------------------------------------------------------ + +-- Computation of approximation to exp 0, exp 1, ..., exp 5 by integration. +-- Values as given by using exp directly: +-- 1.0, 2.71828, 7.38906, 20.0855, 54.5981, 148.413 +loopIntegral_t0 = + let + es = embed (loopIntegral (arr (\(_, x) -> (x + 1, x + 1)))) + (deltaEncode 0.001 (repeat ())) + in + [es!!0, es!!1000, es!!2000, es!!3000, es!!4000, es!!5000] +loopIntegral_t0r :: [Double] +loopIntegral_t0r = [1.0,2.71692,7.38167,20.05544,54.48911,148.04276] + + +-- Test case with a time varying signal transformer inside the loop. +-- Starting at position 0 [m], accelerate by 1.0 [m/s^2] until position +-- exceeds 2.0 [m]. Then accelerate by -1.0 [m/s^2] until position gets +-- below 0.0 [m]. Then accelerate at 1.0 [m/s^2] again. And so on. + +type Position = Double +type Velocity = Double +type Acceleration = Double + +posCntrl :: SF b Position +posCntrl = loopIntegral posCntrlNR + where + posCntrlNR :: SF (b, Velocity) (Position, Acceleration) + posCntrlNR = + arr snd -- Get the velocity. + >>> integral -- This integral gives us the position. + >>> arr (\x -> (x,x)) + >>> + (second $ + arr (\x -> (x,x)) + >>> + (first $ + arr (>=2.0) + >>> edge + >>> (arr (fmap (const (constant (-1.0)))))) + >>> + (second $ + arr (< 0.0) + >>> edge + >>> (arr (fmap (const (constant 1.0))))) + >>> arr (\(e1,e2) -> e1 `lMerge` e2) + >>> arr (\e -> ((), e)) + >>> rSwitch (constant 1.0)) + + +loopIntegral_t1 = take 250 (embed posCntrl (deltaEncode 0.1 (repeat ()))) + +-- Result only partially verified. But the sign of the acceleration changes +-- at roughly the right points. +loopIntegral_t1r :: [Double] +loopIntegral_t1r = + [0.0,0.0,0.01,0.03,0.06,0.1,0.15,0.21,0.28,0.36,0.45,0.55,0.66,0.78,0.91, + 1.05,1.2,1.36,1.53,1.71,1.9,2.1,2.31,2.51,2.7,2.88,3.05,3.21,3.36,3.5, + 3.63,3.75,3.86,3.96,4.05,4.13,4.2,4.26,4.31,4.35,4.38,4.4,4.41,4.41,4.4, + 4.38,4.35,4.31,4.26,4.2,4.13,4.05,3.96,3.86,3.75,3.63,3.5,3.36,3.21,3.05, + 2.88,2.7,2.51,2.31,2.1,1.88,1.65,1.41,1.16,0.9,0.63,0.35,0.06,-0.24, + -0.55,-0.85,-1.14,-1.42,-1.69,-1.95,-2.2,-2.44,-2.67,-2.89,-3.1,-3.3, + -3.49,-3.67,-3.84,-4.0,-4.15,-4.29,-4.42,-4.54,-4.65,-4.75,-4.84,-4.92, + -4.99,-5.05,-5.1,-5.14,-5.17,-5.19,-5.2,-5.2,-5.19,-5.17,-5.14,-5.1, + -5.05,-4.99,-4.92,-4.84,-4.75,-4.65,-4.54,-4.42,-4.29,-4.15,-4.0,-3.84, + -3.67,-3.49,-3.3,-3.1,-2.89,-2.67,-2.44,-2.2,-1.95,-1.69,-1.42,-1.14, + -0.85,-0.55,-0.24,0.08,0.41,0.75,1.1,1.46,1.83,2.21,2.6,2.98,3.35,3.71, + 4.06,4.4,4.73,5.05,5.36,5.66,5.95,6.23,6.5,6.76,7.01,7.25,7.48,7.7,7.91, + 8.11,8.3,8.48,8.65,8.81,8.96,9.1,9.23,9.35,9.46,9.56,9.65,9.73,9.8,9.86, + 9.91,9.95,9.98,10.0,10.01,10.01,10.0,9.98,9.95,9.91,9.86,9.8,9.73,9.65, + 9.56,9.46,9.35,9.23,9.1,8.96,8.81,8.65,8.48,8.3,8.11,7.91,7.7,7.48,7.25, + 7.01,6.76,6.5,6.23,5.95,5.66,5.36,5.05,4.73,4.4,4.06,3.71,3.35,2.98,2.6, + 2.21,1.81,1.4,0.98,0.55,0.11,-0.34,-0.80,-1.25,-1.69,-2.12,-2.54,-2.95, + -3.35,-3.74,-4.12,-4.49,-4.85,-5.2,-5.54,-5.87,-6.19,-6.5,-6.8,-7.09, + -7.37,-7.64,-7.9] + + +loopIntegral_trs = + [ loopIntegral_t0 ~= loopIntegral_t0r, + loopIntegral_t1 ~= loopIntegral_t1r + ] + +loopIntegral_tr = and loopIntegral_trs
+ tests/AFRPTestsLoopLaws.hs view
@@ -0,0 +1,107 @@+{- $Id: AFRPTestsLoopLaws.hs,v 1.2 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTestsLoopLaws * +* Purpose: Test cases based on the arrow laws for loop * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPTestsLoopLaws (looplaws_trs, looplaws_tr) where + +import AFRP + +import AFRPTestsCommon + +------------------------------------------------------------------------------ +-- Test cases based on the arrow laws for loop +------------------------------------------------------------------------------ + +-- For a description of the laws, see Ross Paterson: Embedding a Class of +-- Domain-Specific Languages in a Functional Language. +-- Only a very rudimentary sanity check. Obviously not intended to "prove" +-- this implementation indeed do respect the laws. + +simple_loop :: ((a,c) -> (b,c)) -> (a -> b) +simple_loop f a = b + where + (b, c) = f (a, c) + + +-- Left tightening +looplaws_t0_f = second integral >>> arr swap +looplaws_t0_h :: Fractional a => SF a a +looplaws_t0_h = arr (+10.0) +looplaws_t0_lhs :: [Double] +looplaws_t0_lhs = testSF1 (loop (first looplaws_t0_h >>> looplaws_t0_f)) +looplaws_t0_rhs :: [Double] +looplaws_t0_rhs = testSF1 (looplaws_t0_h >>> loop looplaws_t0_f) + + +-- Right tightening +looplaws_t1_f = second integral >>> arr swap +looplaws_t1_h :: Fractional a => SF a a +looplaws_t1_h = arr (+10.0) +looplaws_t1_lhs :: [Double] +looplaws_t1_lhs = testSF1 (loop (looplaws_t1_f >>> first looplaws_t1_h)) +looplaws_t1_rhs :: [Double] +looplaws_t1_rhs = testSF1 (loop looplaws_t1_f >>> looplaws_t1_h) + + +-- Sliding +-- Used to work with only signature t2_f :: Fractional a -> SF a a +looplaws_t2_f :: SF (Double, Double) (Double, Double) +looplaws_t2_f = integral +looplaws_t2_k = fun_prod id (+42.0) +looplaws_t2_lhs :: [Double] +looplaws_t2_lhs = testSF1 (loop (looplaws_t2_f >>> arr looplaws_t2_k)) +looplaws_t2_rhs :: [Double] +looplaws_t2_rhs = testSF1 (loop (arr looplaws_t2_k >>> looplaws_t2_f)) + + +-- Vanishing +-- The lazy pattern matching (~) is necessary to avoid a black hole in the +-- RHS due to premature forcing of tuples. As far as I can tell, loop is +-- as lazy as it can be, and this problem could not have been solved by +-- "fixing" the loop definition. +looplaws_t3_f = second integral + >>> first (arr swap) + >>> arr (\ ~((a,b),c) -> ((a,c),b)) +looplaws_t3_lhs :: [Double] +looplaws_t3_lhs = testSF1 (loop (loop looplaws_t3_f)) +looplaws_t3_rhs :: [Double] +looplaws_t3_rhs = testSF1 (loop (arr assoc_inv >>> looplaws_t3_f >>>arr assoc)) + + +-- Superposing +looplaws_t4_f = second integral >>> arr swap +looplaws_t4_lhs :: [(Double,Double)] +looplaws_t4_lhs = testSF1 (arr dup >>> (second (loop looplaws_t4_f))) +looplaws_t4_rhs :: [(Double, Double)] +looplaws_t4_rhs = testSF1 (arr dup >>> (loop (arr assoc + >>> second looplaws_t4_f + >>> arr assoc_inv))) + + +-- Extension +looplaws_t5_f = \(a,c) -> (take 5 c, a : c) +looplaws_t5_lhs :: [[Double]] +looplaws_t5_lhs = testSF1 (loop (arr looplaws_t5_f)) +looplaws_t5_rhs :: [[Double]] +looplaws_t5_rhs = testSF1 (arr (simple_loop looplaws_t5_f)) + + +looplaws_trs = + [ looplaws_t0_lhs ~= looplaws_t0_rhs, + looplaws_t1_lhs ~= looplaws_t1_rhs, + looplaws_t2_lhs ~= looplaws_t2_rhs, + looplaws_t3_lhs ~= looplaws_t3_rhs, + looplaws_t4_lhs ~= looplaws_t4_rhs, + looplaws_t5_lhs ~= looplaws_t5_rhs + ] + +looplaws_tr = and looplaws_trs
+ tests/AFRPTestsLoopPre.hs view
@@ -0,0 +1,62 @@+{- $Id: AFRPTestsLoopPre.hs,v 1.2 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTestsLoopPre * +* Purpose: Test cases for loopPre * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPTestsLoopPre (loopPre_tr, loopPre_trs) where + +import AFRP + +import AFRPTestsCommon + +------------------------------------------------------------------------------ +-- Test cases for loopPre +------------------------------------------------------------------------------ + +loop_acc :: SF (Double, Double) (Double, Double) +loop_acc = arr (\(x, y)->(x+y, x+y)) + +-- This kind of test will fail for infinitesimal delay! +loopPre_t0 = testSF1 (loopPre 0 loop_acc) +loopPre_t0r = + [0.0,1.0,3.0,6.0,10.0,15.0,21.0,28.0,36.0,45.0,55.0,66.0,78.0,91.0, + 105.0,120.0,136.0,153.0,171.0,190.0,210.0,231.0,253.0,276.0,300.0] + +loopPre_t1 = testSF2 (loopPre 0 loop_acc) +loopPre_t1r = + [0.0,0.0,0.0,0.0,0.0,1.0,2.0,3.0,4.0,5.0,7.0,9.0,11.0,13.0,15.0,18.0, + 21.0,24.0,27.0,30.0,34.0,38.0,42.0,46.0,50.0] + +-- This kind of test will fail for infinitesimal delay! +loopPre_t2 = testSF1 (loopPre False (arr (dup . not . snd))) +loopPre_t2r = + [True,False,True,False,True,False,True,False,True,False,True,False, + True,False,True,False,True,False,True,False,True,False,True,False,True] + +loopPre_t3 = testSF1 (loopPre 0 (first localTime)) +loopPre_t3r = + [0.0,0.25,0.5,0.75,1.0,1.25,1.5,1.75,2.0,2.25,2.5,2.75,3.0,3.25,3.5,3.75, + 4.0,4.25,4.5,4.75,5.0,5.25,5.5,5.75,6.0] + +loopPre_t4 = testSF1 (loopPre 0 (first localTime >>> loop_acc)) +loopPre_t4r = + [0.0,0.25,0.75,1.5,2.5,3.75,5.25,7.0,9.0,11.25,13.75,16.5,19.5,22.75, + 26.25,30.0,34.0,38.25,42.75,47.5,52.5,57.75,63.25,69.0,75.0] + +loopPre_trs = + [ loopPre_t0 ~= loopPre_t0r, + loopPre_t1 ~= loopPre_t1r, + loopPre_t2 ~= loopPre_t2r, + loopPre_t3 ~= loopPre_t3r, + loopPre_t4 ~= loopPre_t4r + ] + +loopPre_tr = and loopPre_trs
+ tests/AFRPTestsPSwitch.hs view
@@ -0,0 +1,325 @@+{- $Id: AFRPTestsPSwitch.hs,v 1.2 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTestsPSwitch * +* Purpose: Test cases for pSwitchB and dpSwitchB * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPTestsPSwitch ( + pswitch_tr, + pswitch_trs, + pswitch_st0, + pswitch_st0r, + pswitch_st1, + pswitch_st1r +) where + +import List (findIndex) + +import AFRP +import AFRPInternals (Event(NoEvent, Event)) + +import AFRPTestsCommon + +------------------------------------------------------------------------------ +-- Test cases for pSwitchB and dpSwitchB +------------------------------------------------------------------------------ + +pswitch_inp1 = deltaEncode 0.1 [0.0, 0.5 ..] + +whenFstGE :: Ord a => a -> c -> SF (a, b) (Event c) +whenFstGE a c = arr fst >>> arr (>= a) >>> edge >>> arr (`tag` c) + +pswitch_t0 :: [[Double]] +pswitch_t0 = take 20 $ embed sf pswitch_inp1 + where + sf = + pSwitchB [] (whenFstGE 1.25 10.0) $ \sfs x -> + pSwitchB (integral:sfs) (whenFstGE 3.75 10.0) $ \sfs x -> + pSwitchB ((integral>>>arr(+x)):sfs)(whenFstGE 5.25 20.0) $ \sfs x-> + pSwitchB ((integral>>>arr(+x)):sfs)(whenFstGE 7.25 20.0) $ \sfs _-> + parB (take 2 sfs) + +pswitch_t0r = + [[], -- 0.0 + [], -- 0.5 + [], -- 1.0 + [0.0], -- 1.5 + [0.15], -- 2.0 + [0.35], -- 2.5 + [0.60], -- 3.0 + [0.90], -- 3.5 + [10.00, 1.25], -- 4.0 + [10.40, 1.65], -- 4.5 + [10.85, 2.10], -- 5.0 + [20.00, 11.35, 2.60], -- 5.5 + [20.55, 11.90, 3.15], -- 6.0 + [21.15, 12.50, 3.75], -- 6.5 + [21.80, 13.15, 4.40], -- 7.0 + [22.50, 13.85], -- 7.5 + [23.25, 14.60], -- 8.0 + [24.05, 15.40], -- 8.5 + [24.90, 16.25], -- 9.0 + [25.80, 17.15]] -- 9.5 + + +pswitch_t1 :: [[Double]] +pswitch_t1 = take 20 $ embed sf pswitch_inp1 + where + sf = + dpSwitchB [] (whenFstGE 1.25 10.0) $ \sfs x -> + dpSwitchB (integral:sfs) (whenFstGE 3.75 10.0) $ \sfs x -> + dpSwitchB ((integral>>>arr(+x)):sfs)(whenFstGE 5.25 20.0)$ \sfs x-> + dpSwitchB ((integral>>>arr(+x)):sfs)(whenFstGE 7.25 20.0)$ \sfs _-> + parB (take 2 sfs) + + +pswitch_t1r = + [[], -- 0.0 + [], -- 0.5 + [], -- 1.0 + [], -- 1.5 + [0.15], -- 2.0 + [0.35], -- 2.5 + [0.60], -- 3.0 + [0.90], -- 3.5 + [1.25], -- 4.0 + [10.40, 1.65], -- 4.5 + [10.85, 2.10], -- 5.0 + [11.35, 2.60], -- 5.5 + [20.55, 11.90, 3.15], -- 6.0 + [21.15, 12.50, 3.75], -- 6.5 + [21.80, 13.15, 4.40], -- 7.0 + [22.50, 13.85, 5.10], -- 7.5 + [23.25, 14.60], -- 8.0 + [24.05, 15.40], -- 8.5 + [24.90, 16.25], -- 9.0 + [25.80, 17.15]] -- 9.5 + + +pswitch_t2 :: [[Double]] +pswitch_t2 = take 20 $ embed sf pswitch_inp1 + where + sf = + pSwitchB [] (now 10.0) $ \sfs x -> + pSwitchB (integral:sfs) (whenFstGE 3.75 10.0) $ \sfs x -> + pSwitchB ((integral>>>arr(+x)):sfs)(whenFstGE 5.25 20.0) $ \sfs x-> + pSwitchB ((integral>>>arr(+x)):sfs)(now 20.0) $ \sfs _-> + parB (take 2 sfs) + +pswitch_t2r = + [[0.00], -- 0.0 + [0.00], -- 0.5 + [0.05], -- 1.0 + [0.15], -- 1.5 + [0.30], -- 2.0 + [0.50], -- 2.5 + [0.75], -- 3.0 + [1.05], -- 3.5 + [10.00, 1.40], -- 4.0 + [10.40, 1.80], -- 4.5 + [10.85, 2.25], -- 5.0 + [20.00, 11.35], -- 5.5 + [20.55, 11.90], -- 6.0 + [21.15, 12.50], -- 6.5 + [21.80, 13.15], -- 7.0 + [22.50, 13.85], -- 7.5 + [23.25, 14.60], -- 8.0 + [24.05, 15.40], -- 8.5 + [24.90, 16.25], -- 9.0 + [25.80, 17.15]] -- 9.5 + + +pswitch_t3 :: [[Double]] +pswitch_t3 = take 20 $ embed sf pswitch_inp1 + where + sf = + dpSwitchB [] (now 10.0) $ \sfs x -> + dpSwitchB (integral:sfs) (whenFstGE 3.75 10.0) $ \sfs x -> + dpSwitchB ((integral>>>arr(+x)):sfs)(whenFstGE 5.25 20.0)$ \sfs x-> + dpSwitchB ((integral>>>arr(+x)):sfs) (now 20.0) $ \sfs _-> + parB (take 2 sfs) + +pswitch_t3r = + [[], -- 0.0 + [0.00], -- 0.5 + [0.05], -- 1.0 + [0.15], -- 1.5 + [0.30], -- 2.0 + [0.50], -- 2.5 + [0.75], -- 3.0 + [1.05], -- 3.5 + [1.40], -- 4.0 + [10.40, 1.80], -- 4.5 + [10.85, 2.25], -- 5.0 + [11.35, 2.75], -- 5.5 + [20.55, 11.90], -- 6.0 + [21.15, 12.50], -- 6.5 + [21.80, 13.15], -- 7.0 + [22.50, 13.85], -- 7.5 + [23.25, 14.60], -- 8.0 + [24.05, 15.40], -- 8.5 + [24.90, 16.25], -- 9.0 + [25.80, 17.15]] -- 9.5 + + +-- Starts three "ramps" with different phase. As soon as one exceeds a +-- threshold, it's restarted, while the others are left alone. The +-- observaton of the output is done via the loop (rather than the directly +-- from the outputs of the signal functions in the collection), thus the +-- use of a delayed switch is essential. + +pswitch_ramp :: Double -> SF a Double +pswitch_ramp phase = constant 2.0 >>> integral >>> arr (+phase) + +-- We assume that only one signal function will reach the limit at a time. +pswitch_limit :: Double -> SF ((a, [Double]), b) (Event Int) +pswitch_limit x = arr (snd . fst) >>> arr (findIndex (>=x)) >>> edgeJust + +pswitch_t4 :: [[Double]] +pswitch_t4 = take 30 $ embed (loop sf) (deltaEncode 0.1 (repeat ())) + where + sf :: SF (a, [Double]) ([Double],[Double]) + sf = dpSwitchB [pswitch_ramp 0.0, pswitch_ramp 1.0, pswitch_ramp 2.0] + (pswitch_limit 2.99) + pswitch_t4rec + >>> arr dup + +pswitch_t4rec :: [SF (a, [Double]) Double] + -> Int + -> SF (a, [Double]) [Double] +pswitch_t4rec sfs n = + dpSwitchB (take n sfs ++ [pswitch_ramp 0.0] ++ drop (n+1) sfs) + (pswitch_limit 2.99) + pswitch_t4rec + +pswitch_t4r = + [[0.0, 1.0, 2.0], + [0.2, 1.2, 2.2], + [0.4, 1.4, 2.4], + [0.6, 1.6, 2.6], + [0.8, 1.8, 2.8], + [1.0, 2.0, 3.0], + [1.2, 2.2, 0.2], + [1.4, 2.4, 0.4], + [1.6, 2.6, 0.6], + [1.8, 2.8, 0.8], + [2.0, 3.0, 1.0], + [2.2, 0.2, 1.2], + [2.4, 0.4, 1.4], + [2.6, 0.6, 1.6], + [2.8, 0.8, 1.8], + [3.0, 1.0, 2.0], + [0.2, 1.2, 2.2], + [0.4, 1.4, 2.4], + [0.6, 1.6, 2.6], + [0.8, 1.8, 2.8], + [1.0, 2.0, 3.0], + [1.2, 2.2, 0.2], + [1.4, 2.4, 0.4], + [1.6, 2.6, 0.6], + [1.8, 2.8, 0.8], + [2.0, 3.0, 1.0], + [2.2, 0.2, 1.2], + [2.4, 0.4, 1.4], + [2.6, 0.6, 1.6], + [2.8, 0.8, 1.8]] + + +-- Variation of the test above, with direct observation (not via loop) and +-- immediate switch. + +-- We assume that only one signal function will reach the limit at a time. +pswitch_limit2 :: Double -> SF (a, [Double]) (Event Int) +pswitch_limit2 x = arr snd >>> arr (findIndex (>=x)) >>> edgeJust + +pswitch_t5 :: [([Double], Double)] +pswitch_t5 = take 30 $ embed (loop sf) (deltaEncode 0.1 (repeat ())) + where + sf :: SF (a, [Double]) (([Double], Double), [Double]) + sf = ((pSwitchB [pswitch_ramp 0.0, pswitch_ramp 1.0, pswitch_ramp 2.0] + (pswitch_limit2 2.99) + pswitch_t5rec) + &&& (arr snd >>> arr sum)) + >>> arr (\(xs, y) -> ((xs, y), xs)) + +pswitch_t5rec :: [SF (a, [Double]) Double] + -> Int + -> SF (a, [Double]) [Double] +pswitch_t5rec sfs n = + pSwitchB (take n sfs ++ [pswitch_ramp 0.0] ++ drop (n+1) sfs) + (pswitch_limit2 2.99) + pswitch_t5rec + +pswitch_t5r = + [([0.0, 1.0, 2.0], 3.0), + ([0.2, 1.2, 2.2], 3.6), + ([0.4, 1.4, 2.4], 4.2), + ([0.6, 1.6, 2.6], 4.8), + ([0.8, 1.8, 2.8], 5.4), + ([1.0, 2.0, 0.0], 3.0), + ([1.2, 2.2, 0.2], 3.6), + ([1.4, 2.4, 0.4], 4.2), + ([1.6, 2.6, 0.6], 4.8), + ([1.8, 2.8, 0.8], 5.4), + ([2.0, 0.0, 1.0], 3.0), + ([2.2, 0.2, 1.2], 3.6), + ([2.4, 0.4, 1.4], 4.2), + ([2.6, 0.6, 1.6], 4.8), + ([2.8, 0.8, 1.8], 5.4), + ([0.0, 1.0, 2.0], 3.0), + ([0.2, 1.2, 2.2], 3.6), + ([0.4, 1.4, 2.4], 4.2), + ([0.6, 1.6, 2.6], 4.8), + ([0.8, 1.8, 2.8], 5.4), + ([1.0, 2.0, 0.0], 3.0), + ([1.2, 2.2, 0.2], 3.6), + ([1.4, 2.4, 0.4], 4.2), + ([1.6, 2.6, 0.6], 4.8), + ([1.8, 2.8, 0.8], 5.4), + ([2.0, 0.0, 1.0], 3.0), + ([2.2, 0.2, 1.2], 3.6), + ([2.4, 0.4, 1.4], 4.2), + ([2.6, 0.6, 1.6], 4.8), + ([2.8, 0.8, 1.8], 5.4)] + + +pswitch_trs = + [ pswitch_t0 ~= pswitch_t0r, + pswitch_t1 ~= pswitch_t1r, + pswitch_t2 ~= pswitch_t2r, + pswitch_t3 ~= pswitch_t3r, + pswitch_t4 ~= pswitch_t4r, + pswitch_t5 ~= pswitch_t5r + ] + +pswitch_tr = and pswitch_trs + + +pswitch_st0 = testSFSpaceLeak 1000000 (loop sf) + where + sf :: SF (a, [Double]) ([Double],[Double]) + sf = dpSwitchB [pswitch_ramp 0.0, pswitch_ramp 1.0, pswitch_ramp 2.0] + (pswitch_limit 2.99) + pswitch_t4rec + >>> arr dup + +pswitch_st0r = [1.5,2.5,0.5] + + +pswitch_st1 = testSFSpaceLeak 1000000 (loop sf) + where + sf :: SF (a, [Double]) (([Double], Double), [Double]) + sf = ((pSwitchB [pswitch_ramp 0.0, pswitch_ramp 1.0, pswitch_ramp 2.0] + (pswitch_limit2 2.99) + pswitch_t5rec) + &&& (arr snd >>> arr sum)) + >>> arr (\(xs, y) -> ((xs, y), xs)) + +pswitch_st1r = ([1.5,2.5,0.5],4.5)
+ tests/AFRPTestsRPSwitch.hs view
@@ -0,0 +1,246 @@+{- $Id: AFRPTestsRPSwitch.hs,v 1.2 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTestsRPSwitch * +* Purpose: Test cases for rpSwitchB and drpSwitchB * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPTestsRPSwitch ( + rpswitch_tr, + rpswitch_trs, + rpswitch_st0, + rpswitch_st0r +) where + +import Maybe (fromJust) +import List (findIndex) + +import AFRP +import AFRPInternals (Event(NoEvent, Event)) + +import AFRPTestsCommon + +------------------------------------------------------------------------------ +-- Test cases for rpSwitchB and drpSwitchB +------------------------------------------------------------------------------ + +rpswitch_inp1 = (fromJust (head delta_inp), zip (repeat 1.0) (tail delta_inp)) + where + delta_inp = + [Just (1.0, NoEvent), Nothing, Nothing, + Just (2.0, Event (integral:)), Just (3.0, NoEvent), Nothing, + Just (4.0, NoEvent), Nothing, Nothing, + Just (5.0, Event ((integral >>> arr (+100.0)):)), + Just (6.0, NoEvent), Nothing, + Just (7.0, NoEvent), Nothing, Nothing, + Just (8.0, Event tail), Just (9.0, NoEvent), Nothing] + ++ repeat Nothing + + +-- This input contains exaples of "continuos switching", i.e. the same +-- switching event ocurring during a a few contiguous time steps. +-- It also starts with an immediate switch. +rpswitch_inp2 = (fromJust (head delta_inp), zip (repeat 1.0) (tail delta_inp)) + where + delta_inp = + [Just (1.0, Event (integral:)), + Just (1.0, NoEvent), Nothing, + Just (2.0, Event ((integral >>> arr(+100.0)):)), Nothing, Nothing, + Just (3.0, Event ((integral >>> arr(+200.0)):)), Nothing, Nothing, + Just (4.0, NoEvent), Nothing, Nothing, + Just (5.0, Event ((arr (*3)):)), + Just (5.0, NoEvent), Nothing, + Just (6.0, Event tail), Just (7.0, Event ((arr (*7)):)), + Just (8.0, Event (take 2)), + Just (9.0, NoEvent), Nothing] + ++ repeat Nothing + + +rpswitch_t0 :: [[Double]] +rpswitch_t0 = take 20 $ embed (rpSwitchB []) rpswitch_inp1 + +rpswitch_t0r = + [[], -- 0 s + [], -- 1 s + [], -- 2 s + [0.0], -- 3 s + [2.0], -- 4 s + [5.0], -- 5 s + [8.0], -- 6 s + [12.0], -- 7 s + [16.0], -- 8 s + [100.0, 20.0], -- 9 s + [105.0, 25.0], -- 10 s + [111.0, 31.0], -- 11 s + [117.0, 37.0], -- 12 s + [124.0, 44.0], -- 13 s + [131.0, 51.0], -- 14 s + [58.0], -- 15 s + [66.0], -- 16 s + [75.0], -- 17 s + [84.0], -- 18 s + [93.0]] -- 19 s + + +rpswitch_t1 :: [[Double]] +rpswitch_t1 = take 20 $ embed (drpSwitchB []) rpswitch_inp1 + +rpswitch_t1r = + [[], -- 0 s + [], -- 1 s + [], -- 2 s + [], -- 3 s + [2.0], -- 4 s + [5.0], -- 5 s + [8.0], -- 6 s + [12.0], -- 7 s + [16.0], -- 8 s + [20.0] , -- 9 s + [105.0, 25.0], -- 10 s + [111.0, 31.0], -- 11 s + [117.0, 37.0], -- 12 s + [124.0, 44.0], -- 13 s + [131.0, 51.0], -- 14 s + [138.0, 58.0], -- 15 s + [66.0], -- 16 s + [75.0], -- 17 s + [84.0], -- 18 s + [93.0]] -- 19 s + + +rpswitch_t2 :: [[Double]] +rpswitch_t2 = take 20 $ embed (rpSwitchB []) rpswitch_inp2 + +rpswitch_t2r = + [[0.0], -- 0 s + [1.0], -- 1 s + [2.0], -- 2 s + [100.0, 3.0], -- 3 s + [100.0, 102.0, 5.0], -- 4 s + [100.0, 102.0, 104.0, 7.0], -- 5 s + [200.0, 102.0, 104.0, 106.0, 9.0], -- 6 s + [200.0, 203.0, 105.0, 107.0, 109.0, 12.0], -- 7 s + [200.0, 203.0, 206.0, 108.0, 110.0, 112.0, 15.0], -- 8 s + [203.0, 206.0, 209.0, 111.0, 113.0, 115.0, 18.0], -- 9 s + [207.0, 210.0, 213.0, 115.0, 117.0, 119.0, 22.0], -- 10 s + [211.0, 214.0, 217.0, 119.0, 121.0, 123.0, 26.0], -- 11 s + [15.0, 215.0, 218.0, 221.0, 123.0, 125.0, 127.0, 30.0], -- 12 s + [15.0, 220.0, 223.0, 226.0, 128.0, 130.0, 132.0, 35.0], -- 13 s + [15.0, 225.0, 228.0, 231.0, 133.0, 135.0, 137.0, 40.0], -- 14 s + [230.0, 233.0, 236.0, 138.0, 140.0, 142.0, 45.0], -- 15 s + [49.0, 236.0, 239.0, 242.0, 144.0, 146.0, 148.0, 51.0], -- 16 s + [56.0, 243.0], -- 17 s + [63.0, 251.0], -- 18 s + [63.0, 260.0]] -- 19 s + + +rpswitch_t3 :: [[Double]] +rpswitch_t3 = take 20 $ embed (drpSwitchB []) rpswitch_inp2 + +rpswitch_t3r = + [[], -- 0 s + [1.0], -- 1 s + [2.0], -- 2 s + [3.0], -- 3 s + [102.0, 5.0], -- 4 s + [102.0, 104.0, 7.0], -- 5 s + [102.0, 104.0, 106.0, 9.0], -- 6 s + [203.0, 105.0, 107.0, 109.0, 12.0], -- 7 s + [203.0, 206.0, 108.0, 110.0, 112.0, 15.0], -- 8 s + [203.0, 206.0, 209.0, 111.0, 113.0, 115.0, 18.0], -- 9 s + [207.0, 210.0, 213.0, 115.0, 117.0, 119.0, 22.0], -- 10 s + [211.0, 214.0, 217.0, 119.0, 121.0, 123.0, 26.0], -- 11 s + [215.0, 218.0, 221.0, 123.0, 125.0, 127.0, 30.0], -- 12 s + [15.0, 220.0, 223.0, 226.0, 128.0, 130.0, 132.0, 35.0], -- 13 s + [15.0, 225.0, 228.0, 231.0, 133.0, 135.0, 137.0, 40.0], -- 14 s + [18.0, 230.0, 233.0, 236.0, 138.0, 140.0, 142.0, 45.0], -- 15 s + [236.0, 239.0, 242.0, 144.0, 146.0, 148.0, 51.0], -- 16 s + [56.0, 243.0, 246.0, 249.0, 151.0, 153.0, 155.0, 58.0], -- 17 s + [63.0, 251.0], -- 18 s + [63.0, 260.0]] -- 19 s + + +-- Starts three "ramps" with different phase. As soon as one exceeds a +-- threshold, it's restarted, while the others are left alone. The observaton +-- of the output is done via a loop, thus the use of a delayed switch is +-- essential. + +rpswitch_ramp :: Double -> SF a Double +rpswitch_ramp phase = constant 2.0 >>> integral >>> arr (+phase) + +-- We assume that only one signal function will reach the limit at a time. +rpswitch_limit :: Double -> SF [Double] (Event ([SF a Double]->[SF a Double])) +rpswitch_limit x = arr (findIndex (>=x)) >>> edgeJust >>> arr (fmap restart) + where + restart n = \sfs -> take n sfs ++ [rpswitch_ramp 0.0] ++ drop (n+1) sfs + +rpswitch_t4 :: [[Double]] +rpswitch_t4 = take 30 $ embed (loop sf) (deltaEncode 0.1 (repeat ())) + where + sf :: SF (a, [Double]) ([Double],[Double]) + sf = (second (rpswitch_limit 2.99) + >>> drpSwitchB [rpswitch_ramp 0.0, + rpswitch_ramp 1.0, + rpswitch_ramp 2.0]) + >>> arr dup + +rpswitch_t4r = + [[0.0, 1.0, 2.0], + [0.2, 1.2, 2.2], + [0.4, 1.4, 2.4], + [0.6, 1.6, 2.6], + [0.8, 1.8, 2.8], + [1.0, 2.0, 3.0], + [1.2, 2.2, 0.2], + [1.4, 2.4, 0.4], + [1.6, 2.6, 0.6], + [1.8, 2.8, 0.8], + [2.0, 3.0, 1.0], + [2.2, 0.2, 1.2], + [2.4, 0.4, 1.4], + [2.6, 0.6, 1.6], + [2.8, 0.8, 1.8], + [3.0, 1.0, 2.0], + [0.2, 1.2, 2.2], + [0.4, 1.4, 2.4], + [0.6, 1.6, 2.6], + [0.8, 1.8, 2.8], + [1.0, 2.0, 3.0], + [1.2, 2.2, 0.2], + [1.4, 2.4, 0.4], + [1.6, 2.6, 0.6], + [1.8, 2.8, 0.8], + [2.0, 3.0, 1.0], + [2.2, 0.2, 1.2], + [2.4, 0.4, 1.4], + [2.6, 0.6, 1.6], + [2.8, 0.8, 1.8]] + + +rpswitch_trs = + [ rpswitch_t0 ~= rpswitch_t0r, + rpswitch_t1 ~= rpswitch_t1r, + rpswitch_t2 ~= rpswitch_t2r, + rpswitch_t3 ~= rpswitch_t3r, + rpswitch_t4 ~= rpswitch_t4r + ] + +rpswitch_tr = and rpswitch_trs + + +rpswitch_st0 = testSFSpaceLeak 1000000 (loop sf) + where + sf :: SF (a, [Double]) ([Double],[Double]) + sf = (second (rpswitch_limit 2.99) + >>> drpSwitchB [rpswitch_ramp 0.0, + rpswitch_ramp 1.0, + rpswitch_ramp 2.0]) + >>> arr dup + +rpswitch_st0r = [1.5,2.5,0.5]
+ tests/AFRPTestsRSwitch.hs view
@@ -0,0 +1,144 @@+{- $Id: AFRPTestsRSwitch.hs,v 1.2 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTestsRSwitch * +* Purpose: Test cases for rSwitch and drSwitch * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPTestsRSwitch ( + rswitch_tr, + rswitch_trs, + rswitch_st0, + rswitch_st0r +) where + +import Maybe (fromJust) + +import AFRP +import AFRPInternals (Event(NoEvent, Event)) + +import AFRPTestsCommon + +------------------------------------------------------------------------------ +-- Test cases for rSwitch and drSwitch +------------------------------------------------------------------------------ + +rswitch_inp1 = (fromJust (head delta_inp), zip (repeat 1.0) (tail delta_inp)) + where + delta_inp = + [Just (1.0, NoEvent), Nothing, Nothing, + Just (2.0, Event (arr (*3))), Just (3.0, NoEvent), Nothing, + Just (4.0, NoEvent), Nothing, Nothing, + Just (5.0, Event integral), + Just (6.0, NoEvent), Nothing, + Just (7.0, NoEvent), Nothing, Nothing, + Just (8.0, Event (arr (*7))), Just (9.0, NoEvent), Nothing] + ++ repeat Nothing + + +-- This input contains exaples of "continuos switching", i.e. the same +-- switching event ocurring during a a few contiguous time steps. +-- It also starts with an immediate switch. +rswitch_inp2 = (fromJust (head delta_inp), zip (repeat 1.0) (tail delta_inp)) + where + delta_inp = + [Just (1.0, Event integral), + Just (1.0, NoEvent), Nothing, + Just (2.0, Event (arr (*2))), Nothing, Nothing, + Just (3.0, Event integral), Nothing, Nothing, + Just (4.0, NoEvent), Nothing, Nothing, + Just (5.0, Event integral), + Just (5.0, NoEvent), Nothing, + Just (6.0, Event (arr (*3))), Just (7.0, Event (arr (*4))), + Just (8.0, Event integral), + Just (9.0, NoEvent), Nothing] + ++ repeat Nothing + + +rswitch_t0 = take 20 $ embed (rSwitch (arr (+3))) rswitch_inp1 + +-- Integration using rectangle rule assumed. +rswitch_t0r :: [Double] +rswitch_t0r = + [4.0, 4.0, 4.0, 6.0, 9.0, + 9.0, 12.0, 12.0, 12.0, 0.0, + 5.0, 11.0, 17.0, 24.0, 31.0, + 56.0, 63.0, 63.0, 63.0, 63.0] + + +rswitch_t1 = take 20 $ embed (rSwitch integral) rswitch_inp1 + +-- Integration using rectangle rule assumed. +rswitch_t1r :: [Double] +rswitch_t1r = + [0.0, 1.0, 2.0, 6.0, 9.0, + 9.0, 12.0, 12.0, 12.0, 0.0, + 5.0, 11.0, 17.0, 24.0, 31.0, + 56.0, 63.0, 63.0, 63.0, 63.0] + +rswitch_t2 = take 20 $ embed (rSwitch (arr (+100))) rswitch_inp2 + +-- Integration using rectangle rule assumed. +rswitch_t2r :: [Double] +rswitch_t2r = + [0.0, 1.0, 2.0, 4.0, 4.0, + 4.0, 0.0, 0.0, 0.0, 3.0, + 7.0, 11.0, 0.0, 5.0, 10.0, + 18.0, 28.0, 0.0, 8.0, 17.0] + + +rswitch_t3 = take 20 $ embed (drSwitch (arr (+100))) rswitch_inp2 + +-- Integration using rectangle rule assumed. +rswitch_t3r :: [Double] +rswitch_t3r = + [101.0, 1.0, 2.0, 3.0, 4.0, + 4.0, 6.0, 3.0, 3.0, 3.0, + 7.0, 11.0, 15.0, 5.0, 10.0, + 15.0, 21.0, 32.0, 8.0, 17.0] + + +rswitch_sawTooth :: SF a Double +rswitch_sawTooth = + loop (second (arr (>=5.0) + >>> edge + >>> arr (`tag` ramp)) + >>> drSwitch ramp + >>> arr dup) + where + ramp :: SF a Double + ramp = constant 1.0 >>> integral + +rswitch_inp3 = deltaEncode 0.5 (repeat 0.0) + +rswitch_t4 = take 40 $ embed rswitch_sawTooth rswitch_inp3 + +rswitch_t4r = + [0.0, 0.5, 1.0, 1.5, 2.0, + 2.5, 3.0, 3.5, 4.0, 4.5, + 5.0, 0.5, 1.0, 1.5, 2.0, + 2.5, 3.0, 3.5, 4.0, 4.5, + 5.0, 0.5, 1.0, 1.5, 2.0, + 2.5, 3.0, 3.5, 4.0, 4.5, + 5.0, 0.5, 1.0, 1.5, 2.0, + 2.5, 3.0, 3.5, 4.0, 4.5] + +rswitch_trs = + [ rswitch_t0 ~= rswitch_t0r, + rswitch_t1 ~= rswitch_t1r, + rswitch_t2 ~= rswitch_t2r, + rswitch_t3 ~= rswitch_t3r, + rswitch_t4 ~= rswitch_t4r + ] + +rswitch_tr = and rswitch_trs + + +rswitch_st0 = testSFSpaceLeak 2000000 rswitch_sawTooth +rswitch_st0r = 4.75
+ tests/AFRPTestsReact.hs view
@@ -0,0 +1,70 @@+{- $Id: AFRPTestsReact.hs,v 1.2 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTestsReact * +* Purpose: Test cases for reactimation * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPTestsReact (react_tr, react_trs) where + +import Data.IORef (IORef, newIORef, writeIORef, readIORef) +import System.IO.Unsafe (unsafePerformIO) + +import AFRP + +import AFRPTestsCommon + +------------------------------------------------------------------------------ +-- Test cases for reactimation +------------------------------------------------------------------------------ + +react_t0 :: [(Double, Double)] +react_t0 = unsafePerformIO $ do + countr <- newIORef undefined + inputr <- newIORef undefined + outputsr <- newIORef [] + let init = do + writeIORef countr 1 + let input0 = 0.0 + writeIORef inputr input0 + return input0 + sense _ = do + count <- readIORef countr + if count >= 5 then do + writeIORef countr 1 + input <- readIORef inputr + let input' = input + 0.5 + writeIORef inputr input' + return (0.1, Just input') + else do + writeIORef countr (count + 1) + return (0.1, Nothing) + actuate _ output = do + outputs <- readIORef outputsr + writeIORef outputsr (output : outputs) + input <- readIORef inputr + return (input > 5.0) + reactimate init sense actuate (arr dup >>> second integral) + outputs <- readIORef outputsr + return (take 25 (reverse outputs)) + + +react_t0r :: [(Double, Double)] +react_t0r = [ + (0.0,0.00), (0.0,0.00), (0.0,0.00), (0.0,0.00), (0.0,0.00), + (0.5,0.00), (0.5,0.05), (0.5,0.10), (0.5,0.15), (0.5,0.20), + (1.0,0.25), (1.0,0.35), (1.0,0.45), (1.0,0.55), (1.0,0.65), + (1.5,0.75), (1.5,0.90), (1.5,1.05), (1.5,1.20), (1.5,1.35), + (2.0,1.50), (2.0,1.70), (2.0,1.90), (2.0,2.10), (2.0,2.30)] + + +react_trs = [ react_t0 ~= react_t0r ] + + +react_tr = and react_trs
+ tests/AFRPTestsSwitch.hs view
@@ -0,0 +1,214 @@+{- $Id: AFRPTestsSwitch.hs,v 1.2 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTestsSwitch * +* Purpose: Test cases for switch * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPTestsSwitch (switch_tr, switch_trs) where + +import AFRP +import AFRPInternals (Event(NoEvent, Event)) +import AFRPUtilities (snap) + +import AFRPTestsCommon + +------------------------------------------------------------------------------ +-- Test cases for switch and dSwitch +------------------------------------------------------------------------------ + +switch_inp1 = deltaEncode 1.0 $ + [1.0, 1.0, 1.0, + 2.0, + 3.0, 3.0, + 4.0, 4.0, 4.0, + 5.0, + 6.0, 6.0, + 7.0, 7.0, 7.0, + 8.0] + ++ repeat 9.0 + +switch_t0 = take 18 $ + embed (switch switch_t0a $ \x -> + switch (switch_t0b x) $ \x -> + switch (switch_t0c x) $ \x -> + switch (switch_t0c x) $ \x -> + switch (switch_t0d x) $ \x -> + switch (switch_t0e x) $ \x -> + switch (switch_t0e x) $ + switch_t0final) + switch_inp1 + +switch_t0a :: SF Double (Double, Event Int) +switch_t0a = localTime + >>> arr dup + >>> second (arr (>= 3.0) >>> edge >>> arr (`tag` 17)) + +switch_t0b :: Int -> SF Double (Double, Event Int) +switch_t0b x = localTime + >>> arr dup + >>> second (arr (>= 3.0) >>> edge >>> arr (`tag` (23 + x))) + +-- This should raise an event IMMEDIATELY: no time should pass. +switch_t0c :: Num b => b -> SF a (a, Event b) +switch_t0c x = arr dup >>> second (now (x + 1)) + +switch_t0d x = (arr (+ (fromIntegral x))) &&& (arr (>= 7.0) >>> edge) + +-- This should raise an event IMMEDIATELY: no time should pass. +switch_t0e :: b -> SF a (a, Event a) +switch_t0e _ = arr dup >>> second snap + +switch_t0final :: Double -> SF Double Double +switch_t0final x = arr (+x) + +switch_t0r = + [0.0, 1.0, 2.0, -- switch_t0a + 0.0, 1.0, 2.0, -- switch_t0b + 46.0, 46.0, 46.0, 47.0, 48.0, 48.0, -- switch_t0d + 14.0, 14.0, 14.0, 15.0, 16.0, 16.0 -- switch_t0final + ] + + +switch_t1 = take 32 $ embed (switch_t1rec 42.0) switch_inp1 + +-- Outputs current input, local time, and the value of the initializing +-- argument until some time has passed (determined by integrating a constant), +-- at which point an event occurs. +switch_t1a :: Double -> SF Double ((Double,Double,Double), Event ()) +switch_t1a x = (arr dup >>> second localTime >>> arr (\(a,t) -> (a,t,x))) + &&& (constant 0.5 + >>> integral + >>> (arr (>= (2.0 :: Double)) -- Used to work with no sig. + >>> edge)) + +-- This should raise an event IMMEDIATELY: no time should pass. +switch_t1b :: b -> SF a ((Double,Double,Double), Event a) +switch_t1b _ = constant (-999.0,-999.0,-999.0) &&& snap + +switch_t1rec :: Double -> SF Double (Double,Double,Double) +switch_t1rec x = + switch (switch_t1a x) $ \x -> + switch (switch_t1b x) $ \x -> + switch (switch_t1b x) $ + switch_t1rec + +switch_t1r = + [(1.0,0.0,42.0), (1.0,1.0,42.0), (1.0,2.0,42.0), (2.0,3.0,42.0), + (3.0,0.0,3.0), (3.0,1.0,3.0), (4.0,2.0,3.0), (4.0,3.0,3.0), + (4.0,0.0,4.0), (5.0,1.0,4.0), (6.0,2.0,4.0), (6.0,3.0,4.0), + (7.0,0.0,7.0), (7.0,1.0,7.0), (7.0,2.0,7.0), (8.0,3.0,7.0), + (9.0,0.0,9.0), (9.0,1.0,9.0), (9.0,2.0,9.0), (9.0,3.0,9.0), + (9.0,0.0,9.0), (9.0,1.0,9.0), (9.0,2.0,9.0), (9.0,3.0,9.0), + (9.0,0.0,9.0), (9.0,1.0,9.0), (9.0,2.0,9.0), (9.0,3.0,9.0), + (9.0,0.0,9.0), (9.0,1.0,9.0), (9.0,2.0,9.0), (9.0,3.0,9.0)] + +switch_t2 = take 18 $ + embed (dSwitch switch_t0a $ \x -> + dSwitch (switch_t0b x) $ \x -> + dSwitch (switch_t0c x) $ \x -> + dSwitch (switch_t0c x) $ \x -> + dSwitch (switch_t0d x) $ \x -> + dSwitch (switch_t0e x) $ \x -> + dSwitch (switch_t0e x) $ + switch_t0final) + switch_inp1 + +switch_t2r = + [0.0, 1.0, 2.0, -- switch_t0a + 3.0, 1.0, 2.0, -- switch_t0b + 3.0, 46.0, 46.0, 47.0, 48.0, 48.0, -- switch_t0d + 49.0, 14.0, 14.0, 15.0, 16.0, 16.0 -- switch_t0final + ] + + +switch_t3 = take 32 $ embed (switch_t3rec 42.0) switch_inp1 + +switch_t3rec :: Double -> SF Double (Double,Double,Double) +switch_t3rec x = + dSwitch (switch_t1a x) $ \x -> + dSwitch (switch_t1b x) $ \x -> + dSwitch (switch_t1b x) $ + switch_t3rec + +switch_t3r = + [(1.0,0.0,42.0), (1.0,1.0,42.0), (1.0,2.0,42.0), (2.0,3.0,42.0), + (3.0,4.0,42.0), (3.0,1.0,3.0), (4.0,2.0,3.0), (4.0,3.0,3.0), + (4.0,4.0,3.0), (5.0,1.0,4.0), (6.0,2.0,4.0), (6.0,3.0,4.0), + (7.0,4.0,4.0), (7.0,1.0,7.0), (7.0,2.0,7.0), (8.0,3.0,7.0), + (9.0,4.0,7.0), (9.0,1.0,9.0), (9.0,2.0,9.0), (9.0,3.0,9.0), + (9.0,4.0,9.0), (9.0,1.0,9.0), (9.0,2.0,9.0), (9.0,3.0,9.0), + (9.0,4.0,9.0), (9.0,1.0,9.0), (9.0,2.0,9.0), (9.0,3.0,9.0), + (9.0,4.0,9.0), (9.0,1.0,9.0), (9.0,2.0,9.0), (9.0,3.0,9.0)] + + +-- The correct strictness properties of dSwitch are crucial here. +-- switch does not work. +switch_t4 = take 25 $ + embed (loop $ + dSwitch switch_t4a $ \_ -> + dSwitch switch_t4a $ \_ -> + dSwitch switch_t4a $ \_ -> + switch_t4final + ) + (deltaEncode 1.0 (repeat ())) + + +switch_t4a :: SF (a, Double) ((Double, Double), Event ()) +switch_t4a = (constant 1.0 >>> integral >>> arr dup) + &&& (arr (\ (_, x) -> x >= 5.0) >>> edge) + +switch_t4final :: SF (a, Double) (Double, Double) +switch_t4final = constant 0.1 >>> integral >>> arr dup + +switch_t4r = + [0.0, 1.0, 2.0, 3.0, 4.0, -- switch_t4a + 5.0, 1.0, 2.0, 3.0, 4.0, -- switch_t4a + 5.0, 1.0, 2.0, 3.0, 4.0, -- switch_t4a + 5.0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9 -- switch_t4final + ] + + +impulseIntegral2 :: VectorSpace a s => SF (a, Event a) a +impulseIntegral2 = + switch (first integral >>> arr (\(a, ea) -> (a, fmap (^+^a) ea))) + impulseIntegral2' + where + impulseIntegral2' :: VectorSpace a s => a -> SF (a, Event a) a + impulseIntegral2' a = + switch ((integral >>> arr (^+^a)) *** notYet + >>> arr (\(a, ea) -> (a, fmap (^+^a) ea))) + impulseIntegral2' + +switch_t5 :: [Double] +switch_t5 = take 50 $ embed impulseIntegral2 + (deltaEncode 0.1 (zip (repeat 1.0) evSeq)) + where + evSeq = replicate 9 NoEvent ++ [Event 10.0] + ++ replicate 9 NoEvent ++ [Event (-10.0)] + ++ evSeq + +switch_t5r = + [ 0.0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 10.9, + 11.0, 11.1, 11.2, 11.3, 11.4, 11.5, 11.6, 11.7, 11.8, 1.9, + 2.0, 2.1, 2.2, 2.3, 2.4, 2.5, 2.6, 2.7, 2.8, 12.9, + 13.0, 13.1, 13.2, 13.3, 13.4, 13.5, 13.6, 13.7, 13.8, 3.9, + 4.0, 4.1, 4.2, 4.3, 4.4, 4.5, 4.6, 4.7, 4.8, 14.9] + + +switch_trs = + [ switch_t0 ~= switch_t0r, + switch_t1 ~= switch_t1r, + switch_t2 ~= switch_t2r, + switch_t3 ~= switch_t3r, + switch_t4 ~= switch_t4r, + switch_t5 ~= switch_t5r + ] + +switch_tr = and switch_trs
+ tests/AFRPTestsTask.hs view
@@ -0,0 +1,217 @@+{- $Id: AFRPTestsTask.hs,v 1.2 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTestsTask * +* Purpose: Test cases for tasks (AFRPTask) * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +-- Very rudimentary testing of AFRPTask. + +module AFRPTestsTask (task_tr, task_trs) where + +import AFRP +import AFRPTask + +import AFRPTestsCommon + +------------------------------------------------------------------------------ +-- Test cases for tasks (AFRPTask) +------------------------------------------------------------------------------ + +task_t0 = testSF1 (runTask (do + mkTask (localTime + &&&(localTime >>> arr (>=5.0) >>> edge)) + x <- snapT + return (x * 2.0)) + ) + +task_t0r = + [Left 0.0, Left 0.25, Left 0.5, Left 0.75, Left 1.0, + Left 1.25, Left 1.5, Left 1.75, Left 2.0, Left 2.25, + Left 2.5, Left 2.75, Left 3.0, Left 3.25, Left 3.5, + Left 3.75, Left 4.0, Left 4.25, Left 4.5, Left 4.75, + Right 40.0, Right 40.0, Right 40.0, Right 40.0, Right 40.0] + + +task_t1 = testSF1 (runTask (do + mkTask (localTime + &&& (localTime>>>arr (>=5.0) >>> edge)) + return () -- No time should pass! + return () -- No Time should pass! + snapT -- No time should pass! + snapT -- No time should pass! + x <- snapT + return (x * 2.0)) + ) + + +task_t2 = testSF1 (runTask (do + sleepT 1.51 42.0 + x <- snapT + y <- snapT + sleepT 1.51 x + if x == y then + sleepT 1.51 (x * 2) + else + sleepT 0.51 (x * 3) + ) + ) + +task_t2r = + [Left 42.0, Left 42.0, Left 42.0, Left 42.0, -- 0.0 s + Left 42.0, Left 42.0, Left 42.0, Left 7.0, -- 1.0 s + Left 7.0, Left 7.0, Left 7.0, Left 7.0, -- 2.0 s + Left 7.0, Left 7.0, Left 14.0, Left 14.0, -- 3.0 s + Left 14.0, Left 14.0, Left 14.0, Left 14.0, -- 4.0 s + Left 14.0, Right (), Right (), Right (), -- 5.0 s + Right ()] + + +task_t3 = testSF1 (runTask (do + c <- sawtooth `timeOut` 3.49 + case c of + Nothing -> sleepT 1.51 (-10.0) + Just x -> sleepT 1.51 x + ) + ) + where + sawtooth = + forEver ((mkTask (constant 2.0 >>> integral &&& never)) + `timeOut` 1.5) + +task_t3r :: [Either Double ()] +task_t3r = + [Left 0.0, Left 0.5, Left 1.0, Left 1.5, -- 0.0 s + Left 2.0, Left 2.5, Left 0.0, Left 0.5, -- 1.0 s + Left 1.0, Left 1.5, Left 2.0, Left 2.5, -- 2.0 s + Left 0.0, Left 0.5, Left (-10.0), Left (-10.0), -- 3.0 s + Left (-10.0), Left (-10.0), Left (-10.0), Left (-10.0), -- 4.0 s + Left (-10.0), Right (), Right (), Right (), -- 5.0 s + Right ()] + + +task_t4 = testSF1 (runTask (do + c <- sawtooth `timeOut` 3.49 + case c of + Nothing -> sleepT 1.51 (-10.0) + Just x -> sleepT 1.51 x + ) + ) + where + sawtooth = do + for 1 (+1) (<=2) + ((mkTask (constant 2.0 >>> integral &&& never)) + `timeOut` 1.5) + return (-42.0) + +task_t4r :: [Either Double ()] +task_t4r = + [Left 0.0, Left 0.5, Left 1.0, Left 1.5, -- 0.0 s + Left 2.0, Left 2.5, Left 0.0, Left 0.5, -- 1.0 s + Left 1.0, Left 1.5, Left 2.0, Left 2.5, -- 2.0 s + Left (-42.0), Left (-42.0), Left (-42.0), Left (-42.0), -- 3.0 s + Left (-42.0), Left (-42.0), Left (-42.0), Right (), -- 4.0 s + Right (), Right (), Right (), Right (), -- 5.0 s + Right ()] + + +task_t5 = testSF1 (runTask (do + x<-(sawtoothCycle>>snapT) `repeatUntil` (>=20.0) + y<-snapT + return (x == y) + ) + ) + where + sawtoothCycle = mkTask (constant 2.0 >>> integral &&& after 1.5 ()) + +task_t5r :: [Either Double Bool] +task_t5r = + [Left 0.0, Left 0.5, Left 1.0, Left 1.5, -- 0.0 s, 0 - 3 + Left 2.0, Left 2.5, Left 0.0, Left 0.5, -- 1.0 s, 4 - 7 + Left 1.0, Left 1.5, Left 2.0, Left 2.5, -- 2.0 s, 8 - 11 + Left 0.0, Left 0.5, Left 1.0, Left 1.5, -- 3.0 s, 12 - 15 + Left 2.0, Left 2.5, Left 0.0, Left 0.5, -- 4.0 s, 16 - 19, + Left 1.0, Left 1.5, Left 2.0, Left 2.5, -- 5.0 s, 20 - 23 + Right True] + + +task_t6 = testSF1 $ runTask $ + do + x <- ((sawtoothCycle >> snapT) `repeatUntil` (>=20.0)) + `abortWhen` (localTime >>> arr (>=3.51) >>> edge) + y <- snapT + return (x,y) + where + sawtoothCycle = mkTask (constant 2.0 >>> integral &&& after 1.5 ()) + +task_t6r :: [Either Double (Either Double (), Double)] +task_t6r = + [Left 0.0, Left 0.5, Left 1.0, Left 1.5, -- 0.0 s, 0 - 3 + Left 2.0, Left 2.5, Left 0.0, Left 0.5, -- 1.0 s, 4 - 7 + Left 1.0, Left 1.5, Left 2.0, Left 2.5, -- 2.0 s, 8 - 11 + Left 0.0, Left 0.5, Left 1.0, Right (Right (),15.0), -- 3.0 s, 12 - 15 + Right (Right (),15.0), Right (Right (),15.0), -- 4.0 s, 16, 17 + Right (Right (),15.0), Right (Right (),15.0), -- 4.5 s, 18, 19 + Right (Right (),15.0), Right (Right (),15.0), -- 5.0 s, 20, 21 + Right (Right (),15.0), Right (Right (),15.0), -- 5.5 s, 22, 23 + Right (Right (),15.0)] + +task_t7 = testSF1 $ runTask $ + do + x <- ((sawtoothCycle >> snapT) `repeatUntil` (>=20.0)) + `abortWhen` (localTime >>> arr (>=5.75) >>> edge) + y <- snapT + return (x,y) + where + sawtoothCycle = mkTask (constant 2.0 >>> integral &&& after 1.5 ()) + +task_t7r :: [Either Double (Either Double (), Double)] +task_t7r = + [Left 0.0, Left 0.5, Left 1.0, Left 1.5, -- 0.0 s, 0 - 3 + Left 2.0, Left 2.5, Left 0.0, Left 0.5, -- 1.0 s, 4 - 7 + Left 1.0, Left 1.5, Left 2.0, Left 2.5, -- 2.0 s, 8 - 11 + Left 0.0, Left 0.5, Left 1.0, Left 1.5, -- 3.0 s, 12 - 15 + Left 2.0, Left 2.5, Left 0.0, Left 0.5, -- 4.0 s, 16 - 19 + Left 1.0, Left 1.5, Left 2.0, Right (Right (),23.0), -- 5.0 s, 20 - 23 + Right (Right (),23.0)] + +task_t8 = testSF1 $ runTask $ + do + x <- ((sawtoothCycle >> snapT) `repeatUntil` (>=20.0)) + `abortWhen` (localTime >>> arr (>=5.76) >>> edge) + y <- snapT + return (x,y) + where + sawtoothCycle = mkTask (constant 2.0 >>> integral &&& after 1.5 ()) + +-- Since abortWhen uses lMergeEvent, the terminating event of the task +-- gets priority over the aborting event. +task_t8r :: [Either Double (Either Double (), Double)] +task_t8r = + [Left 0.0, Left 0.5, Left 1.0, Left 1.5, -- 0.0 s, 0 - 3 + Left 2.0, Left 2.5, Left 0.0, Left 0.5, -- 1.0 s, 4 - 7 + Left 1.0, Left 1.5, Left 2.0, Left 2.5, -- 2.0 s, 8 - 11 + Left 0.0, Left 0.5, Left 1.0, Left 1.5, -- 3.0 s, 12 - 15 + Left 2.0, Left 2.5, Left 0.0, Left 0.5, -- 4.0 s, 16 - 19 + Left 1.0, Left 1.5, Left 2.0, Left 2.5, -- 5.0 s, 20 - 23 + Right (Left 24.0,24.0)] + +task_trs = + [ task_t0 ~= task_t0r, + task_t1 ~= task_t0r, -- Intentionally! task_t0 = task_t1! + task_t2 ~= task_t2r, + task_t3 ~= task_t3r, + task_t4 ~= task_t4r, + task_t5 ~= task_t5r, + task_t6 ~= task_t6r, + task_t7 ~= task_t7r, + task_t8 ~= task_t8r + ] + +task_tr = and task_trs
+ tests/AFRPTestsUtils.hs view
@@ -0,0 +1,276 @@+{- $Id: AFRPTestsUtils.hs,v 1.2 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTestsUtils * +* Purpose: Test cases for utilities (AFRPUtilities) * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +-- Not really intended to test all definitions in the utilities module. + +module AFRPTestsUtils (utils_tr, utils_trs) where + +import AFRP +import AFRPInternals (Event(NoEvent, Event)) +import AFRPUtilities + +import AFRPTestsCommon + +------------------------------------------------------------------------------ +-- Test cases for utilities (AFRPUtils) +------------------------------------------------------------------------------ + +-- Should re-order these test cases to reflect the order in AFRPUtils +-- at some point. + +utils_inp1 = deltaEncode 1.0 $ + [NoEvent, NoEvent, Event 1.0, NoEvent, + Event 2.0, NoEvent, NoEvent, NoEvent, + Event 3.0, Event 4.0, Event 4.0, NoEvent, + Event 0.0, NoEvent, NoEvent, NoEvent] + ++ repeat NoEvent + + +utils_inp2 = deltaEncode 1.0 $ + [Event 1.0, NoEvent, NoEvent, NoEvent, + Event 2.0, NoEvent, NoEvent, NoEvent, + Event 3.0, Event 4.0, Event 4.0, NoEvent, + Event 0.0, NoEvent, NoEvent, NoEvent] + ++ repeat NoEvent + + +utils_t0 :: [Double] +utils_t0 = take 16 $ embed (dHold 99.99) utils_inp1 + +utils_t0r = + [99.99, 99.99, 99.99, 1.0, + 1.0, 2.0, 2.0, 2.0, + 2.0, 3.0, 4.0, 4.0, + 4.0, 0.0, 0.0, 0.0] + +utils_t1 :: [Double] +utils_t1 = take 16 $ embed (dHold 99.99) utils_inp2 + +utils_t1r = + [99.99, 1.0, 1.0, 1.0, + 1.0, 2.0, 2.0, 2.0, + 2.0, 3.0, 4.0, 4.0, + 4.0, 0.0, 0.0, 0.0] + + +utils_inp3 = deltaEncode 1.0 $ + [Nothing, Nothing, Just 1.0, Just 2.0, Just 3.0, + Just 4.0, Nothing, Nothing, Nothing, Just 3.0, + Just 2.0, Nothing, Just 1.0, Just 0.0, Just 1.0, + Just 2.0, Just 3.0, Nothing, Nothing, Just 4.0] + ++ repeat Nothing + +utils_inp4 = deltaEncode 1.0 $ + [Just 0.0, Nothing, Just 1.0, Just 2.0, Just 3.0, + Just 4.0, Nothing, Nothing, Nothing, Just 3.0, + Just 2.0, Nothing, Just 1.0, Just 0.0, Just 1.0, + Just 2.0, Just 3.0, Nothing, Nothing, Just 4.0] + ++ repeat Nothing + + +utils_t2 :: [Double] +utils_t2 = take 25 $ embed (dTrackAndHold 99.99) utils_inp3 + +utils_t2r = + [99.99, 99.99, 99.99, 1.0, 2.0, + 3.0, 4.0, 4.0, 4.0, 4.0, + 3.0, 2.0, 2.0, 1.0, 0.0, + 1.0, 2.0, 3.0, 3.0, 3.0, + 4.0, 4.0, 4.0, 4.0, 4.0] + +utils_t3 :: [Double] +utils_t3 = take 25 $ embed (dTrackAndHold 99.99) utils_inp4 + +utils_t3r = + [99.99, 0.0, 0.0, 1.0, 2.0, + 3.0, 4.0, 4.0, 4.0, 4.0, + 3.0, 2.0, 2.0, 1.0, 0.0, + 1.0, 2.0, 3.0, 3.0, 3.0, + 4.0, 4.0, 4.0, 4.0, 4.0] + + +utils_t4 :: [Event Int] +utils_t4 = take 16 $ embed count utils_inp1 + +utils_t4r :: [Event Int] +utils_t4r = + [NoEvent, NoEvent, Event 1, NoEvent, + Event 2, NoEvent, NoEvent, NoEvent, + Event 3, Event 4, Event 5, NoEvent, + Event 6, NoEvent, NoEvent, NoEvent] + + +utils_t5 :: [Event Int] +utils_t5 = take 16 $ embed count utils_inp2 + +utils_t5r :: [Event Int] +utils_t5r = + [Event 1, NoEvent, NoEvent, NoEvent, + Event 2, NoEvent, NoEvent, NoEvent, + Event 3, Event 4, Event 5, NoEvent, + Event 6, NoEvent, NoEvent, NoEvent] + + +dynDelayLine :: a -> SF (a, Event Bool) a +dynDelayLine a0 = + second (arr (fmap (\p -> if p then addDelay else delDelay))) + >>> loop (arr (\((a, e), as) -> (a:as, e)) + >>> rpSwitchZ [iPre a0] + >>> arr (\as -> (last as, init as))) + where + addDelay ds = ds ++ [last ds] + + delDelay [d] = [d] + delDelay ds = init ds + +utils_t6 :: [Int] +utils_t6 = take 200 $ embed (dynDelayLine 0) + (deltaEncode 0.1 (zip [1..] evSeq)) + where + evSeq = NoEvent : Event True : NoEvent : NoEvent : Event True : + NoEvent : NoEvent : Event False : evSeq + +utils_t6r = + [0,1,1,2,3,3,4,6,7,8,8,9,10,10,11,13,14,15,15,16,17,17,18,20,21,22,22,23, + 24,24,25,27,28,29,29,30,31,31,32,34,35,36,36,37,38,38,39,41,42,43,43,44, + 45,45,46,48,49,50,50,51,52,52,53,55,56,57,57,58,59,59,60,62,63,64,64,65, + 66,66,67,69,70,71,71,72,73,73,74,76,77,78,78,79,80,80,81,83,84,85,85,86, + 87,87,88,90,91,92,92,93,94,94,95,97,98,99,99,100,101,101,102,104,105,106, + 106,107,108,108,109,111,112,113,113,114,115,115,116,118,119,120,120,121, + 122,122,123,125,126,127,127,128,129,129,130,132,133,134,134,135,136,136, + 137,139,140,141,141,142,143,143,144,146,147,148,148,149,150,150,151,153, + 154,155,155,156,157,157,158,160,161,162,162,163,164,164,165,167,168,169, + 169,170,171,171,172,174] + +utils_t7 :: [Double] +utils_t7 = take 50 $ embed impulseIntegral + (deltaEncode 0.1 (zip (repeat 1.0) evSeq)) + where + evSeq = replicate 9 NoEvent ++ [Event 10.0] + ++ replicate 9 NoEvent ++ [Event (-10.0)] + ++ evSeq + +utils_t7r = + [ 0.0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 10.9, + 11.0, 11.1, 11.2, 11.3, 11.4, 11.5, 11.6, 11.7, 11.8, 1.9, + 2.0, 2.1, 2.2, 2.3, 2.4, 2.5, 2.6, 2.7, 2.8, 12.9, + 13.0, 13.1, 13.2, 13.3, 13.4, 13.5, 13.6, 13.7, 13.8, 3.9, + 4.0, 4.1, 4.2, 4.3, 4.4, 4.5, 4.6, 4.7, 4.8, 14.9] + + +utils_t8 :: [Double] +utils_t8 = take 50 $ embed (provided (even . floor) integral (constant (-1))) + (deltaEncode 0.1 input) + where + input = replicate 10 1 + ++ replicate 10 2 + ++ replicate 10 3 + ++ replicate 10 4 + ++ input + +utils_t8r = + [-1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, + 0.0, 0.2, 0.4, 0.6, 0.8, 1.0, 1.2, 1.4, 1.6, 1.8, + -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, + 0.0, 0.4, 0.8, 1.2, 1.6, 2.0, 2.4, 2.8, 3.2, 3.6, + -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0] + + +utils_t9 :: [Double] +utils_t9 = take 50 $ embed (provided (odd . floor) integral (constant (-1))) + (deltaEncode 0.1 input) + where + input = replicate 10 1 + ++ replicate 10 2 + ++ replicate 10 3 + ++ replicate 10 4 + ++ input + +utils_t9r = + [ 0.0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9, + -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, + 0.0, 0.3, 0.6, 0.9, 1.2, 1.5, 1.8, 2.1, 2.4, 2.7, + -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, + 0.0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9] + + +utils_t10 :: [Event Double] +utils_t10 = testSF1 snap + +utils_t10r = + [Event 0.0, NoEvent, NoEvent, NoEvent, -- 0.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 1.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 2.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 3.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 4.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 5.0 s + NoEvent] + + +utils_t11 :: [Event Double] +utils_t11 = testSF1 (snapAfter 2.6) + +utils_t11r = + [NoEvent, NoEvent, NoEvent, NoEvent, -- 0.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 1.0 s + NoEvent, NoEvent, NoEvent, Event 11.0, -- 2.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 3.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 4.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 5.0 s + NoEvent] + + +utils_t12 :: [Event Double] +utils_t12 = testSF1 (sample 0.99) + +utils_t12r = + [NoEvent, NoEvent, NoEvent, NoEvent, -- 0.0 s + Event 4.0, NoEvent, NoEvent, NoEvent, -- 1.0 s + Event 8.0, NoEvent, NoEvent, NoEvent, -- 2.0 s + Event 12.0, NoEvent, NoEvent, NoEvent, -- 3.0 s + Event 16.0, NoEvent, NoEvent, NoEvent, -- 4.0 s + Event 20.0, NoEvent, NoEvent, NoEvent, -- 5.0 s + Event 24.0] + + +utils_t13 :: [Event ()] +utils_t13 = testSF1 (recur (after 0.99 ())) + +utils_t13r = + [NoEvent, NoEvent, NoEvent, NoEvent, -- 0.0 s + Event (), NoEvent, NoEvent, NoEvent, -- 1.0 s + Event (), NoEvent, NoEvent, NoEvent, -- 2.0 s + Event (), NoEvent, NoEvent, NoEvent, -- 3.0 s + Event (), NoEvent, NoEvent, NoEvent, -- 4.0 s + Event (), NoEvent, NoEvent, NoEvent, -- 5.0 s + Event ()] + + +utils_trs = + [ utils_t0 ~= utils_t0r, + utils_t1 ~= utils_t1r, + utils_t2 ~= utils_t2r, + utils_t3 ~= utils_t3r, + utils_t4 ~= utils_t4r, + utils_t5 ~= utils_t5r, + utils_t6 ~= utils_t6r, + utils_t7 ~= utils_t7r, + utils_t8 ~= utils_t8r, + utils_t9 ~= utils_t9r, + utils_t10 ~= utils_t10r, + utils_t11 ~= utils_t11r, + utils_t12 ~= utils_t12r, + utils_t13 ~= utils_t13r + ] + +utils_tr = and utils_trs
+ tests/AFRPTestsWFG.hs view
@@ -0,0 +1,103 @@+{- $Id: AFRPTestsWFG.hs,v 1.2 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTestsWFG * +* Purpose: Test cases for wave-form generation * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} + +module AFRPTestsWFG (wfg_tr, wfg_trs) where + +import AFRP +import AFRPInternals (Event(NoEvent, Event)) + +import AFRPTestsCommon + +------------------------------------------------------------------------------ +-- Test cases for wave-form generation +------------------------------------------------------------------------------ + +wfg_inp1 = deltaEncode 1.0 $ + [NoEvent, NoEvent, Event 1.0, NoEvent, + Event 2.0, NoEvent, NoEvent, NoEvent, + Event 3.0, Event 4.0, Event 4.0, NoEvent, + Event 0.0, NoEvent, NoEvent, NoEvent] + ++ repeat NoEvent + + +wfg_inp2 = deltaEncode 1.0 $ + [Event 1.0, NoEvent, NoEvent, NoEvent, + Event 2.0, NoEvent, NoEvent, NoEvent, + Event 3.0, Event 4.0, Event 4.0, NoEvent, + Event 0.0, NoEvent, NoEvent, NoEvent] + ++ repeat NoEvent + + +wfg_t0 :: [Double] +wfg_t0 = take 16 $ embed (hold 99.99) wfg_inp1 + +wfg_t0r = + [99.99, 99.99, 1.0, 1.0, + 2.0, 2.0, 2.0, 2.0, + 3.0, 4.0, 4.0, 4.0, + 0.0, 0.0, 0.0, 0.0] + +wfg_t1 :: [Double] +wfg_t1 = take 16 $ embed (hold 99.99) wfg_inp2 + +wfg_t1r = + [1.0, 1.0, 1.0, 1.0, + 2.0, 2.0, 2.0, 2.0, + 3.0, 4.0, 4.0, 4.0, + 0.0, 0.0, 0.0, 0.0] + +wfg_inp3 = deltaEncode 1.0 $ + [Nothing, Nothing, Just 1.0, Just 2.0, Just 3.0, + Just 4.0, Nothing, Nothing, Nothing, Just 3.0, + Just 2.0, Nothing, Just 1.0, Just 0.0, Just 1.0, + Just 2.0, Just 3.0, Nothing, Nothing, Just 4.0] + ++ repeat Nothing + +wfg_inp4 = deltaEncode 1.0 $ + [Just 0.0, Nothing, Just 1.0, Just 2.0, Just 3.0, + Just 4.0, Nothing, Nothing, Nothing, Just 3.0, + Just 2.0, Nothing, Just 1.0, Just 0.0, Just 1.0, + Just 2.0, Just 3.0, Nothing, Nothing, Just 4.0] + ++ repeat Nothing + + +wfg_t2 :: [Double] +wfg_t2 = take 25 $ embed (trackAndHold 99.99) wfg_inp3 + +wfg_t2r = + [99.99, 99.99, 1.0, 2.0, 3.0, + 4.0, 4.0, 4.0, 4.0, 3.0, + 2.0, 2.0, 1.0, 0.0, 1.0, + 2.0, 3.0, 3.0, 3.0, 4.0, + 4.0, 4.0, 4.0, 4.0, 4.0] + + +wfg_t3 :: [Double] +wfg_t3 = take 25 $ embed (trackAndHold 99.99) wfg_inp4 + +wfg_t3r = + [0.0, 0.0, 1.0, 2.0, 3.0, + 4.0, 4.0, 4.0, 4.0, 3.0, + 2.0, 2.0, 1.0, 0.0, 1.0, + 2.0, 3.0, 3.0, 3.0, 4.0, + 4.0, 4.0, 4.0, 4.0, 4.0] + + +wfg_trs = + [ wfg_t0 ~= wfg_t0r, + wfg_t1 ~= wfg_t1r, + wfg_t2 ~= wfg_t2r, + wfg_t3 ~= wfg_t3r + ] + +wfg_tr = and wfg_trs
+ tests/Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ tests/testAFRP.cabal view
@@ -0,0 +1,45 @@+Name: testAFRP+Version: 0.0+Description: Tests for Yampa functions.+License: BSD3+License-File: ../LICENSE.txt+Copyright: Henrik Nilsson, Antony Courtney and Yale University, (c) 2003+Author: Antony Courtney, Paul Hudak, Henrik Nilsson, John Peterson+Maintainer: Antony Courtney <antony@apocalypse.org>, Paul Hudak <paul.hudak@yale.edu>, Henrik Nilsson <nilsson@cs.yale.edu>, John Peterson <peterson-john@cs.yale.edu>+Stability: provisional+Homepage: http://www.haskell.org/yampa/+Category: Reactivity, FRP+Synopsis: Tests for Yampa functions.++Build-Depends: base, haskell98, Yampa >= 0.9.1 && < 0.9.2++Executable: testAFRP+Main-is: testAFRPMain.hs+ghc-options: -O -fglasgow-exts +Other-modules:+ AFRPTests,+ AFRPTestsCommon,+ AFRPTestsArr,+ AFRPTestsComp,+ AFRPTestsFirstSecond,+ AFRPTestsLaws,+ AFRPTestsLoop,+ AFRPTestsLoopLaws,+ AFRPTestsBasicSF,+ AFRPTestsEvSrc,+ AFRPTestsCOC,+ AFRPTestsSwitch,+ AFRPTestsKSwitch,+ AFRPTestsRSwitch,+ AFRPTestsPSwitch,+ AFRPTestsRPSwitch,+ AFRPTestsWFG,+ AFRPTestsAccum,+ AFRPTestsDelay,+ AFRPTestsDer,+ AFRPTestsLoopPre,+ AFRPTestsLoopIntegral,+ AFRPTestsReact,+ AFRPTestsEmbed,+ AFRPTestsUtils,+ AFRPTestsTask
+ tests/testAFRPMain.hs view
@@ -0,0 +1,71 @@+{- $Id: testAFRPMain.hs,v 1.9 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: testAFRPMain * +* Purpose: Main driver routine for running tests. * +* Authors: Henrik Nilsson and Antony Courtney * +* * +* Copyright (c) Yale University, 2003 * +* * +****************************************************************************** +-} +module Main where + +import AFRPTests + +import IO +import System -- getArgs + +-- main = runTests +-- main = runSpaceTests + +data TestFlags = TestFlags { tReg :: Bool -- run regression tests + , tSpace :: Bool -- run space tests + , tHelp :: Bool -- print usage and exit + } + +defFlags = TestFlags { tReg = False, tSpace = False, tHelp = False} +allFlags = TestFlags { tReg = True, tSpace = True, tHelp = False} + +parseArgs :: TestFlags -> [String] -> Either TestFlags String +parseArgs flags [] = Left flags +parseArgs flags (arg:args) = + case arg of + "-r" -> parseArgs (flags {tReg = True}) args + "-s" -> parseArgs (flags {tSpace = True}) args + "-h" -> parseArgs (flags {tHelp = True}) args + _ -> Right ("invalid argument: " ++ arg) + +usage :: String -> Maybe String -> IO () +usage pname mbEmsg = do + case mbEmsg of + (Just emsg) -> hPutStrLn stderr (pname ++ ": " ++ emsg) + _ -> return () + hPutStrLn stderr ("usage: " ++ pname ++ " [-r] [-s] [-h]") + hPutStrLn stderr "\t-s run space tests" + hPutStrLn stderr "\t-r run regression tests" + hPutStrLn stderr "\t-h print this help message" + hPutStrLn stderr "(no arguments runs all tests.)" + +main :: IO () +main = do + pname <- getProgName + args <- getArgs + let eFlags = if (length args) < 1 + then (Left allFlags) + else parseArgs defFlags args + case eFlags of + (Left tFlags) -> + if (tHelp tFlags) + then usage pname Nothing + else do + if (tReg tFlags) + then runRegTests + else return () + if (tSpace tFlags) + then runSpaceTests + else return () + (Right emsg) -> usage pname (Just emsg) + +