diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,52 @@ +2015-06-19 Ivan Perez + * src:/ instances of DeepSeq (see #5). + * Yampa.cabal: Deepseq added to dependencies. Version bump (0.10.2). + +2015-05-06 Ivan Perez + * Yampa.cabal: disables tests by default. Version bump (0.10.1.1). + +2015-05-05 Ivan Perez + * Yampa.cabal: exposes internal modules for documentation purposes. + Version bump (0.10.1) + +2015-05-05 Ivan Perez + * src/: Reorders code. Marks modules as deprecated. Removes useless functions. + * Yampa.cabal: version bump (0.10.0) + +2015-05-05 Ivan Perez + * src/FRP/Yampa.hs: documentation. Removes tabs. + * README.md: links to games, related projects, documentation. + * Yampa.cabal: version bump (0.9.7) + +2015-03-30 Ivan Perez + * src/FRP/Yampa/Task.hs: Adds Functor and Applicative instances, + for compatibility with base >= 4.8 (issue #7, pull request by + Ryan Scott). + * Yampa.cabal: version bump (0.9.6.1). + +2015-03-04 Ivan Perez + * src/: Coding style improvements. + +2014-08-29 Ivan Perez + + * Yampa.cabal: version bump (0.9.6). + * src/: Adds a substantial amount of documentation. + * src/FRP/Yampa.hs: Adds a new pause combinator. + +2014-06-04 Ivan Perez + + * Adds project to hudson-backed continuous integration server. + +2014-04-26 Ivan Perez + + * Yampa.cabal: version bump (0.9.5). + * Adds CHANGELOG to cabal file. + +2014-04-07 Ivan Perez + + * Yampa.cabal: new maintainer, version bump (0.9.4). + * src/: documentation is exposed so that Haddock can process it. + * No interface changes. + +Copyright (c) 2003, Henrik Nilsson, Antony Courtney and Yale University. +All rights reserved. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Yampa-core.cabal b/Yampa-core.cabal new file mode 100644 --- /dev/null +++ b/Yampa-core.cabal @@ -0,0 +1,135 @@ +name: Yampa-core +version: 0.2.0 +cabal-version: >= 1.8 +license: BSD3 +license-file: LICENSE +author: Henrik Nilsson, Antony Courtney +maintainer: Mykola Orliuk (virkony@gmail.com) +homepage: https://github.com/ony/Yampa-core +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. Yampa-core is a fork of Yampa that prefer to use other + Haskell libraries like deepseq and vector-space. + +build-type: Simple +extra-source-files: + tests/AFRPTests.hs, tests/AFRPTestsCommon.hs, tests/AFRPTestsArr.hs, + tests/AFRPTestsComp.hs, tests/AFRPTestsFirstSecond.hs, tests/AFRPTestsLaws.hs, + tests/AFRPTestsLoop.hs, tests/AFRPTestsLoopLaws.hs, tests/AFRPTestsBasicSF.hs, + tests/AFRPTestsSscan.hs, tests/AFRPTestsEvSrc.hs, tests/AFRPTestsCOC.hs, + tests/AFRPTestsSwitch.hs, tests/AFRPTestsKSwitch.hs, tests/AFRPTestsRSwitch.hs, + tests/AFRPTestsPSwitch.hs, tests/AFRPTestsRPSwitch.hs, tests/AFRPTestsWFG.hs, + tests/AFRPTestsAccum.hs, tests/AFRPTestsPre.hs, tests/AFRPTestsDelay.hs, + tests/AFRPTestsDer.hs, tests/AFRPTestsLoopPre.hs, tests/AFRPTestsLoopIntegral.hs, + tests/AFRPTestsReact.hs, tests/AFRPTestsEmbed.hs, tests/AFRPTestsUtils.hs, + tests/AFRPTestsTask.hs, tests/testAFRPMain.hs, + + examples/Elevator/Elevator.hs, + examples/Elevator/TestElevatorMain.hs, + examples/TailgatingDetector/TailgatingDetector.hs, + examples/TailgatingDetector/TestTGMain.hs, + + CHANGELOG + + +-- You can disable the hlint test suite with -f-test-hlint +flag test-hlint + default: False + manual: True + +flag test-afrp + default: False + manual: True + description: Enable semi-manual tests (monitor space-time leak) + +flag examples + default: False + manual: True + description: Build all examples + +library + hs-source-dirs: src + ghc-options : -O3 -Wall -fno-warn-name-shadowing + extensions: GADTs, TypeFamilies, Rank2Types, CPP, Arrows, FlexibleContexts + build-Depends: base < 5, random, vector-space >= 0.5, deepseq >= 1.1 + exposed-modules: + -- Main FRP modules + FRP.Yampa + FRP.Yampa.Event + FRP.Yampa.Internals + FRP.Yampa.Task + + -- FRP Core (minimal complete definition) + FRP.Yampa.Core + + -- Auxiliary definitions + FRP.Yampa.MergeableRecord + FRP.Yampa.Miscellany + FRP.Yampa.Utilities + FRP.Yampa.Basic + FRP.Yampa.Conditional + FRP.Yampa.Delays + FRP.Yampa.Diagnostics + FRP.Yampa.EventS + FRP.Yampa.Hybrid + FRP.Yampa.Integration + FRP.Yampa.Loop + FRP.Yampa.Random + FRP.Yampa.Scan + FRP.Yampa.Simulation + FRP.Yampa.Switches + FRP.Yampa.Time + + other-modules: + FRP.Yampa.InternalCore + +test-suite hlint + type: exitcode-stdio-1.0 + main-is: hlint.hs + hs-source-dirs: tests + if !flag(test-hlint) + buildable: False + else + build-depends: + base, + hlint >= 1.7 + +test-suite testAFRP + type: exitcode-stdio-1.0 + main-is: testAFRPMain.hs + hs-source-dirs: tests + build-depends: + base, + Yampa-core <0.3 + if !flag(test-afrp) + buildable: False + +executable YampaElevator + main-is: TestElevatorMain.hs + hs-source-dirs: examples/Elevator + build-depends: + base <5, + Yampa-core <0.3 + if !flag(examples) + buildable: False + +executable YampaTailgatingDetector + main-is: TestTGMain.hs + hs-source-dirs: examples/TailgatingDetector + build-depends: + base <5, + Yampa-core <0.3 + if !flag(examples) + buildable: False + +source-repository head + type: git + location: git://github.com/ivanperez-keera/Yampa.git + +source-repository head + type: git + location: git://github.com/ony/Yampa-core.git diff --git a/examples/Elevator/Elevator.hs b/examples/Elevator/Elevator.hs new file mode 100644 --- /dev/null +++ b/examples/Elevator/Elevator.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE Arrows #-} + +{- +****************************************************************************** +* A F R P * +* * +* Module: Elevator * +* Purpose: Elevator simulation based on the Fran version * +* from Simon Thompson's paper "A functional reactive * +* animation of a lift using Fran". * +* Authors: Henrik Nilsson * +* * +* Copyright (c) The University of Nottingham, 2004 * +* * +****************************************************************************** +-} + +module Elevator where + +import FRP.Yampa +import FRP.Yampa.Utilities -- ((^<<), dHold) + +------------------------------------------------------------------------------ +-- Auxiliary definitions +------------------------------------------------------------------------------ + +type Position = Double -- [m] +type Distance = Double -- [m] +type Velocity = Double -- [m/s] + + +------------------------------------------------------------------------------ +-- Elevator simulator +------------------------------------------------------------------------------ + +lower, upper :: Position +lower = 0 +upper = 5 + +upRate, downRate :: Velocity +upRate = 1 +downRate = 1.1 + + +elevator :: SF (Event (), Event ()) Position +elevator = proc (lbp,rbp) -> do + rec + -- This delayed hold can be thought of as modelling acceleration. + -- It is not "physical" to expect a desire to travel at a certain + -- velocity to be immediately reflected in the actual velocity. + -- (The reason we get into trouble here is that the stop/go events + -- depends instantaneously on "stopped" which in turn depends + -- instantaneously on "v".) + v <- dHold 0 -< stop `tag` 0 + `lMerge` + goUp `tag` upRate + `lMerge` + goDown `tag` (-downRate) + + y <- (lower +) ^<< integral -< v + + let atBottom = y <= lower + atTop = y >= upper + stopped = v == 0 -- Somewhat dubious ... + + waitingBottom = atBottom && stopped + waitingTop = atTop && stopped + + arriveBottom <- edge -< atBottom + arriveTop <- edge -< atTop + + let setUp = lbp `tag` True + setDown = rbp `tag` True + + -- This does not work. The reset events would be generated as soon + -- as the corresponding go event was generated, but the latter + -- depend instantaneusly on the reset signals. +-- resetUp = goUp `tag` False +-- resetDown = goDown `tag` False + + -- One approach would be to wait for "physical confiramtion" + -- that the elevator actually is moving in the desired direction: +-- resetUp <- (`tag` True) ^<< edge -< v > 0 +-- resetDown <- (`tag` False) ^<< edge -< v < 0 + + -- Another approach is to simply delay the reset events to avoid + -- suppressing the very event that generates the reset event. + resetUp <- iPre noEvent -< goUp `tag` False + resetDown <- iPre noEvent -< goDown `tag` False + + -- Of course, a third approach would be to just use dHold below. + -- But that does not seem to be the right solution to me. + upPending <- hold False -< setUp `lMerge` resetUp + downPending <- hold False -< setDown `lMerge` resetDown + + let pending = upPending || downPending + eitherButton = lbp `lMerge` rbp + + goDown = arriveTop `gate` pending + `lMerge` + eitherButton `gate` waitingTop + goUp = arriveBottom `gate` pending + `lMerge` + eitherButton `gate` waitingBottom + stop = (arriveTop `lMerge` arriveBottom) `gate` not pending + + returnA -< y diff --git a/examples/Elevator/TestElevatorMain.hs b/examples/Elevator/TestElevatorMain.hs new file mode 100644 --- /dev/null +++ b/examples/Elevator/TestElevatorMain.hs @@ -0,0 +1,97 @@ +{- +****************************************************************************** +* A F R P * +* * +* Example: Elevator * +* Purpose: Testing of the Elevator simulator. * +* Authors: Henrik Nilsson * +* * +* Copyright (c) The University of Nottingham, 2004 * +* * +****************************************************************************** +-} + +module Main where + +import Data.List (sortBy, intersperse) +import Data.Maybe (catMaybes) + +import FRP.Yampa +import FRP.Yampa.Utilities +import FRP.Yampa.Internals -- Just for testing purposes. + +import Elevator + +smplPer = 0.01 + +lbps :: SF a (Event ()) +lbps = afterEach [(3.0, ()), (2.0, ()), (50.0, ())] + +rbps :: SF a (Event ()) +rbps = afterEach [(20.0, ()), (2.0, ()), (18.0, ()), (15.001, ())] + + +-- Looks for interesting events by inspecting the input events +-- and the elevator position over the interval [0, t_max]. + +data State = Stopped | GoingUp | GoingDown deriving Eq + + +testElevator :: Time -> [(Time, ((Event (), Event ()), Position))] +testElevator t_max = takeWhile ((<= t_max) . fst) tios + where + -- Time, Input, and Output + tios = embed (localTime &&& ((lbps &&& rbps >>^ dup) + >>> second elevator)) + (deltaEncode smplPer (repeat ())) + + +findEvents :: [(Time, ((Event (), Event ()), Position))] + -> [(Time, Position, String)] +findEvents [] = [] +findEvents tios@((_, (_, y)) : _) = feAux Stopped y tios + where + feAux _ _ [] = [] + feAux sPre yPre ((t, ((lbp, rbp), y)) : tios') = + if not (null message) then + (t, y, message) : feAux s y tios' + else + feAux s y tios' + where + s = if y == yPre then + Stopped + else if yPre < y then + GoingUp + else + GoingDown + + ms = if s /= sPre then + case s of + Stopped -> Just "elevator stopped" + GoingUp -> Just "elevator started going up" + GoingDown -> Just "elevator started going down" + else + Nothing + + mu = if isEvent lbp then + Just "up button pressed" + else + Nothing + + md = if isEvent rbp then + Just "down button pressed" + else + Nothing + + message = concat (intersperse ", " (catMaybes [ms, mu, md])) + +formatEvent :: (Time, Position, String) -> String +formatEvent (t, y, m) = "t = " ++ t' ++ ",\ty = " ++ y' ++ ":\t" ++ m + where + t' = show (fromIntegral (round (t * 100)) / 100) + y' = show (fromIntegral (round (y * 100)) / 100) + +ppEvents [] = return () +ppEvents (e : es) = putStrLn (formatEvent e) >> ppEvents es + +main = ppEvents (findEvents (testElevator 100)) diff --git a/examples/TailgatingDetector/TailgatingDetector.hs b/examples/TailgatingDetector/TailgatingDetector.hs new file mode 100644 --- /dev/null +++ b/examples/TailgatingDetector/TailgatingDetector.hs @@ -0,0 +1,326 @@ +{-# LANGUAGE Arrows #-} + +{- +****************************************************************************** +* 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 Data.List (sortBy, (\\)) + +import FRP.Yampa +import FRP.Yampa.Utilities +import FRP.Yampa.Conditional +import FRP.Yampa.EventS + + +------------------------------------------------------------------------------ +-- 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) diff --git a/examples/TailgatingDetector/TestTGMain.hs b/examples/TailgatingDetector/TestTGMain.hs new file mode 100644 --- /dev/null +++ b/examples/TailgatingDetector/TestTGMain.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE Arrows #-} + +{- +****************************************************************************** +* 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 Data.List (sortBy) + +import FRP.Yampa +import FRP.Yampa.Utilities +import FRP.Yampa.Internals -- 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 diff --git a/src/FRP/Yampa.hs b/src/FRP/Yampa.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa.hs @@ -0,0 +1,434 @@ +{-# LANGUAGE GADTs, Rank2Types, CPP #-} + +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa +-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- +-- 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. +-- +-- You can find examples, tutorials and documentation on Yampa here: +-- +-- +-- +-- Structuring a hybrid system in Yampa is done based on two main concepts: +-- +-- * Signal Functions: 'SF'. Yampa is based on the concept of Signal Functions, +-- which are functions from a typed input signal to a typed output signal. +-- Conceptually, signals are functions from Time to Value, where time are the +-- real numbers and, computationally, a very dense approximation (Double) is +-- used. +-- +-- * Events: 'Event'. Values that may or may not occur (and would probably +-- occur rarely). It is often used for incoming network messages, mouse +-- clicks, etc. Events are used as values carried by signals. +-- +-- A complete Yampa system is defined as one Signal Function from some +-- type @a@ to a type @b@. The execution of this signal transformer +-- with specific input can be accomplished by means of two functions: +-- 'reactimate' (which needs an initialization action, +-- an input sensing action and an actuation/consumer action and executes +-- until explicitly stopped), and 'react' (which executes only one cycle). +-- +-- This will be the last version of Yampa to include mergeable records, +-- point2 and point3, vector2 and vector3, and other auxiliary definitions. The +-- internals have now changed. Although not all will be exposed in the next +-- version, below is the new project structure. Please, take a look and let us +-- know if you think there are any potential problems with it. +-- +-- Main Yampa modules: +-- +-- * "FRP.Yampa" -- This exports all FRP-related functions +-- +-- * "FRP.Yampa.Task" +-- +-- Minimal Complete FRP Definition +-- +-- * "FRP.Yampa.Core" +-- +-- Different FRP aspects +-- +-- * "FRP.Yampa.Basic" +-- +-- * "FRP.Yampa.Conditional" +-- +-- * "FRP.Yampa.Delays" +-- +-- * "FRP.Yampa.Event" +-- +-- * "FRP.Yampa.EventS" -- Event consuming/producing SFs. To be renamed. +-- +-- * "FRP.Yampa.Hybrid" -- Hybrid (discrete/continuous) SFs +-- +-- * "FRP.Yampa.Integration" +-- +-- * "FRP.Yampa.Loop" +-- +-- * "FRP.Yampa.Random" +-- +-- * "FRP.Yampa.Scan" +-- +-- * "FRP.Yampa.Switches" +-- +-- * "FRP.Yampa.Time" +-- +-- * "FRP.Yampa.Simulation" -- Reactimation/evaluation +-- +-- Internals +-- +-- * "FRP.Yampa.InternalCore" +-- +-- Old legacy code: +-- +-- * "FRP.Yampa.Diagnostics" +-- +-- * "FRP.Yampa.Internals" -- No longer in use +-- +-- * "FRP.Yampa.MergeableRecord" +-- +-- * "FRP.Yampa.Miscellany" +-- +-- * "FRP.Yampa.Utilities" +-- +-- CHANGELOG: +-- +-- * Adds (most) documentation. +-- +-- * New version using GADTs. +-- +-- ToDo: +-- +-- * Specialize def. of repeatedly. Could have an impact on invaders. +-- +-- * New defs for accs using SFAcc +-- +-- * Make sure opt worked: e.g. +-- +-- > repeatedly >>> count >>> arr (fmap sqr) +-- +-- * Introduce SFAccHld. +-- +-- * See if possible to unify AccHld wity Acc??? They are so close. +-- +-- * Introduce SScan. BUT KEEP IN MIND: Most if not all opts would +-- have been possible without GADTs??? +-- +-- * Look into pairs. At least pairing of SScan ought to be interesting. +-- +-- * Would be nice if we could get rid of first & second with impunity +-- thanks to Id optimizations. That's a clear win, with or without +-- an explicit pair combinator. +-- +-- * delayEventCat is a bit complicated ... +-- +-- +-- Random ideas: +-- +-- * What if one used rules to optimize +-- - (arr :: SF a ()) to (constant ()) +-- - (arr :: SF a a) to identity +-- But inspection of invader source code seem to indicate that +-- these are not very common cases at all. +-- +-- * It would be nice if it was possible to come up with opt. rules +-- that are invariant of how signal function expressions are +-- parenthesized. Right now, we have e.g. +-- arr f >>> (constant c >>> sf) +-- being optimized to +-- cpAuxA1 f (cpAuxC1 c sf) +-- whereas it clearly should be possible to optimize to just +-- cpAuxC1 c sf +-- What if we didn't use SF' but +-- SFComp :: -> SF' a b -> SF' b c -> SF' a c +-- ??? +-- +-- * The transition function would still be optimized in (pretty much) +-- the current way, but it would still be possible to look "inside" +-- composed signal functions for lost optimization opts. +-- Seems to me this could be done without too much extra effort/no dupl. +-- work. +-- E.g. new cpAux, the general case: +-- +-- @ +-- cpAux sf1 sf2 = SFComp tf sf1 sf2 +-- where +-- tf dt a = (cpAux sf1' sf2', c) +-- where +-- (sf1', b) = (sfTF' sf1) dt a +-- (sf2', c) = (sfTF' sf2) dt b +-- @ +-- +-- * The ONLY change was changing the constructor from SF' to SFComp and +-- adding sf1 and sf2 to the constructor app.! +-- +-- * An optimized case: +-- cpAuxC1 b sf1 sf2 = SFComp tf sf1 sf2 +-- So cpAuxC1 gets an extra arg, and we change the constructor. +-- But how to exploit without writing 1000s of rules??? +-- Maybe define predicates on SFComp to see if the first or second +-- sf are "interesting", and if so, make "reassociate" and make a +-- recursive call? E.g. we're in the arr case, and the first sf is another +-- arr, so we'd like to combine the two. +-- +-- * It would also be intersting, then, to know when to STOP playing this +-- game, due to the overhead involved. +-- +-- * Why don't we have a "SWITCH" constructor that indicates that the +-- structure will change, and thus that it is worthwile to keep +-- looking for opt. opportunities, whereas a plain "SF'" would +-- indicate that things NEVER are going to change, and thus we can just +-- as well give up? +----------------------------------------------------------------------------------------- + +module FRP.Yampa ( + -- Re-exported module, classes, and types + module Control.Arrow, + module Data.VectorSpace, + RandomGen(..), + Random(..), + + -- * Basic definitions + Time, -- [s] Both for time w.r.t. some reference and intervals. + DTime, -- [s] Sampling interval, always > 0. + SF, -- Signal Function. + Event(..), -- Events; conceptually similar to Maybe (but abstract). + + -- Temporary! + -- SF(..), sfTF', + + -- Main instances + -- SF is an instance of Arrow and ArrowLoop. Method instances: + -- arr :: (a -> b) -> SF a b + -- (>>>) :: SF a b -> SF b c -> SF a c + -- (<<<) :: SF b c -> SF a b -> SF a c + -- first :: SF a b -> SF (a,c) (b,c) + -- second :: SF a b -> SF (c,a) (c,b) + -- (***) :: SF a b -> SF a' b' -> SF (a,a') (b,b') + -- (&&&) :: SF a b -> SF a b' -> SF a (b,b') + -- returnA :: SF a a + -- loop :: SF (a,c) (b,c) -> SF a b + + -- Event is an instance of Functor, Eq, and Ord. Some method instances: + -- fmap :: (a -> b) -> Event a -> Event b + -- (==) :: Event a -> Event a -> Bool + -- (<=) :: Event a -> Event a -> Bool + + -- ** Lifting + arrPrim, arrEPrim, -- For optimization + + -- * Signal functions + + -- ** Basic signal functions + identity, -- :: SF a a + constant, -- :: b -> SF a b + localTime, -- :: SF a Time + time, -- :: SF a Time, Other name for localTime. + + -- ** Initialization + (-->), -- :: b -> SF a b -> SF a b, infixr 0 + (>--), -- :: a -> SF a b -> SF a b, infixr 0 + (-=>), -- :: (b -> b) -> SF a b -> SF a b infixr 0 + (>=-), -- :: (a -> a) -> SF a b -> SF a b infixr 0 + initially, -- :: a -> SF a a + + -- ** Simple, stateful signal processing + sscan, -- :: (b -> a -> b) -> b -> SF a b + sscanPrim, -- :: (c -> a -> Maybe (c, b)) -> c -> b -> SF a b + + -- * Events + -- ** Basic event sources + never, -- :: SF a (Event b) + now, -- :: b -> SF a (Event b) + after, -- :: Time -> b -> SF a (Event b) + repeatedly, -- :: Time -> b -> SF a (Event b) + afterEach, -- :: [(Time,b)] -> SF a (Event b) + afterEachCat, -- :: [(Time,b)] -> SF a (Event [b]) + delayEvent, -- :: Time -> SF (Event a) (Event a) + delayEventCat, -- :: Time -> SF (Event a) (Event [a]) + edge, -- :: SF Bool (Event ()) + iEdge, -- :: Bool -> SF Bool (Event ()) + edgeTag, -- :: a -> SF Bool (Event a) + edgeJust, -- :: SF (Maybe a) (Event a) + edgeBy, -- :: (a -> a -> Maybe b) -> a -> SF a (Event b) + + -- ** Stateful event suppression + notYet, -- :: SF (Event a) (Event a) + once, -- :: SF (Event a) (Event a) + takeEvents, -- :: Int -> SF (Event a) (Event a) + dropEvents, -- :: Int -> SF (Event a) (Event a) + + -- ** Pointwise functions on events + noEvent, -- :: Event a + noEventFst, -- :: (Event a, b) -> (Event c, b) + noEventSnd, -- :: (a, Event b) -> (a, Event c) + event, -- :: a -> (b -> a) -> Event b -> a + fromEvent, -- :: Event a -> a + isEvent, -- :: Event a -> Bool + isNoEvent, -- :: Event a -> Bool + tag, -- :: Event a -> b -> Event b, infixl 8 + tagWith, -- :: b -> Event a -> Event b, + attach, -- :: Event a -> b -> Event (a, b), infixl 8 + lMerge, -- :: Event a -> Event a -> Event a, infixl 6 + rMerge, -- :: Event a -> Event a -> Event a, infixl 6 + merge, -- :: Event a -> Event a -> Event a, infixl 6 + mergeBy, -- :: (a -> a -> a) -> Event a -> Event a -> Event a + mapMerge, -- :: (a -> c) -> (b -> c) -> (a -> b -> c) + -- -> Event a -> Event b -> Event c + mergeEvents, -- :: [Event a] -> Event a + catEvents, -- :: [Event a] -> Event [a] + joinE, -- :: Event a -> Event b -> Event (a,b),infixl 7 + splitE, -- :: Event (a,b) -> (Event a, Event b) + filterE, -- :: (a -> Bool) -> Event a -> Event a + mapFilterE, -- :: (a -> Maybe b) -> Event a -> Event b + gate, -- :: Event a -> Bool -> Event a, infixl 8 + + -- * Switching + -- ** Basic switchers + switch, dSwitch, -- :: SF a (b, Event c) -> (c -> SF a b) -> SF a b + rSwitch, drSwitch, -- :: SF a b -> SF (a,Event (SF a b)) b + kSwitch, dkSwitch, -- :: SF a b + -- -> SF (a,b) (Event c) + -- -> (SF a b -> c -> SF a b) + -- -> SF a b + + -- ** Parallel composition and switching + -- *** Parallel composition and switching over collections with broadcasting + parB, -- :: Functor col => col (SF a b) -> SF a (col b) + pSwitchB,dpSwitchB, -- :: Functor col => + -- col (SF a b) + -- -> SF (a, col b) (Event c) + -- -> (col (SF a b) -> c -> SF a (col b)) + -- -> SF a (col b) + rpSwitchB,drpSwitchB, -- :: Functor col => + -- col (SF a b) + -- -> SF (a, Event (col (SF a b)->col (SF a b))) + -- (col b) + + -- *** 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) + + -- * Discrete to continuous-time signal functions + -- ** Wave-form generation + hold, -- :: a -> SF (Event a) a + dHold, -- :: a -> SF (Event a) a + trackAndHold, -- :: a -> SF (Maybe a) a + + -- ** Accumulators + accum, -- :: a -> SF (Event (a -> a)) (Event a) + accumHold, -- :: a -> SF (Event (a -> a)) a + dAccumHold, -- :: a -> SF (Event (a -> a)) a + accumBy, -- :: (b -> a -> b) -> b -> SF (Event a) (Event b) + accumHoldBy, -- :: (b -> a -> b) -> b -> SF (Event a) b + dAccumHoldBy, -- :: (b -> a -> b) -> b -> SF (Event a) b + accumFilter, -- :: (c -> a -> (c, Maybe b)) -> c + -- -> SF (Event a) (Event b) + + -- * Delays + -- ** Basic delays + pre, -- :: SF a a + iPre, -- :: a -> SF a a + + -- ** Timed delays + delay, -- :: Time -> a -> SF a a + + -- ** Variable delay + pause, -- :: b -> SF a b -> SF a Bool -> SF a b + + -- * State keeping combinators + + -- ** Loops with guaranteed well-defined feedback + loopPre, -- :: c -> SF (a,c) (b,c) -> SF a b + loopIntegral, -- :: (VectorSpace a, s ~ Scalar a, Fractional s) => SF (a,c) (b,c) -> SF a b + + -- ** Integration and differentiation + integral, -- :: (VectorSpace a, s ~ Scalar a, Fractional s) => SF a a + + derivative, -- :: (VectorSpace a, s ~ Scalar a, Fractional s) => SF a a -- Crude! + imIntegral, -- :: (VectorSpace a, s ~ Scalar a, Fractional s) => a -> SF a a + + -- Temporarily hidden, but will eventually be made public. + -- iterFrom, -- :: (a -> a -> DTime -> b -> b) -> b -> SF a b + + -- * 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) + + -- * Execution/simulation + -- ** Reactimation + reactimate, -- :: IO a + -- -> (Bool -> IO (DTime, Maybe a)) + -- -> (Bool -> b -> IO Bool) + -- -> SF a b + -- -> IO () + ReactHandle, + reactInit, -- IO a -- init + -- -> (ReactHandle a b -> Bool -> b -> IO Bool) -- actuate + -- -> SF a b + -- -> IO (ReactHandle a b) + -- process a single input sample: + react, -- ReactHandle a b + -- -> (DTime,Maybe a) + -- -> IO Bool + + -- ** Embedding + -- (tentative: will be revisited) + embed, -- :: SF a b -> (a, [(DTime, Maybe a)]) -> [b] + embedSynch, -- :: SF a b -> (a, [(DTime, Maybe a)]) -> SF Double b + deltaEncode, -- :: Eq a => DTime -> [a] -> (a, [(DTime, Maybe a)]) + deltaEncodeBy, -- :: (a -> a -> Bool) -> DTime -> [a] + -- -> (a, [(DTime, Maybe a)]) + + -- * Auxiliary definitions + -- Reverse function composition and arrow plumbing aids + ( # ), -- :: (a -> b) -> (b -> c) -> (a -> c), infixl 9 + dup, -- :: a -> (a,a) + +) where + +import Control.Arrow + +import FRP.Yampa.InternalCore +import FRP.Yampa.Basic +import FRP.Yampa.Conditional +import FRP.Yampa.Delays +import FRP.Yampa.Event +import FRP.Yampa.EventS +import FRP.Yampa.Hybrid +import FRP.Yampa.Integration +import FRP.Yampa.Loop +import FRP.Yampa.Miscellany (( # ), dup) +import FRP.Yampa.Random +import FRP.Yampa.Scan +import FRP.Yampa.Simulation +import FRP.Yampa.Switches +import FRP.Yampa.Time +import Data.VectorSpace + +-- Vim modeline +-- vim:set tabstop=8 expandtab: diff --git a/src/FRP/Yampa/Basic.hs b/src/FRP/Yampa/Basic.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa/Basic.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE GADTs, Rank2Types, CPP #-} + +-- Module : FRP.Yampa.Basic +-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) + +module FRP.Yampa.Basic ( + + -- * Basic signal functions + identity, -- :: SF a a + constant, -- :: b -> SF a b + + -- ** Initialization + (-->), -- :: b -> SF a b -> SF a b, infixr 0 + (>--), -- :: 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 + + ) where + + +import FRP.Yampa.InternalCore (SF(..), sfConst, sfId) + +infixr 0 -->, >--, -=>, >=- + +------------------------------------------------------------------------------ +-- Basic signal functions +------------------------------------------------------------------------------ + +-- | Identity: identity = arr id +-- +-- Using 'identity' is preferred over lifting id, since the arrow combinators +-- know how to optimise certain networks based on the transformations being +-- applied. +identity :: SF a a +identity = SF {sfTF = \a -> (sfId, a)} + +{-# ANN constant "HLint: ignore Use const" #-} +-- | Identity: constant b = arr (const b) +-- +-- Using 'constant' is preferred over lifting const, since the arrow combinators +-- know how to optimise certain networks based on the transformations being +-- applied. +constant :: b -> SF a b +constant b = SF {sfTF = \_ -> (sfConst b, b)} + +------------------------------------------------------------------------------ +-- Initialization +------------------------------------------------------------------------------ + +-- | Initialization operator (cf. Lustre/Lucid Synchrone). +-- +-- The output at time zero is the first argument, and from +-- that point on it behaves like the signal function passed as +-- second argument. +(-->) :: b -> SF a b -> SF a b +b0 --> (SF {sfTF = tf10}) = SF {sfTF = \a0 -> (fst (tf10 a0), b0)} + +-- | Input initialization operator. +-- +-- The input at time zero is the first argument, and from +-- that point on it behaves like the signal function passed as +-- second argument. +(>--) :: a -> SF a b -> SF a b +a0 >-- (SF {sfTF = tf10}) = SF {sfTF = \_ -> tf10 a0} + + +-- | Transform initial output value. +-- +-- Applies a transformation 'f' only to the first output value at +-- time zero. +(-=>) :: (b -> b) -> SF a b -> SF a b +f -=> (SF {sfTF = tf10}) = + SF {sfTF = \a0 -> let (sf1, b0) = tf10 a0 in (sf1, f b0)} + + +-- | Transform initial input value. +-- +-- Applies a transformation 'f' only to the first input value at +-- time zero. +{-# ANN (>=-) "HLint: ignore Avoid lambda" #-} +(>=-) :: (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) diff --git a/src/FRP/Yampa/Conditional.hs b/src/FRP/Yampa/Conditional.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa/Conditional.hs @@ -0,0 +1,67 @@ +module FRP.Yampa.Conditional ( + -- Guards and automata-oriented combinators + provided -- :: (a -> Bool) -> SF a b -> SF a b -> SF a b + -- ** Variable delay + , pause -- :: b -> SF a b -> SF a Bool -> SF a b + + ) where + +import Control.Arrow +import FRP.Yampa.Basic +import FRP.Yampa.InternalCore (SF(..), SF'(..), sfTF', Transition) +import FRP.Yampa.EventS +import FRP.Yampa.Switches + +------------------------------------------------------------------------------ +-- 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) + +------------------------------------------------------------------------------ +-- Variable pause in signal +------------------------------------------------------------------------------ + +-- | Given a value in an accumulator (b), a predicate signal function (sfC), +-- and a second signal function (sf), pause will produce the accumulator b +-- if sfC input is True, and will transform the signal using sf otherwise. +-- It acts as a pause with an accumulator for the moments when the +-- transformation is paused. +pause :: b -> SF a Bool -> SF a b -> SF a b +pause b_init (SF { sfTF = tfP}) (SF {sfTF = tf10}) = SF {sfTF = tf0} + where + -- Initial transformation (no time delta): + -- If the condition is True, return the accumulator b_init) + -- Otherwise transform the input normally and recurse. + tf0 a0 = case tfP a0 of + (c, True) -> (pauseInit b_init tf10 c, b_init) + (c, False) -> let (k, b0) = tf10 a0 + in (pause' b0 k c, b0) + + -- Similar deal, but with a time delta + pauseInit :: b -> (a -> Transition a b) -> SF' a Bool -> SF' a b + pauseInit b_init' tf10' c = SF' tf0' + where tf0' dt a = + case (sfTF' c) dt a of + (c', True) -> (pauseInit b_init' tf10' c', b_init') + (c', False) -> let (k, b0) = tf10' a + in (pause' b0 k c', b0) + + -- Very same deal (almost alpha-renameable) + pause' :: b -> SF' a b -> SF' a Bool -> SF' a b + pause' b_init' tf10' tfP' = SF' tf0' + where tf0' dt a = + case (sfTF' tfP') dt a of + (tfP'', True) -> (pause' b_init' tf10' tfP'', b_init') + (tfP'', False) -> let (tf10'', b0') = (sfTF' tf10') dt a + in (pause' b0' tf10'' tfP'', b0') + + diff --git a/src/FRP/Yampa/Core.hs b/src/FRP/Yampa/Core.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa/Core.hs @@ -0,0 +1,26 @@ +module FRP.Yampa.Core + ( + -- * Signal function + SF + + -- * Stateless combinators + , iPre + , arr + , (>>>) + , first + + -- * Stateful combinators + , loop + , integral + + -- ** Switching upon certain events + , Event(..) + , switch + + -- ** Time (NOTE: integral 1 over time. Not really necessary.) + , Time + , time + ) + where + +import FRP.Yampa diff --git a/src/FRP/Yampa/Delays.hs b/src/FRP/Yampa/Delays.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa/Delays.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE GADTs, Rank2Types, CPP #-} +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.Delays +-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +----------------------------------------------------------------------------------------- + +module FRP.Yampa.Delays ( + + -- * Delays + -- ** Basic delays + pre, -- :: SF a a + iPre, -- :: a -> SF a a + + -- ** Timed delays + delay, -- :: Time -> a -> SF a a + + -- ** To be completed + fby, -- :: b -> SF a b -> SF a b, infixr 0 +) where + +import Control.Arrow + +import FRP.Yampa.Diagnostics +import FRP.Yampa.InternalCore (SF(..), SF'(..), sfTF', Transition, Time) + +import FRP.Yampa.Basic +import FRP.Yampa.Scan + +infixr 0 `fby` + +------------------------------------------------------------------------------ +-- Delays +------------------------------------------------------------------------------ + +-- | Uninitialized delay operator. + +-- !!! Redefined using SFSScan +-- !!! About 20% slower than old_pre on its own. +pre :: SF a a +pre = sscanPrim f uninit uninit + where + f c a = Just (a, c) + uninit = usrErr "AFRP" "pre" "Uninitialized pre operator." + + +-- | Initialized delay operator. +iPre :: a -> SF a a +iPre = (--> pre) + + +------------------------------------------------------------------------------ +-- Timed delays +------------------------------------------------------------------------------ + +-- | Delay a signal by a fixed time 't', using the second parameter +-- to fill in the initial 't' seconds. + +-- Invariants: +-- t_diff measure the time since the latest output sample ideally +-- should have been output. Whenever that equals or exceeds the +-- time delta for the next buffered sample, it is time to output a +-- new sample (although not necessarily the one first in the queue: +-- it might be necessary to "catch up" by discarding samples. +-- 0 <= t_diff < bdt, where bdt is the buffered time delta for the +-- sample on the front of the buffer queue. +-- +-- Sum of time deltas in the queue >= q. + +-- !!! PROBLEM! +-- Since input samples sometimes need to be duplicated, it is not a +-- good idea use a delay on things like events since we then could +-- end up with duplication of event occurrences. +-- (Thus, we actually NEED delayEvent.) + +delay :: Time -> a -> SF a a +delay q a_init | q < 0 = usrErr "AFRP" "delay" "Negative delay." + | q == 0 = identity + | otherwise = SF {sfTF = tf0} + where + tf0 a0 = (delayAux [] [(q, a0)] 0 a_init, a_init) + + delayAux _ [] _ _ = undefined + delayAux rbuf buf@((bdt, ba) : buf') t_diff a_prev = SF' tf -- True + where + tf dt a | t_diff' < bdt = + (delayAux rbuf' buf t_diff' a_prev, a_prev) + | otherwise = nextSmpl rbuf' buf' (t_diff' - bdt) ba + where + t_diff' = t_diff + dt + rbuf' = (dt, a) : rbuf + + nextSmpl rbuf [] t_diff a = + nextSmpl [] (reverse rbuf) t_diff a + nextSmpl rbuf buf@((bdt, ba) : buf') t_diff a + | t_diff < bdt = (delayAux rbuf buf t_diff a, a) + | otherwise = nextSmpl rbuf buf' (t_diff-bdt) ba + + +-- !!! Hmm. Not so easy to do efficiently, it seems ... + +-- varDelay :: Time -> a -> SF (a, Time) a +-- varDelay = undefined + + +-- if_then_else :: SF a Bool -> SF a b -> SF a b -> SF a b +-- if_then_else condSF sfThen sfElse = proc (i) -> do +-- cond <- condSF -< i +-- ok <- sfThen -< i +-- notOk <- sfElse -< i +-- returnA -< if cond then ok else notOk + +-- | Lucid-Synchrone-like initialized delay (read "followed by"). +fby :: b -> SF a b -> SF a b +b0 `fby` sf = b0 --> sf >>> pre + + +-- Vim modeline +-- vim:set tabstop=8 expandtab: diff --git a/src/FRP/Yampa/Diagnostics.hs b/src/FRP/Yampa/Diagnostics.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa/Diagnostics.hs @@ -0,0 +1,21 @@ +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.Diagnostics +-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : nilsson@cs.yale.edu +-- Stability : provisional +-- Portability : portable +-- +-- Standardized error-reporting for Yampa +----------------------------------------------------------------------------------------- + +module FRP.Yampa.Diagnostics where + +usrErr :: String -> String -> String -> a +usrErr mn fn msg = error (mn ++ "." ++ fn ++ ": " ++ msg) + +intErr :: String -> String -> String -> a +intErr mn fn msg = error ("[internal error] " ++ mn ++ "." ++ fn ++ ": " + ++ msg) diff --git a/src/FRP/Yampa/Event.hs b/src/FRP/Yampa/Event.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa/Event.hs @@ -0,0 +1,309 @@ +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.Event +-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : nilsson@cs.yale.edu +-- Stability : provisional +-- Portability : portable +-- +-- Definition of Yampa Event type. +-- +-- Note on naming conventions used in this module. +-- +-- Names here might have to be rethought. It's really a bit messy. +-- In general, the aim has been short and convenient names (like 'tag', +-- 'attach', 'lMerge') and thus we have tried to stay away from suffixing/ +-- prefixing conventions. E.g. 'Event' as a common suffix would be very +-- verbose. +-- +-- However, part of the names come from a desire to stay close to similar +-- functions for the Maybe type. e.g. 'event', 'fromEvent', 'isEvent'. +-- In many cases, this use of 'Event' can could understood to refer to the +-- constructor 'Event', not to the type name 'Event'. Thus this use of +-- event should not be seen as a suffixing-with-type-name convention. But +-- that is obviously not easy to see, and, more over, interpreting 'Event' +-- as the name of the type might make equally good or better sense. E.g. +-- 'fromEvent' can also be seen as a function taking an event signal, +-- which is a partial function on time, to a normal signal. The latter is +-- then undefined when the source event function is undefined. +-- +-- In other cases, it has been necessary to somehow stay out of the way of +-- names used by the prelude or other commonly imported modules/modules +-- which could be expected to be used heavily in Yampa code. In those cases +-- a suffix 'E' have been added. Examples are 'filterE' (exists in Prelude) +-- and 'joinE' (exists in Monad). Maybe the suffix isn't necessary in the +-- last case. +-- +-- Some functions (actually only one currently, 'mapFilterE') have got an 'E' +-- suffix just because they're closely related (by name or semantics) to one +-- which already has an 'E' suffix. Another candidate would be 'splitE' to +-- complement 'joinE'. But events carrying pairs could obviously have other +-- sources than a 'joinE', so currently it is called 'split'. +-- +-- 2003-05-19: Actually, have now changed to 'splitE' to avoid a clash +-- with the method 'split' in the class RandomGen. +-- +-- 2003-05-19: What about 'gate'? Stands out compared to e.g. 'filterE'. +-- +-- Currently the 'E' suffix is considered an exception. Maybe we should use +-- completely different names to avoid the 'E' suffix. If the functions +-- are not used that often, 'Event' might be approriate. Alternatively the +-- suffix 'E' should be adopted globaly (except if the name already contains +-- 'event' in some form?). +-- +-- Arguably, having both a type 'Event' and a constructor 'Event' is confusing +-- since there are more than one constructor. But the name 'Event' for the +-- constructor is quite apt. It's really the type name that is wrong. But +-- no one has found a better name, and changing it would be a really major +-- undertaking. Yes, the constructor 'Event' is not exported, but we still +-- need to talk conceptually about them. On the other hand, if we consider +-- Event-signals as partial functions on time, maybe it isn't so confusing: +-- they just don't have a value between events, so 'NoEvent' does not really +-- exist conceptually. +-- +-- ToDo: +-- - Either: reveal NoEvent and Event +-- or: introcuce 'event = Event', call what's now 'event' 'fromEvent', +-- and call what's now called 'fromEvent' something else, like +-- 'unsafeFromEvent'??? Better, dump it! After all, using current +-- names, 'fromEvent = event undefined'! +----------------------------------------------------------------------------------------- + +module FRP.Yampa.Event where + +-- 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 + +import Control.DeepSeq (NFData(..)) + +import FRP.Yampa.Diagnostics + + +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. + +-- | A single possible event occurrence, that is, a value that may or may +-- not occur. Events are used to represent values that are not produced +-- continuously, such as mouse clicks (only produced when the mouse is clicked, +-- as opposed to mouse positions, which are always defined). +data Event a = NoEvent | Event a deriving (Show) + +-- | Make the NoEvent constructor available. Useful e.g. for initialization, +-- ((-->) & friends), and it's easily available anyway (e.g. mergeEvents []). +noEvent :: Event a +noEvent = NoEvent + + +-- | Suppress any event in the first component of a pair. +noEventFst :: (Event a, b) -> (Event c, b) +noEventFst (_, b) = (NoEvent, b) + + +-- | Suppress any event in the second component of a pair. +noEventSnd :: (a, Event b) -> (a, Event c) +noEventSnd (a, _) = (a, NoEvent) + + +------------------------------------------------------------------------------ +-- Eq instance +------------------------------------------------------------------------------ + +-- Right now, we could derive this instance. But that could possibly change. + +instance Eq a => Eq (Event a) where + NoEvent == NoEvent = True + (Event x) == (Event y) = x == y + _ == _ = False + + +------------------------------------------------------------------------------ +-- Ord instance +------------------------------------------------------------------------------ + +instance Ord a => Ord (Event a) where + compare NoEvent NoEvent = EQ + compare NoEvent (Event _) = LT + compare (Event _) NoEvent = GT + compare (Event x) (Event y) = compare x y + + +------------------------------------------------------------------------------ +-- Functor instance +------------------------------------------------------------------------------ + +instance Functor Event where + fmap _ NoEvent = NoEvent + fmap f (Event a) = Event (f a) + + +------------------------------------------------------------------------------ +-- NFData instance +------------------------------------------------------------------------------ +instance NFData a => NFData (Event a) where + rnf NoEvent = () + rnf (Event a) = rnf a `seq` () + +------------------------------------------------------------------------------ +-- 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 + +-- | Extract the value from an event. Fails if there is no event. +fromEvent :: Event a -> a +fromEvent (Event a) = a +fromEvent NoEvent = usrErr "AFRP" "fromEvent" "Not an event." + +-- | Tests whether the input represents an actual event. +isEvent :: Event a -> Bool +isEvent NoEvent = False +isEvent (Event _) = True + +-- | Negation of 'isEvent'. +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 + +-- | Tags an (occurring) event with a value ("replacing" the old value). Same +-- as 'tag' with the arguments swapped. +tagWith :: b -> Event a -> Event b +tagWith = flip tag + +-- | Attaches an extra value to the value of an occurring event. +attach :: Event a -> b -> Event (a, b) +e `attach` b = fmap (\a -> (a, b)) e + + +------------------------------------------------------------------------------ +-- Event merging (disjunction) and joining (conjunction) +------------------------------------------------------------------------------ + +-- !!! I think this is too complicated. rMerge can be obtained simply by +-- !!! swapping the arguments. So the only time it is possibly of any +-- !!! interest is for partial app. "merge" is inherently dangerous. +-- !!! But this is NOT obvious from its type: it's type is just like +-- !!! the others. This is the only example of such a def. +-- !!! Finally: mergeEvents is left-biased, but this is not reflected in +-- !!! its name. + +-- | Left-biased event merge (always prefer left event, if present). +lMerge :: Event a -> Event a -> Event a +le `lMerge` re = event re Event le + + +-- | Right-biased event merge (always prefer right event, if present). +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 parameterized by a 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-map utility that maps event occurrences, +-- merging the results. The first three arguments are mapping functions, +-- the third of which will only be used when both events are present. +-- Therefore, 'mergeBy' = 'mapMerge' 'id' 'id' +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) + +-- | Merge a list of events; foremost event has priority. +mergeEvents :: [Event a] -> Event a +mergeEvents = foldr lMerge NoEvent + +-- | Collect 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 (conjunction) of two events. Only produces an event +-- if both events exist. +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. Note: since 'Event' is a 'Functor', +-- see 'fmap' for a simpler version of this function with no filtering. +mapFilterE :: (a -> Maybe b) -> Event a -> Event b +mapFilterE _ NoEvent = NoEvent +mapFilterE f (Event a) = case f a of + Nothing -> NoEvent + Just b -> Event b + + +-- | Enable/disable event occurences based on an external condition. +gate :: Event a -> Bool -> Event a +_ `gate` False = NoEvent +e `gate` True = e diff --git a/src/FRP/Yampa/EventS.hs b/src/FRP/Yampa/EventS.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa/EventS.hs @@ -0,0 +1,569 @@ +{-# LANGUAGE GADTs, Rank2Types, CPP #-} +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.EventS +-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- +----------------------------------------------------------------------------------------- + +module FRP.Yampa.EventS ( + + -- * Basic event sources + never, -- :: SF a (Event b) + now, -- :: b -> SF a (Event b) + after, -- :: Time -> b -> SF a (Event b) + repeatedly, -- :: Time -> b -> SF a (Event b) + afterEach, -- :: [(Time,b)] -> SF a (Event b) + afterEachCat, -- :: [(Time,b)] -> SF a (Event [b]) + delayEvent, -- :: Time -> SF (Event a) (Event a) + delayEventCat, -- :: Time -> SF (Event a) (Event [a]) + edge, -- :: SF Bool (Event ()) + iEdge, -- :: Bool -> SF Bool (Event ()) + edgeTag, -- :: a -> SF Bool (Event a) + edgeJust, -- :: SF (Maybe a) (Event a) + edgeBy, -- :: (a -> a -> Maybe b) -> a -> SF a (Event b) + + -- * Stateful event suppression + notYet, -- :: SF (Event a) (Event a) + once, -- :: SF (Event a) (Event a) + takeEvents, -- :: Int -> SF (Event a) (Event a) + dropEvents, -- :: Int -> SF (Event a) (Event a) + + -- ** Pointwise functions on events + -- noEvent, -- :: Event a + -- noEventFst, -- :: (Event a, b) -> (Event c, b) + -- noEventSnd, -- :: (a, Event b) -> (a, Event c) + -- event, -- :: a -> (b -> a) -> Event b -> a + -- fromEvent, -- :: Event a -> a + -- isEvent, -- :: Event a -> Bool + -- isNoEvent, -- :: Event a -> Bool + -- tag, -- :: Event a -> b -> Event b, infixl 8 + -- tagWith, -- :: b -> Event a -> Event b, + -- attach, -- :: Event a -> b -> Event (a, b), infixl 8 + -- lMerge, -- :: Event a -> Event a -> Event a, infixl 6 + -- rMerge, -- :: Event a -> Event a -> Event a, infixl 6 + -- merge, -- :: Event a -> Event a -> Event a, infixl 6 + -- mergeBy, -- :: (a -> a -> a) -> Event a -> Event a -> Event a + -- mapMerge, -- :: (a -> c) -> (b -> c) -> (a -> b -> c) + -- -- -> Event a -> Event b -> Event c + -- mergeEvents, -- :: [Event a] -> Event a + -- catEvents, -- :: [Event a] -> Event [a] + -- joinE, -- :: Event a -> Event b -> Event (a,b),infixl 7 + -- splitE, -- :: Event (a,b) -> (Event a, Event b) + -- filterE, -- :: (a -> Bool) -> Event a -> Event a + -- mapFilterE, -- :: (a -> Maybe b) -> Event a -> Event b + -- gate, -- :: Event a -> Bool -> Event a, infixl 8 + -- Event sources + snap, -- :: SF a (Event a) + snapAfter, -- :: Time -> SF a (Event a) + sample, -- :: Time -> SF a (Event a) + recur, -- :: SF a (Event b) -> SF a (Event b) + andThen -- :: SF a (Event b)->SF a (Event b)->SF a (Event b) + + + +) where + +import Control.Arrow + +import FRP.Yampa.InternalCore (SF(..), sfConst, Time, SF'(..)) + +import FRP.Yampa.Basic +import FRP.Yampa.Diagnostics +import FRP.Yampa.Event +import FRP.Yampa.Miscellany +import FRP.Yampa.Scan +import FRP.Yampa.Switches + + +infixr 5 `andThen` + +-- -- The event-processing function *could* accept the present NoEvent +-- -- output as an extra state argument. That would facilitate composition +-- -- of event-processing functions somewhat, but would presumably incur an +-- -- extra cost for the more common and simple case of non-composed event +-- -- processors. +-- +-- sfEP :: (c -> a -> (c, b, b)) -> c -> b -> SF' (Event a) b +-- sfEP f c bne = sf +-- where +-- sf = SFEP (\_ ea -> case ea of +-- NoEvent -> (sf, bne) +-- Event a -> let +-- (c', b, bne') = f c a +-- in +-- (sfEP f c' bne', b)) +-- f +-- c +-- bne +-- +-- +-- -- epPrim is used to define hold, accum, and other event-processing +-- -- functions. +-- epPrim :: (c -> a -> (c, b, b)) -> c -> b -> SF (Event a) b +-- epPrim f c bne = SF {sfTF = tf0} +-- where +-- tf0 NoEvent = (sfEP f c bne, bne) +-- tf0 (Event a) = let +-- (c', b, bne') = f c a +-- in +-- (sfEP f c' bne', b) + + +{- +-- !!! Maybe something like this? +-- !!! But one problem is that the invarying marking would be lost +-- !!! if the signal function is taken apart and re-constructed from +-- !!! the function description and subordinate signal function in +-- !!! cases like SFCpAXA. +sfMkInv :: SF a b -> SF a b +sfMkInv sf = SF {sfTF = ...} + + sfMkInvAux :: SF' a b -> SF' a b + sfMkInvAux sf@(SFArr _ _) = sf + -- sfMkInvAux sf@(SFAcc _ _ _ _) = sf + sfMkInvAux sf@(SFEP _ _ _ _) = sf + sfMkInvAux sf@(SFCpAXA tf inv fd1 sf2 fd3) + | inv = sf + | otherwise = SFCpAXA tf' True fd1 sf2 fd3 + where + tf' = \dt a -> let (sf', b) = tf dt a in (sfMkInvAux sf', b) + sfMkInvAux sf@(SF' tf inv) + | inv = sf + | otherwise = SF' tf' True + tf' = + +-} + +------------------------------------------------------------------------------ +-- Basic event sources +------------------------------------------------------------------------------ + +-- | Event source that never occurs. +{-# ANN never "HLint: ignore Use const" #-} +never :: SF a (Event b) +never = SF {sfTF = \_ -> (sfNever, NoEvent)} + +sfNever :: SF' a (Event b) +sfNever = sfConst 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 -- ^ The time /q/ after which the event should be produced + -> b -- ^ Value to produce at that time + -> SF a (Event b) +after q x = afterEach [(q,x)] + +-- | Event source with repeated occurrences with interval q. +-- Note: If the interval is too short w.r.t. the sampling intervals, +-- the result will be that events occur at every sample. However, no more +-- than one event results from any sampling interval, thus avoiding an +-- "event backlog" should sampling become more frequent at some later +-- point in time. + +-- !!! 2005-03-30: This is potentially a bit inefficient since we KNOW +-- !!! (at this level) that the SF is going to be invarying. But afterEach +-- !!! does NOT know this as the argument list may well be finite. +-- !!! We could use sfMkInv, but that's not without problems. +-- !!! We're probably better off specializing afterEachCat here. + +repeatedly :: Time -> b -> SF a (Event b) +repeatedly q x | q > 0 = afterEach qxs + | otherwise = usrErr "AFRP" "repeatedly" "Non-positive period." + where + qxs = (q,x):qxs + + +-- Event source with consecutive occurrences at the given intervals. +-- Should more than one event be scheduled to occur in any sampling interval, +-- only the first will in fact occur to avoid an event backlog. +-- Question: Should positive periods except for the first one be required? +-- Note that periods of length 0 will always be skipped except for the first. +-- Right now, periods of length 0 is allowed on the grounds that no attempt +-- is made to forbid simultaneous events elsewhere. +{- +afterEach :: [(Time,b)] -> SF a (Event b) +afterEach [] = never +afterEach ((q,x):qxs) + | q < 0 = usrErr "AFRP" "afterEach" "Negative period." + | otherwise = SF {sfTF = tf0} + where + tf0 _ = if q <= 0 then + (scheduleNextEvent 0.0 qxs, Event x) + else + (awaitNextEvent (-q) x qxs, NoEvent) + + scheduleNextEvent t [] = sfNever + scheduleNextEvent t ((q,x):qxs) + | q < 0 = usrErr "AFRP" "afterEach" "Negative period." + | t' >= 0 = scheduleNextEvent t' qxs + | otherwise = awaitNextEvent t' x qxs + where + t' = t - q + awaitNextEvent t x qxs = SF' {sfTF' = tf} + where + tf dt _ | t' >= 0 = (scheduleNextEvent t' qxs, Event x) + | otherwise = (awaitNextEvent t' x qxs, NoEvent) + where + t' = t + dt +-} + +-- | Event source with consecutive occurrences at the given intervals. +-- Should more than one event be scheduled to occur in any sampling interval, +-- only the first will in fact occur to avoid an event backlog. + +-- After all, after, repeatedly etc. are defined in terms of afterEach. +afterEach :: [(Time,b)] -> SF a (Event b) +afterEach qxs = afterEachCat qxs >>> arr (fmap head) + +-- | Event source with consecutive occurrences at the given intervals. +-- Should more than one event be scheduled to occur in any sampling interval, +-- the output list will contain all events produced during that interval. + +-- Guaranteed not to miss any events. +afterEachCat :: [(Time,b)] -> SF a (Event [b]) +afterEachCat [] = never +afterEachCat ((q,x):qxs) + | q < 0 = usrErr "AFRP" "afterEachCat" "Negative period." + | otherwise = SF {sfTF = tf0} + where + tf0 _ = if q <= 0 then + emitEventsScheduleNext 0.0 [x] qxs + else + (awaitNextEvent (-q) x qxs, NoEvent) + + emitEventsScheduleNext _ xs [] = (sfNever, Event (reverse xs)) + emitEventsScheduleNext t xs ((q,x):qxs) + | q < 0 = usrErr "AFRP" "afterEachCat" "Negative period." + | t' >= 0 = emitEventsScheduleNext t' (x:xs) qxs + | otherwise = (awaitNextEvent t' x qxs, Event (reverse xs)) + where + t' = t - q + awaitNextEvent t x qxs = SF' tf -- False + where + tf dt _ | t' >= 0 = emitEventsScheduleNext t' [x] qxs + | otherwise = (awaitNextEvent t' x qxs, NoEvent) + where + t' = t + dt + +-- | Delay for events. (Consider it a triggered after, hence /basic/.) + +-- Can be implemented fairly cheaply as long as the events are sparse. +-- It is a question of rescheduling events for later. Not unlike "afterEach". +-- +-- It is not exactly the case that delayEvent t = delay t NoEvent +-- since the rules for dropping/extrapolating samples are different. +-- A single event occurrence will never be duplicated. +-- If there is an event occurrence, one will be output as soon as +-- possible after the given delay time, but not necessarily that +-- one. See delayEventCat. + +delayEvent :: Time -> SF (Event a) (Event a) +delayEvent q | q < 0 = usrErr "AFRP" "delayEvent" "Negative delay." + | q == 0 = identity + | otherwise = delayEventCat q >>> arr (fmap head) + + +-- There is no *guarantee* above that every event actually will be +-- rescheduled since the sampling frequency (temporarily) might drop. +-- The following interface would allow ALL scheduled events to occur +-- as soon as possible: +-- (Read "delay event and catenate events that occur so closely so as to be +-- inseparable".) +-- The events in the list are ordered temporally to the extent possible. + +{- +-- This version is too strict! +delayEventCat :: Time -> SF (Event a) (Event [a]) +delayEventCat q | q < 0 = usrErr "AFRP" "delayEventCat" "Negative delay." + | q == 0 = arr (fmap (:[])) + | otherwise = SF {sfTF = tf0} + where + tf0 NoEvent = (noPendingEvent, NoEvent) + tf0 (Event x) = (pendingEvents (-q) [] [] (-q) x, NoEvent) + + noPendingEvent = SF' tf -- True + where + tf _ NoEvent = (noPendingEvent, NoEvent) + tf _ (Event x) = (pendingEvents (-q) [] [] (-q) x, NoEvent) + + -- t_next is the present time w.r.t. the next scheduled event. + -- t_last is the present time w.r.t. the last scheduled event. + -- In the event queues, events are associated with their time + -- w.r.t. to preceding event (positive). + pendingEvents t_last rqxs qxs t_next x = SF' tf -- True + where + tf dt NoEvent = tf1 (t_last + dt) rqxs (t_next + dt) + tf dt (Event x') = tf1 (-q) ((q', x') : rqxs) t_next' + where + t_next' = t_next + dt + t_last' = t_last + dt + q' = t_last' + q + + tf1 t_last' rqxs' t_next' + | t_next' >= 0 = + emitEventsScheduleNext t_last' rqxs' qxs t_next' [x] + | otherwise = + (pendingEvents t_last' rqxs' qxs t_next' x, NoEvent) + + -- t_next is the present time w.r.t. the *scheduled* time of the + -- event that is about to be emitted (i.e. >= 0). + -- The time associated with any event at the head of the event + -- queue is also given w.r.t. the event that is about to be emitted. + -- Thus, t_next - q' is the present time w.r.t. the event at the head + -- of the event queue. + emitEventsScheduleNext t_last [] [] t_next rxs = + (noPendingEvent, Event (reverse rxs)) + emitEventsScheduleNext t_last rqxs [] t_next rxs = + emitEventsScheduleNext t_last [] (reverse rqxs) t_next rxs + emitEventsScheduleNext t_last rqxs ((q', x') : qxs') t_next rxs + | q' > t_next = (pendingEvents t_last rqxs qxs' (t_next - q') x', + Event (reverse rxs)) + | otherwise = emitEventsScheduleNext t_last rqxs qxs' (t_next-q') + (x' : rxs) +-} + +-- | Delay an event by a given delta and catenate events that occur so closely +-- so as to be /inseparable/. +delayEventCat :: Time -> SF (Event a) (Event [a]) +delayEventCat q | q < 0 = usrErr "AFRP" "delayEventCat" "Negative delay." + | q == 0 = arr (fmap (:[])) + | otherwise = SF {sfTF = tf0} + where + tf0 e = (case e of + NoEvent -> noPendingEvent + Event x -> pendingEvents (-q) [] [] (-q) x, + NoEvent) + + noPendingEvent = SF' tf -- True + where + tf _ e = (case e of + NoEvent -> noPendingEvent + Event x -> pendingEvents (-q) [] [] (-q) x, + NoEvent) + + -- t_next is the present time w.r.t. the next scheduled event. + -- t_last is the present time w.r.t. the last scheduled event. + -- In the event queues, events are associated with their time + -- w.r.t. to preceding event (positive). + pendingEvents t_last rqxs qxs t_next x = SF' tf -- True + where + tf dt e + | t_next' >= 0 = + emitEventsScheduleNext e t_last' rqxs qxs t_next' [x] + | otherwise = + (pendingEvents t_last'' rqxs' qxs t_next' x, NoEvent) + where + t_next' = t_next + dt + t_last' = t_last + dt + (t_last'', rqxs') = + case e of + NoEvent -> (t_last', rqxs) + Event x' -> (-q, (t_last'+q,x') : rqxs) + + -- t_next is the present time w.r.t. the *scheduled* time of the + -- event that is about to be emitted (i.e. >= 0). + -- The time associated with any event at the head of the event + -- queue is also given w.r.t. the event that is about to be emitted. + -- Thus, t_next - q' is the present time w.r.t. the event at the head + -- of the event queue. + emitEventsScheduleNext e _ [] [] _ rxs = + (case e of + NoEvent -> noPendingEvent + Event x -> pendingEvents (-q) [] [] (-q) x, + Event (reverse rxs)) + emitEventsScheduleNext e t_last rqxs [] t_next rxs = + emitEventsScheduleNext e t_last [] (reverse rqxs) t_next rxs + emitEventsScheduleNext e t_last rqxs ((q', x') : qxs') t_next rxs + | q' > t_next = (case e of + NoEvent -> + pendingEvents t_last + rqxs + qxs' + (t_next - q') + x' + Event x'' -> + pendingEvents (-q) + ((t_last+q, x'') : rqxs) + qxs' + (t_next - q') + x', + Event (reverse rxs)) + | otherwise = emitEventsScheduleNext e + t_last + rqxs + qxs' + (t_next - q') + (x' : rxs) + + +-- | A rising edge detector. Useful for things like detecting key presses. +-- It is initialised as /up/, meaning that events occuring at time 0 will +-- not be detected. + +-- Note that we initialize the loop with state set to True so that there +-- will not be an occurence at t0 in the logical time frame in which +-- this is started. +edge :: SF Bool (Event ()) +edge = iEdge True + +-- | A rising edge detector that can be initialized as up ('True', meaning +-- that events occurring at time 0 will not be detected) or down +-- ('False', meaning that events ocurring at time 0 will be detected). +iEdge :: Bool -> SF Bool (Event ()) +-- iEdge i = edgeBy (isBoolRaisingEdge ()) i +iEdge b = sscanPrim f (if b then 2 else 0) NoEvent + where + f :: Int -> Bool -> Maybe (Int, Event ()) + f 0 False = Nothing + f 0 True = Just (1, Event ()) + f 1 False = Just (0, NoEvent) + f 1 True = Just (2, NoEvent) + f 2 False = Just (0, NoEvent) + f 2 True = Nothing + f _ _ = undefined + +-- | Like 'edge', but parameterized on the tag value. +edgeTag :: a -> SF Bool (Event a) +-- edgeTag a = edgeBy (isBoolRaisingEdge a) True +edgeTag a = edge >>> arr (`tag` a) + + +-- Internal utility. +-- isBoolRaisingEdge :: a -> Bool -> Bool -> Maybe a +-- isBoolRaisingEdge _ False False = Nothing +-- isBoolRaisingEdge a False True = Just a +-- isBoolRaisingEdge _ True True = Nothing +-- isBoolRaisingEdge _ True False = Nothing + + +-- | Edge detector particularized for detecting transtitions +-- on a 'Maybe' signal from 'Nothing' to 'Just'. + +-- !!! 2005-07-09: To be done or eliminated +-- !!! Maybe could be kept as is, but could be easy to implement directly +-- !!! in terms of sscan? +edgeJust :: SF (Maybe a) (Event a) +edgeJust = edgeBy isJustEdge (Just undefined) + where + isJustEdge Nothing Nothing = Nothing + isJustEdge Nothing ma@(Just _) = ma + isJustEdge (Just _) (Just _) = Nothing + isJustEdge (Just _) Nothing = Nothing + + +-- | Edge detector parameterized on the edge detection function and initial +-- state, i.e., the previous input sample. The first argument to the +-- edge detection function is the previous sample, the second the current one. + +-- !!! Is this broken!?! Does not disallow an edge condition that persists +-- !!! between consecutive samples. See discussion in ToDo list above. +-- !!! 2005-07-09: To be done. +edgeBy :: (a -> a -> Maybe b) -> a -> SF a (Event b) +edgeBy isEdge a_init = SF {sfTF = tf0} + where + tf0 a0 = (ebAux a0, maybeToEvent (isEdge a_init a0)) + + ebAux a_prev = SF' tf -- True + where + tf _ a = (ebAux a, maybeToEvent (isEdge a_prev a)) + + +------------------------------------------------------------------------------ +-- Stateful event suppression +------------------------------------------------------------------------------ + +-- | Suppression of initial (at local time 0) event. +notYet :: SF (Event a) (Event a) +notYet = initially NoEvent + + +-- | Suppress all but the first event. +once :: SF (Event a) (Event a) +once = takeEvents 1 + + +-- | Suppress all but the first n events. +takeEvents :: Int -> SF (Event a) (Event a) +takeEvents n | n <= 0 = never +takeEvents n = dSwitch (arr dup) (const (NoEvent >-- takeEvents (n - 1))) + + +{- +-- More complicated using "switch" that "dSwitch". +takeEvents :: Int -> SF (Event a) (Event a) +takeEvents 0 = never +takeEvents (n + 1) = switch (never &&& identity) (takeEvents' n) + where + takeEvents' 0 a = now a + takeEvents' (n + 1) a = switch (now a &&& notYet) (takeEvents' n) +-} + + +-- | Suppress first n events. + +-- Here dSwitch or switch does not really matter. +dropEvents :: Int -> SF (Event a) (Event a) +dropEvents n | n <= 0 = identity +dropEvents n = dSwitch (never &&& identity) + (const (NoEvent >-- dropEvents (n - 1))) + +-- Event source with a single occurrence at time 0. The value of the event +-- is obtained by sampling the input at that time. +-- (The outer "switch" ensures that the entire signal function will become +-- just "constant" once the sample has been taken.) +snap :: SF a (Event a) +snap = switch (never &&& (identity &&& now () >>^ \(a, e) -> e `tag` a)) now + + +-- Event source with a single occurrence at or as soon after (local) time t_ev +-- as possible. The value of the event is obtained by sampling the input a +-- that time. +snapAfter :: Time -> SF a (Event a) +snapAfter t_ev = switch (never + &&& (identity + &&& after t_ev () >>^ \(a, e) -> e `tag` a)) + now + + +-- Sample a signal at regular intervals. +sample :: Time -> SF a (Event a) +sample p_ev = identity &&& repeatedly p_ev () >>^ \(a, e) -> e `tag` a + + +-- Makes an event source recurring by restarting it as soon as it has an +-- occurrence. +-- !!! What about event sources that have an instantaneous occurrence? +-- !!! E.g. recur (now ()). +-- !!! Or worse, what about recur identity? (or substitute identity for +-- !!! a more sensible definition that e.g. merges any incoming event +-- !!! with an internally generated one, for example) +-- !!! Possibly we should ignore instantaneous reoccurrences. +-- New definition: +recur :: SF a (Event b) -> SF a (Event b) +recur sfe = switch (never &&& sfe) $ \b -> Event b --> (recur (NoEvent-->sfe)) + +andThen :: SF a (Event b) -> SF a (Event b) -> SF a (Event b) +sfe1 `andThen` sfe2 = dSwitch (sfe1 >>^ dup) (const sfe2) + +{- +recur :: SF a (Event b) -> SF a (Event b) +recur sfe = switch (never &&& sfe) recurAux + where + recurAux b = switch (now b &&& sfe) recurAux +-} + +-- Vim modeline +-- vim:set tabstop=8 expandtab: diff --git a/src/FRP/Yampa/Hybrid.hs b/src/FRP/Yampa/Hybrid.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa/Hybrid.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE GADTs, Rank2Types, CPP #-} +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.Hybrid +-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +----------------------------------------------------------------------------------------- + +module FRP.Yampa.Hybrid ( + + +-- * Discrete to continuous-time signal functions +-- ** Wave-form generation + hold, -- :: a -> SF (Event a) a + dHold, -- :: a -> SF (Event a) a + trackAndHold, -- :: a -> SF (Maybe a) a + dTrackAndHold, -- :: a -> SF (Maybe a) a + +-- ** Accumulators + accum, -- :: a -> SF (Event (a -> a)) (Event a) + accumHold, -- :: a -> SF (Event (a -> a)) a + dAccumHold, -- :: a -> SF (Event (a -> a)) a + accumBy, -- :: (b -> a -> b) -> b -> SF (Event a) (Event b) + accumHoldBy, -- :: (b -> a -> b) -> b -> SF (Event a) b + dAccumHoldBy, -- :: (b -> a -> b) -> b -> SF (Event a) b + accumFilter, -- :: (c -> a -> (c, Maybe b)) -> c + -- -> SF (Event a) (Event b) + +) where + +import Control.Arrow + +import FRP.Yampa.InternalCore (SF, epPrim) + +import FRP.Yampa.Delays +import FRP.Yampa.Event + +------------------------------------------------------------------------------ +-- Wave-form generation +------------------------------------------------------------------------------ + +-- | Zero-order hold. +hold :: a -> SF (Event a) a +hold a_init = epPrim f () a_init + where + f _ a = ((), a, a) + +-- !!! +-- !!! 2005-04-10: I DO NO LONGER THINK THIS IS CORRECT! +-- !!! CAN ONE POSSIBLY GET THE DESIRED STRICTNESS PROPERTIES +-- !!! ("DECOUPLING") this way??? +-- !!! Also applies to the other "d" functions that were tentatively +-- !!! defined using only epPrim. +-- !!! +-- !!! 2005-06-13: Yes, indeed wrong! (But it's subtle, one has to +-- !!! make sure that the incoming event (and not just the payload +-- !!! of the event) is control dependent on the output of "dHold" +-- !!! to observe it. +-- !!! +-- !!! 2005-06-09: But if iPre can be defined in terms of sscan, +-- !!! and ep + sscan = sscan, then things might work, and +-- !!! it might be possible to define dHold simply as hold >>> iPre +-- !!! without any performance penalty. + +-- | Zero-order hold with delay. +-- +-- Identity: dHold a0 = hold a0 >>> iPre a0). +dHold :: a -> SF (Event a) a +dHold a0 = hold a0 >>> iPre a0 +{- +-- THIS IS WRONG! SEE ABOVE. +dHold a_init = epPrim f a_init a_init + where + f a' a = (a, a', a) +-} + +-- | Tracks input signal when available, holds last value when disappears. +-- +-- !!! DANGER!!! Event used inside arr! Probably OK because arr will not be +-- !!! optimized to arrE. But still. Maybe rewrite this using, say, scan? +-- !!! or switch? Switching (in hold) for every input sample does not +-- !!! seem like such a great idea anyway. +trackAndHold :: a -> SF (Maybe a) a +trackAndHold a_init = arr (maybe NoEvent Event) >>> hold a_init + +dTrackAndHold :: a -> SF (Maybe a) a +dTrackAndHold a_init = trackAndHold a_init >>> iPre a_init + +------------------------------------------------------------------------------ +-- Accumulators +------------------------------------------------------------------------------ + +-- | Given an initial value in an accumulator, +-- it returns a signal function that processes +-- an event carrying transformation functions. +-- Every time an 'Event' is received, the function +-- inside it is applied to the accumulator, +-- whose new value is outputted in an 'Event'. +-- +accum :: a -> SF (Event (a -> a)) (Event a) +accum a_init = epPrim f a_init NoEvent + where + f a g = (a', Event a', NoEvent) -- Accumulator, output if Event, output if no event + where + a' = g a + + +-- | Zero-order hold accumulator (always produces the last outputted value +-- until an event arrives). +accumHold :: a -> SF (Event (a -> a)) a +accumHold a_init = epPrim f a_init a_init + where + f a g = (a', a', a') -- Accumulator, output if Event, output if no event + where + a' = g a + +-- | Zero-order hold accumulator with delayed initialization (always produces +-- the last outputted value until an event arrives, but the very initial output +-- is always the given accumulator). +dAccumHold :: a -> SF (Event (a -> a)) a +dAccumHold a_init = accumHold a_init >>> iPre a_init +{- +-- WRONG! +-- epPrim DOES and MUST patternmatch +-- on the input at every time step. +-- Test case to check for this added! +dAccumHold a_init = epPrim f a_init a_init + where + f a g = (a', a, a') + where + a' = g a +-} + + +-- | Accumulator parameterized by the accumulation function. +accumBy :: (b -> a -> b) -> b -> SF (Event a) (Event b) +accumBy g b_init = epPrim f b_init NoEvent + where + f b a = (b', Event b', NoEvent) + where + b' = g b a + +-- | Zero-order hold accumulator parameterized by the accumulation function. +accumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b +accumHoldBy g b_init = epPrim f b_init b_init + where + f b a = (b', b', b') + where + b' = g b a + +-- !!! This cannot be right since epPrim DOES and MUST patternmatch +-- !!! on the input at every time step. +-- !!! Add a test case to check for this! + +-- | Zero-order hold accumulator parameterized by the accumulation function +-- with delayed initialization (initial output sample is always the +-- given accumulator). +dAccumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b +dAccumHoldBy f a_init = accumHoldBy f a_init >>> iPre a_init +{- +-- WRONG! +-- epPrim DOES and MUST patternmatch +-- on the input at every time step. +-- Test case to check for this added! +dAccumHoldBy g b_init = epPrim f b_init b_init + where + f b a = (b', b, b') + where + b' = g b a +-} + + +{- Untested: + +accumBy f b = switch (never &&& identity) $ \a -> + let b' = f b a in NoEvent >-- Event b' --> accumBy f b' + +But no real improvement in clarity anyway. + +-} + +-- accumBy f b = accumFilter (\b -> a -> let b' = f b a in (b', Event b')) b + +{- +-- Identity: accumBy f = accumFilter (\b a -> let b' = f b a in (b',Just b')) +accumBy :: (b -> a -> b) -> b -> SF (Event a) (Event b) +accumBy f b_init = SF {sfTF = tf0} + where + tf0 NoEvent = (abAux b_init, NoEvent) + tf0 (Event a0) = let b' = f b_init a0 + in (abAux b', Event b') + + abAux b = SF' {sfTF' = tf} + where + tf _ NoEvent = (abAux b, NoEvent) + tf _ (Event a) = let b' = f b a + in (abAux b', Event b') +-} + +{- +accumFilter :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b) +accumFilter f c_init = SF {sfTF = tf0} + where + tf0 NoEvent = (afAux c_init, NoEvent) + tf0 (Event a0) = case f c_init a0 of + (c', Nothing) -> (afAux c', NoEvent) + (c', Just b0) -> (afAux c', Event b0) + + afAux c = SF' {sfTF' = tf} + where + tf _ NoEvent = (afAux c, NoEvent) + tf _ (Event a) = case f c a of + (c', Nothing) -> (afAux c', NoEvent) + (c', Just b) -> (afAux c', Event b) +-} + +-- | Accumulator parameterized by the accumulator function with filtering, +-- possibly discarding some of the input events based on whether the second +-- component of the result of applying the accumulation function is +-- 'Nothing' or 'Just' x for some x. +accumFilter :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b) +accumFilter g c_init = epPrim f c_init NoEvent + where + f c a = case g c a of + (c', Nothing) -> (c', NoEvent, NoEvent) + (c', Just b) -> (c', Event b, NoEvent) + + + +-- Vim modeline +-- vim:set tabstop=8 expandtab: diff --git a/src/FRP/Yampa/Integration.hs b/src/FRP/Yampa/Integration.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa/Integration.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE GADTs, Rank2Types, CPP #-} +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.Integration +-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +----------------------------------------------------------------------------------------- + +module FRP.Yampa.Integration ( + + -- * Integration + integral, -- :: (VectorSpace a, s ~ Scalar a, Fractional s) => SF a a + imIntegral, -- :: (VectorSpace a, s ~ Scalar a, Fractional s) => a -> SF a a + + -- * Differentiation + derivative, -- :: (VectorSpace a, s ~ Scalar a, Fractional s) => SF a a -- Crude! + + -- Temporarily hidden, but will eventually be made public. + -- iterFrom, -- :: (a -> a -> DTime -> b -> b) -> b -> SF a b + impulseIntegral, + count + +) where + +import Control.Arrow +import FRP.Yampa.Event +import FRP.Yampa.Hybrid +import FRP.Yampa.InternalCore (SF(..), SF'(..), DTime) +import Data.VectorSpace + +------------------------------------------------------------------------------ +-- Integration and differentiation +------------------------------------------------------------------------------ + +-- | Integration using the rectangle rule. +{-# INLINE integral #-} +integral :: (VectorSpace a, s ~ Scalar a, Fractional s) => SF a a +integral = SF {sfTF = tf0} + where + tf0 a0 = (integralAux igrl0 a0, igrl0) + + igrl0 = zeroV + + integralAux igrl a_prev = SF' tf -- True + where + tf dt a = (integralAux igrl' a, igrl') + where + igrl' = igrl ^+^ realToFrac dt *^ a_prev + + +-- | \"Immediate\" integration (using the function's value at the current time) +imIntegral :: (VectorSpace a, s ~ Scalar a, Fractional s) => a -> SF a a +imIntegral = ((\ _ a' dt v -> v ^+^ realToFrac dt *^ a') `iterFrom`) + +iterFrom :: (a -> a -> DTime -> b -> b) -> b -> SF a b +f `iterFrom` b = SF (iterAux b) + where + iterAux b a = (SF' (\ dt a' -> iterAux (f a a' dt b) a'), b) + +-- | A very crude version of a derivative. It simply divides the +-- value difference by the time difference. Use at your own risk. +derivative :: (VectorSpace a, s ~ Scalar a, Fractional s) => SF a a +derivative = SF {sfTF = tf0} + where + tf0 a0 = (derivativeAux a0, zeroV) + + derivativeAux a_prev = SF' tf -- True + where + tf dt a = (derivativeAux a, (a ^-^ a_prev) ^/ realToFrac dt) + +impulseIntegral :: (VectorSpace a, k ~ Scalar a, Fractional k) => SF (a, Event a) a +impulseIntegral = (integral *** accumHoldBy (^+^) zeroV) >>^ uncurry (^+^) + +count :: Integral b => SF (Event a) (Event b) +count = accumBy (\n _ -> n + 1) 0 + + +-- Vim modeline +-- vim:set tabstop=8 expandtab: diff --git a/src/FRP/Yampa/InternalCore.hs b/src/FRP/Yampa/InternalCore.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa/InternalCore.hs @@ -0,0 +1,1518 @@ +{-# LANGUAGE GADTs, Rank2Types, CPP #-} +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa +-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- +-- 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. +-- +-- You can find examples, tutorials and documentation on Yampa here: +-- +-- +-- +-- Structuring a hybrid system in Yampa is done based on two main concepts: +-- +-- * Signal Functions: 'SF'. Yampa is based on the concept of Signal Functions, +-- which are functions from a typed input signal to a typed output signal. +-- Conceptually, signals are functions from Time to Value, where time are the +-- real numbers and, computationally, a very dense approximation (Double) is +-- used. +-- +-- * Events: 'Event'. Values that may or may not occur (and would probably +-- occur rarely). It is often used for incoming network messages, mouse +-- clicks, etc. Events are used as values carried by signals. +-- +-- A complete Yampa system is defined as one Signal Function from some +-- type @a@ to a type @b@. The execution of this signal transformer +-- with specific input can be accomplished by means of two functions: +-- 'reactimate' (which needs an initialization action, +-- an input sensing action and an actuation/consumer action and executes +-- until explicitly stopped), and 'react' (which executes only one cycle). +-- +-- Apart from using normal functions and arrow syntax to define 'SF's, you +-- can also use several combinators. See [<#g:4>] for basic signals combinators, +-- [<#g:11>] for ways of switching from one signal transformation to another, +-- and [<#g:16>] for ways of transforming Event-carrying signals into continuous +-- signals, [<#g:19>] for ways of delaying signals, and [<#g:21>] for ways to +-- feed a signal back to the same signal transformer. +-- +-- Ways to define Event-carrying signals are given in [<#g:7>], and +-- "FRP.Yampa.Event" defines events and event-manipulation functions. +-- +-- Finally, see [<#g:26>] for sources of randomness (useful in games). +-- +-- CHANGELOG: +-- +-- * Adds (most) documentation. +-- +-- * New version using GADTs. +-- +-- ToDo: +-- +-- * Specialize def. of repeatedly. Could have an impact on invaders. +-- +-- * New defs for accs using SFAcc +-- +-- * Make sure opt worked: e.g. +-- +-- > repeatedly >>> count >>> arr (fmap sqr) +-- +-- * Introduce SFAccHld. +-- +-- * See if possible to unify AccHld wity Acc??? They are so close. +-- +-- * Introduce SScan. BUT KEEP IN MIND: Most if not all opts would +-- have been possible without GADTs??? +-- +-- * Look into pairs. At least pairing of SScan ought to be interesting. +-- +-- * Would be nice if we could get rid of first & second with impunity +-- thanks to Id optimizations. That's a clear win, with or without +-- an explicit pair combinator. +-- +-- * delayEventCat is a bit complicated ... +-- +-- +-- Random ideas: +-- +-- * What if one used rules to optimize +-- - (arr :: SF a ()) to (constant ()) +-- - (arr :: SF a a) to identity +-- But inspection of invader source code seem to indicate that +-- these are not very common cases at all. +-- +-- * It would be nice if it was possible to come up with opt. rules +-- that are invariant of how signal function expressions are +-- parenthesized. Right now, we have e.g. +-- arr f >>> (constant c >>> sf) +-- being optimized to +-- cpAuxA1 f (cpAuxC1 c sf) +-- whereas it clearly should be possible to optimize to just +-- cpAuxC1 c sf +-- What if we didn't use SF' but +-- SFComp :: -> SF' a b -> SF' b c -> SF' a c +-- ??? +-- +-- * The transition function would still be optimized in (pretty much) +-- the current way, but it would still be possible to look "inside" +-- composed signal functions for lost optimization opts. +-- Seems to me this could be done without too much extra effort/no dupl. +-- work. +-- E.g. new cpAux, the general case: +-- +-- @ +-- cpAux sf1 sf2 = SFComp tf sf1 sf2 +-- where +-- tf dt a = (cpAux sf1' sf2', c) +-- where +-- (sf1', b) = (sfTF' sf1) dt a +-- (sf2', c) = (sfTF' sf2) dt b +-- @ +-- +-- * The ONLY change was changing the constructor from SF' to SFComp and +-- adding sf1 and sf2 to the constructor app.! +-- +-- * An optimized case: +-- cpAuxC1 b sf1 sf2 = SFComp tf sf1 sf2 +-- So cpAuxC1 gets an extra arg, and we change the constructor. +-- But how to exploit without writing 1000s of rules??? +-- Maybe define predicates on SFComp to see if the first or second +-- sf are "interesting", and if so, make "reassociate" and make a +-- recursive call? E.g. we're in the arr case, and the first sf is another +-- arr, so we'd like to combine the two. +-- +-- * It would also be intersting, then, to know when to STOP playing this +-- game, due to the overhead involved. +-- +-- * Why don't we have a "SWITCH" constructor that indicates that the +-- structure will change, and thus that it is worthwile to keep +-- looking for opt. opportunities, whereas a plain "SF'" would +-- indicate that things NEVER are going to change, and thus we can just +-- as well give up? +----------------------------------------------------------------------------------------- + +module FRP.Yampa.InternalCore ( + module Control.Arrow, + -- SF is an instance of Arrow and ArrowLoop. Method instances: + -- arr :: (a -> b) -> SF a b + -- (>>>) :: SF a b -> SF b c -> SF a c + -- (<<<) :: SF b c -> SF a b -> SF a c + -- first :: SF a b -> SF (a,c) (b,c) + -- second :: SF a b -> SF (c,a) (c,b) + -- (***) :: SF a b -> SF a' b' -> SF (a,a') (b,b') + -- (&&&) :: SF a b -> SF a b' -> SF a (b,b') + -- returnA :: SF a a + -- loop :: SF (a,c) (b,c) -> SF a b + + -- * Basic definitions + -- ** Time + Time, -- [s] Both for time w.r.t. some reference and intervals. + DTime, -- [s] Sampling interval, always > 0. + + -- ** Signal Functions + SF(..), -- Signal Function. + + -- ** Future Signal Function + SF'(..), -- Signal Function. + sfTF', + sfId, + sfConst, + sfArrG, + + -- *** Scanning + sfSScan, + + Transition, + + -- ** Function descriptions + FunDesc(..), + fdFun, + + -- ** Lifting + arrPrim, + arrEPrim, -- For optimization + epPrim + +) where + +import Control.Arrow +#if __GLASGOW_HASKELL__ >= 610 +import qualified Control.Category (Category(..)) +#endif + +import FRP.Yampa.Diagnostics +import FRP.Yampa.Miscellany (dup) +import FRP.Yampa.Event + +------------------------------------------------------------------------------ +-- Basic type definitions with associated utilities +------------------------------------------------------------------------------ + +-- The time type is really a bit boguous, since, as time passes, the minimal +-- interval between two consecutive floating-point-represented time points +-- increases. A better approach might be to pick a reasonable resolution +-- and represent time and time intervals by Integer (giving the number of +-- "ticks"). +-- +-- That might also improve the timing of time-based event sources. +-- One might actually pick the overall resolution in reactimate, +-- to be passed down, possibly in the form of a global parameter +-- record, to all signal functions on initialization. (I think only +-- switch would need to remember the record, since it is the only place +-- where signal functions get started. So it wouldn't cost all that much. + + +-- | Time is used both for time intervals (duration), and time w.r.t. some +-- agreed reference point in time. + +-- Conceptually, Time = R, i.e. time can be 0 -- or even negative. +type Time = Double -- [s] + + +-- | DTime is the time type for lengths of sample intervals. Conceptually, +-- DTime = R+ = { x in R | x > 0 }. Don't assume Time and DTime have the +-- same representation. +type DTime = Double -- [s] + +-- Representation of signal function in initial state. +-- (Naming: "TF" stands for Transition Function.) + +-- | Signal function that transforms a signal carrying values of some type 'a' +-- into a signal carrying values of some type 'b'. You can think of it as +-- (Signal a -> Signal b). A signal is, conceptually, a +-- function from 'Time' to value. +data SF a b = SF {sfTF :: a -> Transition a b} + + +-- Representation of signal function in "running" state. +-- +-- Possibly better design for Inv. +-- Problem: tension between on the one hand making use of the +-- invariant property, and on the other keeping track of how something +-- has been constructed (SFCpAXA, in particular). +-- Idea: Add a boolean field to SFCpAXA and SF' that classifies +-- a signal function as being invarying. +-- A function sfIsInv computes to True for SFArr, SFAcc (and SFSScan, +-- possibly more), extracts the field in other cases. +-- +-- Motivation for using a function (Event a -> b) in SFArrE +-- rather than (a -> Event b) or (a -> b) or even (Event a -> Event b). +-- The result type should be just "b" as opposed to "Event b" for +-- increased flexibility (e.g. matching "routing functions"). +-- When the result type actually IS (Event b), and this fact is +-- exploitable, we'll be in a context where is it clear that +-- this is a fact, so we don't lose anything. +-- Since the idea is that the function is only going to be applied +-- when the there is an event, one could imagine the input type +-- just "a". But that's not the type of function we're given, +-- so it would have to be "massaged" a bit (precomposing with Event) +-- to fit. This will gain nothing, and potentially we will lose if +-- we actually need to recover the original function. +-- In fact, we sometimes really need to recover the original function +-- (e.g. currently in switch), and to do it correctly (also handling +-- NoEvent), we'd have to work quite hard introducing further +-- inefficiencies. +-- Summary: Make use of what we are given and only wrap things up later +-- when it is clear whatthe need is going to be, thus avoiding costly +-- "unwrapping". + +-- GADTs needed in particular for SFEP, but also e.g. SFSScan +-- exploits them since there are more type vars than in the type con. +-- But one could use existentials for those. + +data SF' a b where + SFArr :: !(DTime -> a -> Transition a b) -> !(FunDesc a b) -> SF' a b + -- The b is intentionally unstrict as the initial output sometimes + -- is undefined (e.g. when defining pre). In any case, it isn't + -- necessarily used and should thus not be forced. + SFSScan :: !(DTime -> a -> Transition a b) + -> !(c -> a -> Maybe (c, b)) -> !c -> b + -> SF' a b + SFEP :: !(DTime -> Event a -> Transition (Event a) b) + -> !(c -> a -> (c, b, b)) -> !c -> b + -> SF' (Event a) b + SFCpAXA :: !(DTime -> a -> Transition a d) + -> !(FunDesc a b) -> !(SF' b c) -> !(FunDesc c d) + -> SF' a d + -- SFPair :: ... + SF' :: !(DTime -> a -> Transition a b) -> SF' a b + +-- A transition is a pair of the next state (in the form of a signal +-- function) and the output at the present time step. + +type Transition a b = (SF' a b, b) + +sfTF' :: SF' a b -> (DTime -> a -> Transition a b) +sfTF' (SFArr tf _) = tf +sfTF' (SFSScan tf _ _ _) = tf +sfTF' (SFEP tf _ _ _) = tf +sfTF' (SFCpAXA tf _ _ _) = tf +sfTF' (SF' tf) = tf + + +-- !!! 2005-06-30 +-- Unclear why, but the isInv mechanism seems to do more +-- harm than good. +-- Disable completely and see what happens. +{- +sfIsInv :: SF' a b -> Bool +-- sfIsInv _ = False +sfIsInv (SFArr _ _) = True +-- sfIsInv (SFAcc _ _ _ _) = True +sfIsInv (SFEP _ _ _ _) = True +-- sfIsInv (SFSScan ...) = True +sfIsInv (SFCpAXA _ inv _ _ _) = inv +sfIsInv (SF' _ inv) = inv +-} + +-- "Smart" constructors. The corresponding "raw" constructors should not +-- be used directly for construction. + +sfArr :: FunDesc a b -> SF' a b +sfArr FDI = sfId +sfArr (FDC b) = sfConst b +sfArr (FDE f fne) = sfArrE f fne +sfArr (FDG f) = sfArrG f + + +sfId :: SF' a a +sfId = sf + where + sf = SFArr (\_ a -> (sf, a)) FDI + + +sfConst :: b -> SF' a b +sfConst b = sf + where + sf = SFArr (\_ _ -> (sf, b)) (FDC b) + +-- sfNever :: SF' a (Event b) +-- sfNever = sfConst NoEvent + +-- Assumption: fne = f NoEvent +sfArrE :: (Event a -> b) -> b -> SF' (Event a) b +sfArrE f fne = sf + where + sf = SFArr (\_ ea -> (sf, case ea of NoEvent -> fne ; _ -> f ea)) + (FDE f fne) + +sfArrG :: (a -> b) -> SF' a b +sfArrG f = sf + where + sf = SFArr (\_ a -> (sf, f a)) (FDG f) + + +-- epPrim is used to define hold, accum, and other event-processing +-- functions. +epPrim :: (c -> a -> (c, b, b)) -> c -> b -> SF (Event a) b +epPrim f c bne = SF {sfTF = tf0} + where + tf0 NoEvent = (sfEP f c bne, bne) + tf0 (Event a) = let + (c', b, bne') = f c a + in + (sfEP f c' bne', b) + +-- The event-processing function *could* accept the present NoEvent +-- output as an extra state argument. That would facilitate composition +-- of event-processing functions somewhat, but would presumably incur an +-- extra cost for the more common and simple case of non-composed event +-- processors. +-- +sfEP :: (c -> a -> (c, b, b)) -> c -> b -> SF' (Event a) b +sfEP f c bne = sf + where + sf = SFEP (\_ ea -> case ea of + NoEvent -> (sf, bne) + Event a -> let + (c', b, bne') = f c a + in + (sfEP f c' bne', b)) + f + c + bne + + +{- +-- !!! Maybe something like this? +-- !!! But one problem is that the invarying marking would be lost +-- !!! if the signal function is taken apart and re-constructed from +-- !!! the function description and subordinate signal function in +-- !!! cases like SFCpAXA. +sfMkInv :: SF a b -> SF a b +sfMkInv sf = SF {sfTF = ...} + + sfMkInvAux :: SF' a b -> SF' a b + sfMkInvAux sf@(SFArr _ _) = sf + -- sfMkInvAux sf@(SFAcc _ _ _ _) = sf + sfMkInvAux sf@(SFEP _ _ _ _) = sf + sfMkInvAux sf@(SFCpAXA tf inv fd1 sf2 fd3) + | inv = sf + | otherwise = SFCpAXA tf' True fd1 sf2 fd3 + where + tf' = \dt a -> let (sf', b) = tf dt a in (sfMkInvAux sf', b) + sfMkInvAux sf@(SF' tf inv) + | inv = sf + | otherwise = SF' tf' True + tf' = + +-} + +-- Motivation for event-processing function type +-- (alternative would be function of type a->b plus ensuring that it +-- only ever gets invoked on events): +-- * Now we need to be consistent with other kinds of arrows. +-- * We still want to be able to get hold of the original function. +-- 2005-02-30: OK, for FDE, invarant is that the field of type b = +-- f NoEvent. + +data FunDesc a b where + FDI :: FunDesc a a -- Identity function + FDC :: b -> FunDesc a b -- Constant function + FDE :: (Event a -> b) -> b -> FunDesc (Event a) b -- Event-processing fun + FDG :: (a -> b) -> FunDesc a b -- General function + +fdFun :: FunDesc a b -> (a -> b) +fdFun FDI = id +fdFun (FDC b) = const b +fdFun (FDE f _) = f +fdFun (FDG f) = f + +fdComp :: FunDesc a b -> FunDesc b c -> FunDesc a c +fdComp FDI fd2 = fd2 +fdComp fd1 FDI = fd1 +fdComp (FDC b) fd2 = FDC ((fdFun fd2) b) +fdComp _ (FDC c) = FDC c +-- Hardly worth the effort? +-- 2005-03-30: No, not only not worth the effort as the only thing saved +-- would be an application of f2. Also wrong since current invariant does +-- not imply that f1ne = NoEvent. Moreover, we cannot really adopt that +-- invariant as it is not totally impossible for a user to create a function +-- that breaks it. +-- fdComp (FDE f1 f1ne) (FDE f2 f2ne) = +-- FDE (f2 . f1) (vfyNoEvent (f1 NoEvent) f2ne) +fdComp (FDE f1 f1ne) fd2 = FDE (f2 . f1) (f2 f1ne) + where + f2 = fdFun fd2 +fdComp (FDG f1) (FDE f2 f2ne) = FDG f + where + f a = case f1 a of + NoEvent -> f2ne + f1a -> f2 f1a +fdComp (FDG f1) fd2 = FDG (fdFun fd2 . f1) + + +fdPar :: FunDesc a b -> FunDesc c d -> FunDesc (a,c) (b,d) +fdPar FDI FDI = FDI +fdPar FDI (FDC d) = FDG (\(~(a, _)) -> (a, d)) +fdPar FDI fd2 = FDG (\(~(a, c)) -> (a, (fdFun fd2) c)) +fdPar (FDC b) FDI = FDG (\(~(_, c)) -> (b, c)) +fdPar (FDC b) (FDC d) = FDC (b, d) +fdPar (FDC b) fd2 = FDG (\(~(_, c)) -> (b, (fdFun fd2) c)) +fdPar fd1 fd2 = FDG (\(~(a, c)) -> ((fdFun fd1) a, (fdFun fd2) c)) + + +fdFanOut :: FunDesc a b -> FunDesc a c -> FunDesc a (b,c) +fdFanOut FDI FDI = FDG dup +fdFanOut FDI (FDC c) = FDG (\a -> (a, c)) +fdFanOut FDI fd2 = FDG (\a -> (a, (fdFun fd2) a)) +fdFanOut (FDC b) FDI = FDG (\a -> (b, a)) +fdFanOut (FDC b) (FDC c) = FDC (b, c) +fdFanOut (FDC b) fd2 = FDG (\a -> (b, (fdFun fd2) a)) +fdFanOut (FDE f1 f1ne) (FDE f2 f2ne) = FDE f1f2 f1f2ne + where + f1f2 NoEvent = f1f2ne + f1f2 ea@(Event _) = (f1 ea, f2 ea) + + f1f2ne = (f1ne, f2ne) +fdFanOut fd1 fd2 = + FDG (\a -> ((fdFun fd1) a, (fdFun fd2) a)) + + +-- Verifies that the first argument is NoEvent. Returns the value of the +-- second argument that is the case. Raises an error otherwise. +-- Used to check that functions on events do not map NoEvent to Event +-- wherever that assumption is exploited. +vfyNoEv :: Event a -> b -> b +vfyNoEv NoEvent b = b +vfyNoEv _ _ = usrErr "AFRP" "vfyNoEv" "Assertion failed: Functions on events must not map NoEvent to Event." + + + +------------------------------------------------------------------------------ +-- Arrow instance and implementation +------------------------------------------------------------------------------ +#if __GLASGOW_HASKELL__ >= 610 +instance Control.Category.Category SF where + (.) = flip compPrim + id = SF $ \x -> (sfId,x) +#endif + +instance Arrow SF where + arr = arrPrim + first = firstPrim + second = secondPrim + (***) = parSplitPrim + (&&&) = parFanOutPrim + +#if __GLASGOW_HASKELL__ >= 610 +#else + (>>>) = compPrim +#endif + +-- * Lifting. + +-- | Lifts a pure function into a signal function (applied pointwise). +{-# NOINLINE arrPrim #-} +arrPrim :: (a -> b) -> SF a b +arrPrim f = SF {sfTF = \a -> (sfArrG f, f a)} + +-- | Lifts a pure function into a signal function applied to events +-- (applied pointwise). +{-# RULES "arrPrim/arrEPrim" arrPrim = arrEPrim #-} +arrEPrim :: (Event a -> b) -> SF (Event a) b +arrEPrim f = SF {sfTF = \a -> (sfArrE f (f NoEvent), f a)} + + +-- * Composition. +-- The definition exploits the following identities: +-- sf >>> identity = sf -- New +-- identity >>> sf = sf -- New +-- sf >>> constant c = constant c +-- constant c >>> arr f = constant (f c) +-- arr f >>> arr g = arr (g . f) +-- +-- !!! Notes/Questions: +-- !!! How do we know that the optimizations terminate? +-- !!! Probably by some kind of size argument on the SF tree. +-- !!! E.g. (Hopefully) all compPrim optimizations are such that +-- !!! the number of compose nodes decrease. +-- !!! Should verify this! +-- +-- !!! There is a tension between using SFInv to signal to superior +-- !!! signal functions that the subordinate signal function will not +-- !!! change form, and using SFCpAXA to allow fusion in the context +-- !!! of some suitable superior signal function. +compPrim :: SF a b -> SF b c -> SF a c +compPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0} + where + tf0 a0 = (cpXX sf1 sf2, c0) + where + (sf1, b0) = tf10 a0 + (sf2, c0) = tf20 b0 + +-- The following defs are not local to compPrim because cpAXA needs to be +-- called from parSplitPrim. +-- Naming convention: cp where and is one of: +-- X - arbitrary signal function +-- A - arbitrary pure arrow +-- C - constant arrow +-- E - event-processing arrow +-- G - arrow known not to be identity, constant (C) or +-- event-processing (E). + +cpXX :: SF' a b -> SF' b c -> SF' a c +cpXX (SFArr _ fd1) sf2 = cpAX fd1 sf2 +cpXX sf1 (SFArr _ fd2) = cpXA sf1 fd2 +{- +-- !!! 2005-07-07: Too strict. +-- !!! But the question is if it is worth to define pre in terms of sscan ... +-- !!! It is slower than the simplest possible pre, and the kind of coding +-- !!! required to ensure that the laziness props of the second SF are +-- !!! preserved might just slow things down further ... +cpXX (SFSScan _ f1 s1 b) (SFSScan _ f2 s2 c) = + sfSScan f (s1, b, s2, c) c + where + f (s1, b, s2, c) a = + case f1 s1 a of + Nothing -> + case f2 s2 b of + Nothing -> Nothing + Just (s2', c') -> Just ((s1, b, s2', c'), c') + Just (s1', b') -> + case f2 s2 b' of + Nothing -> Just ((s1', b', s2, c), c) + Just (s2', c') -> Just ((s1', b', s2', c'), c') +-} +-- !!! 2005-07-07: Indeed, this is a bit slower than the code above (14%). +-- !!! But both are better than not composing (35% faster and 26% faster)! +cpXX (SFSScan _ f1 s1 b) (SFSScan _ f2 s2 c) = + sfSScan f (s1, b, s2, c) c + where + f (s1, b, s2, c) a = + let + (u, s1', b') = case f1 s1 a of + Nothing -> (True, s1, b) + Just (s1',b') -> (False, s1', b') + in + case f2 s2 b' of + Nothing | u -> Nothing + | otherwise -> Just ((s1', b', s2, c), c) + Just (s2', c') -> Just ((s1', b', s2', c'), c') +cpXX (SFSScan _ f1 s1 eb) (SFEP _ f2 s2 cne) = + sfSScan f (s1, eb, s2, cne) cne + where + f (s1, eb, s2, cne) a = + case f1 s1 a of + Nothing -> + case eb of + NoEvent -> Nothing + Event b -> + let (s2', c, cne') = f2 s2 b + in + Just ((s1, eb, s2', cne'), c) + Just (s1', eb') -> + case eb' of + NoEvent -> Just ((s1', eb', s2, cne), cne) + Event b -> + let (s2', c, cne') = f2 s2 b + in + Just ((s1', eb', s2', cne'), c) +-- !!! 2005-07-09: This seems to yield only a VERY marginal speedup +-- !!! without seq. With seq, substantial speedup! +cpXX (SFEP _ f1 s1 bne) (SFSScan _ f2 s2 c) = + sfSScan f (s1, bne, s2, c) c + where + f (s1, bne, s2, c) ea = + let (u, s1', b', bne') = case ea of + NoEvent -> (True, s1, bne, bne) + Event a -> + let (s1', b, bne') = f1 s1 a + in + (False, s1', b, bne') + in + case f2 s2 b' of + Nothing | u -> Nothing + | otherwise -> Just (seq s1' (s1', bne', s2, c), c) + Just (s2', c') -> Just (seq s1' (s1', bne', s2', c'), c') +-- The function "f" is invoked whenever an event is to be processed. It then +-- computes the output, the new state, and the new NoEvent output. +-- However, when sequencing event processors, the ones in the latter +-- part of the chain may not get invoked since previous ones may +-- decide not to "fire". But a "new" NoEvent output still has to be +-- produced, i.e. the old one retained. Since it cannot be computed by +-- invoking the last event-processing function in the chain, it has to +-- be remembered. Since the composite event-processing function remains +-- constant/unchanged, the NoEvent output has to be part of the state. +-- An alternarive would be to make the event-processing function take an +-- extra argument. But that is likely to make the simple case more +-- expensive. See note at sfEP. +cpXX (SFEP _ f1 s1 bne) (SFEP _ f2 s2 cne) = + sfEP f (s1, s2, cne) (vfyNoEv bne cne) + where + f (s1, s2, cne) a = + case f1 s1 a of + (s1', NoEvent, NoEvent) -> ((s1', s2, cne), cne, cne) + (s1', Event b, NoEvent) -> + let (s2', c, cne') = f2 s2 b in ((s1', s2', cne'), c, cne') + _ -> usrErr "AFRP" "cpXX" "Assertion failed: Functions on events must not map NoEvent to Event." +-- !!! 2005-06-28: Why isn't SFCpAXA (FDC ...) checked for? +-- !!! No invariant rules that out, and it would allow to drop the +-- !!! event processor ... Does that happen elsewhere? +cpXX sf1@(SFEP{}) (SFCpAXA _ (FDE f21 f21ne) sf22 fd23) = + cpXX (cpXE sf1 f21 f21ne) (cpXA sf22 fd23) +-- f21 will (hopefully) be invoked less frequently if merged with the +-- event processor. +cpXX sf1@(SFEP{}) (SFCpAXA _ (FDG f21) sf22 fd23) = + cpXX (cpXG sf1 f21) (cpXA sf22 fd23) +-- Only functions whose domain is known to be Event can be merged +-- from the left with event processors. +cpXX (SFCpAXA _ fd11 sf12 (FDE f13 f13ne)) sf2@(SFEP{}) = + cpXX (cpAX fd11 sf12) (cpEX f13 f13ne sf2) +-- !!! Other cases to look out for: +-- !!! any sf >>> SFCpAXA = SFCpAXA if first arr is const. +-- !!! But the following will presumably not work due to type restrictions. +-- !!! Need to reconstruct sf2 I think. +-- cpXX sf1 sf2@(SFCpAXA _ _ (FDC b) sf22 fd23) = sf2 +cpXX (SFCpAXA _ fd11 sf12 fd13) (SFCpAXA _ fd21 sf22 fd23) = + -- Termination: The first argument to cpXX is no larger than + -- the current first argument, and the second is smaller. + cpAXA fd11 (cpXX (cpXA sf12 (fdComp fd13 fd21)) sf22) fd23 +-- !!! 2005-06-27: The if below accounts for a significant slowdown. +-- !!! One would really like a cheme where opts only take place +-- !!! after a structural change ... +-- cpXX sf1 sf2 = cpXXInv sf1 sf2 +-- cpXX sf1 sf2 = cpXXAux sf1 sf2 +cpXX sf1 sf2 = SF' tf -- False + -- if sfIsInv sf1 && sfIsInv sf2 then cpXXInv sf1 sf2 else SF' tf False + where + tf dt a = (cpXX sf1' sf2', c) + where + (sf1', b) = (sfTF' sf1) dt a + (sf2', c) = (sfTF' sf2) dt b + + +{- +cpXXAux sf1@(SF' _ _) sf2@(SF' _ _) = SF' tf False + where + tf dt a = (cpXXAux sf1' sf2', c) + where + (sf1', b) = (sfTF' sf1) dt a + (sf2', c) = (sfTF' sf2) dt b +cpXXAux sf1 sf2 = SF' tf False + where + tf dt a = (cpXXAux sf1' sf2', c) + where + (sf1', b) = (sfTF' sf1) dt a + (sf2', c) = (sfTF' sf2) dt b +-} + +{- +cpXXAux sf1 sf2 | unsimplifiable sf1 sf2 = SF' tf False + | otherwise = cpXX sf1 sf2 + where + tf dt a = (cpXXAux sf1' sf2', c) + where + (sf1', b) = (sfTF' sf1) dt a + (sf2', c) = (sfTF' sf2) dt b + + unsimplifiable sf1@(SF' _ _) sf2@(SF' _ _) = True + unsimplifiable sf1 sf2 = True +-} + +{- +-- wrong ... +cpXXAux sf1@(SF' _ False) sf2 = SF' tf False +cpXXAux sf1@(SFCpAXA _ False _ _ _) sf2 = SF' tf False +cpXXAux sf1 sf2@(SF' _ False) = SF' tf False +cpXXAux sf1 sf2@(SFCpAXA _ False _ _ _) = SF' tf False +cpXXAux sf1 sf2 = + if sfIsInv sf1 && sfIsInv sf2 then cpXXInv sf1 sf2 else SF' tf False + where + tf dt a = (cpXXAux sf1' sf2', c) + where + (sf1', b) = (sfTF' sf1) dt a + (sf2', c) = (sfTF' sf2) dt b +-} + +{- +cpXXInv sf1 sf2 = SF' tf True + where + tf dt a = sf1 `seq` sf2 `seq` (cpXXInv sf1' sf2', c) + where + (sf1', b) = (sfTF' sf1) dt a + (sf2', c) = (sfTF' sf2) dt b +-} + +-- !!! No. We need local defs. Keep fd1 and fd2. Extract f1 and f2 +-- !!! once and fo all. Get rid of FDI and FDC at the top level. +-- !!! First local def. analyse sf2. SFArr, SFAcc etc. tf in +-- !!! recursive case just make use of f1 and f3. +-- !!! if sf2 is SFInv, that's delegated to a second local +-- !!! recursive def. that does not analyse sf2. + +cpAXA :: FunDesc a b -> SF' b c -> FunDesc c d -> SF' a d +-- Termination: cpAX/cpXA, via cpCX, cpEX etc. only call cpAXA if sf2 +-- is SFCpAXA, and then on the embedded sf and hence on a smaller arg. +cpAXA FDI sf2 fd3 = cpXA sf2 fd3 +cpAXA fd1 sf2 FDI = cpAX fd1 sf2 +cpAXA (FDC b) sf2 fd3 = cpCXA b sf2 fd3 +cpAXA _ _ (FDC d) = sfConst d +cpAXA fd1 sf2 fd3 = + cpAXAAux fd1 (fdFun fd1) fd3 (fdFun fd3) sf2 + where + -- Really: cpAXAAux :: SF' b c -> SF' a d + -- Note: Event cases are not optimized (EXA etc.) + cpAXAAux :: FunDesc a b -> (a -> b) -> FunDesc c d -> (c -> d) + -> SF' b c -> SF' a d + cpAXAAux fd1 _ fd3 _ (SFArr _ fd2) = + sfArr (fdComp (fdComp fd1 fd2) fd3) + cpAXAAux fd1 _ fd3 _ sf2@(SFSScan {}) = + cpAX fd1 (cpXA sf2 fd3) + cpAXAAux fd1 _ fd3 _ sf2@(SFEP {}) = + cpAX fd1 (cpXA sf2 fd3) + cpAXAAux fd1 _ fd3 _ (SFCpAXA _ fd21 sf22 fd23) = + cpAXA (fdComp fd1 fd21) sf22 (fdComp fd23 fd3) + cpAXAAux fd1 f1 fd3 f3 sf2 = SFCpAXA tf fd1 sf2 fd3 +{- + if sfIsInv sf2 then + cpAXAInv fd1 f1 fd3 f3 sf2 + else + SFCpAXA tf False fd1 sf2 fd3 +-} + where + tf dt a = (cpAXAAux fd1 f1 fd3 f3 sf2', f3 c) + where + (sf2', c) = (sfTF' sf2) dt (f1 a) + +{- + cpAXAInv fd1 f1 fd3 f3 sf2 = SFCpAXA tf True fd1 sf2 fd3 + where + tf dt a = sf2 `seq` (cpAXAInv fd1 f1 fd3 f3 sf2', f3 c) + where + (sf2', c) = (sfTF' sf2) dt (f1 a) +-} + +cpAX :: FunDesc a b -> SF' b c -> SF' a c +cpAX FDI sf2 = sf2 +cpAX (FDC b) sf2 = cpCX b sf2 +cpAX (FDE f1 f1ne) sf2 = cpEX f1 f1ne sf2 +cpAX (FDG f1) sf2 = cpGX f1 sf2 + +cpXA :: SF' a b -> FunDesc b c -> SF' a c +cpXA sf1 FDI = sf1 +cpXA _ (FDC c) = sfConst c +cpXA sf1 (FDE f2 f2ne) = cpXE sf1 f2 f2ne +cpXA sf1 (FDG f2) = cpXG sf1 f2 + +-- Don't forget that the remaining signal function, if it is +-- SF', later could turn into something else, like SFId. +cpCX :: b -> SF' b c -> SF' a c +cpCX b (SFArr _ fd2) = sfConst ((fdFun fd2) b) +-- 2005-07-01: If we were serious about the semantics of sscan being required +-- to be independent of the sampling interval, I guess one could argue for a +-- fixed-point computation here ... Or maybe not. +-- cpCX b (SFSScan _ _ _ _) = sfConst +cpCX b (SFSScan _ f s c) = sfSScan (\s _ -> f s b) s c +cpCX b (SFEP _ _ _ cne) = sfConst (vfyNoEv b cne) +cpCX b (SFCpAXA _ fd21 sf22 fd23) = + cpCXA ((fdFun fd21) b) sf22 fd23 +cpCX b sf2 = SFCpAXA tf (FDC b) sf2 FDI +{- + if sfIsInv sf2 then + cpCXInv b sf2 + else + SFCpAXA tf False (FDC b) sf2 FDI +-} + where + tf dt _ = (cpCX b sf2', c) + where + (sf2', c) = (sfTF' sf2) dt b + + +{- +cpCXInv b sf2 = SFCpAXA tf True (FDC b) sf2 FDI + where + tf dt _ = sf2 `seq` (cpCXInv b sf2', c) + where + (sf2', c) = (sfTF' sf2) dt b +-} + + +cpCXA :: b -> SF' b c -> FunDesc c d -> SF' a d +cpCXA b sf2 FDI = cpCX b sf2 +cpCXA _ _ (FDC c) = sfConst c +cpCXA b sf2 fd3 = cpCXAAux (FDC b) b fd3 (fdFun fd3) sf2 + where + -- fd1 = FDC b + -- f3 = fdFun fd3 + + -- Really: SF' b c -> SF' a d + cpCXAAux :: FunDesc a b -> b -> FunDesc c d -> (c -> d) + -> SF' b c -> SF' a d + cpCXAAux _ b _ f3 (SFArr _ fd2) = sfConst (f3 ((fdFun fd2) b)) + cpCXAAux _ b _ f3 (SFSScan _ f s c) = sfSScan f' s (f3 c) + where + f' s _ = case f s b of + Nothing -> Nothing + Just (s', c') -> Just (s', f3 c') + cpCXAAux _ b _ f3 (SFEP _ _ _ cne) = sfConst (f3 (vfyNoEv b cne)) + cpCXAAux _ b fd3 _ (SFCpAXA _ fd21 sf22 fd23) = + cpCXA ((fdFun fd21) b) sf22 (fdComp fd23 fd3) + cpCXAAux fd1 b fd3 f3 sf2 = SFCpAXA tf fd1 sf2 fd3 +{- + if sfIsInv sf2 then + cpCXAInv fd1 b fd3 f3 sf2 + else + SFCpAXA tf False fd1 sf2 fd3 +-} + where + tf dt _ = (cpCXAAux fd1 b fd3 f3 sf2', f3 c) + where + (sf2', c) = (sfTF' sf2) dt b + +{- + -- For some reason, seq on sf2' in tf is faster than making + -- cpCXAInv strict in sf2 by seq-ing on the top level (which would + -- be similar to pattern matching on sf2). + cpCXAInv fd1 b fd3 f3 sf2 = SFCpAXA tf True fd1 sf2 fd3 + where + tf dt _ = sf2 `seq` (cpCXAInv fd1 b fd3 f3 sf2', f3 c) + where + (sf2', c) = (sfTF' sf2) dt b +-} + + +cpGX :: (a -> b) -> SF' b c -> SF' a c +cpGX f1 sf2 = cpGXAux (FDG f1) f1 sf2 + where + cpGXAux :: FunDesc a b -> (a -> b) -> SF' b c -> SF' a c + cpGXAux fd1 _ (SFArr _ fd2) = sfArr (fdComp fd1 fd2) + -- We actually do know that (fdComp (FDG f1) fd21) is going to + -- result in an FDG. So we *could* call a cpGXA here. But the + -- price is "inlining" of part of fdComp. + cpGXAux _ f1 (SFSScan _ f s c) = sfSScan (\s a -> f s (f1 a)) s c + -- We really shouldn't see an EP here, as that would mean + -- an arrow INTRODUCING events ... + cpGXAux fd1 _ (SFCpAXA _ fd21 sf22 fd23) = + cpAXA (fdComp fd1 fd21) sf22 fd23 + cpGXAux fd1 f1 sf2 = SFCpAXA tf fd1 sf2 FDI +{- + if sfIsInv sf2 then + cpGXInv fd1 f1 sf2 + else + SFCpAXA tf False fd1 sf2 FDI +-} + where + tf dt a = (cpGXAux fd1 f1 sf2', c) + where + (sf2', c) = (sfTF' sf2) dt (f1 a) + +{- + cpGXInv fd1 f1 sf2 = SFCpAXA tf True fd1 sf2 FDI + where + tf dt a = sf2 `seq` (cpGXInv fd1 f1 sf2', c) + where + (sf2', c) = (sfTF' sf2) dt (f1 a) +-} + + +cpXG :: SF' a b -> (b -> c) -> SF' a c +cpXG sf1 f2 = cpXGAux (FDG f2) f2 sf1 + where + -- Really: cpXGAux :: SF' a b -> SF' a c + cpXGAux :: FunDesc b c -> (b -> c) -> SF' a b -> SF' a c + cpXGAux fd2 _ (SFArr _ fd1) = sfArr (fdComp fd1 fd2) + cpXGAux _ f2 (SFSScan _ f s b) = sfSScan f' s (f2 b) + where + f' s a = case f s a of + Nothing -> Nothing + Just (s', b') -> Just (s', f2 b') + cpXGAux _ f2 (SFEP _ f1 s bne) = sfEP f s (f2 bne) + where + f s a = let (s', b, bne') = f1 s a in (s', f2 b, f2 bne') + cpXGAux fd2 _ (SFCpAXA _ fd11 sf12 fd22) = + cpAXA fd11 sf12 (fdComp fd22 fd2) + cpXGAux fd2 f2 sf1 = SFCpAXA tf FDI sf1 fd2 +{- + if sfIsInv sf1 then + cpXGInv fd2 f2 sf1 + else + SFCpAXA tf False FDI sf1 fd2 +-} + where + tf dt a = (cpXGAux fd2 f2 sf1', f2 b) + where + (sf1', b) = (sfTF' sf1) dt a + +{- + cpXGInv fd2 f2 sf1 = SFCpAXA tf True FDI sf1 fd2 + where + tf dt a = (cpXGInv fd2 f2 sf1', f2 b) + where + (sf1', b) = (sfTF' sf1) dt a +-} + +cpEX :: (Event a -> b) -> b -> SF' b c -> SF' (Event a) c +cpEX f1 f1ne sf2 = cpEXAux (FDE f1 f1ne) f1 f1ne sf2 + where + cpEXAux :: FunDesc (Event a) b -> (Event a -> b) -> b + -> SF' b c -> SF' (Event a) c + cpEXAux fd1 _ _ (SFArr _ fd2) = sfArr (fdComp fd1 fd2) + cpEXAux _ f1 _ (SFSScan _ f s c) = sfSScan (\s a -> f s (f1 a)) s c + -- We must not capture cne in the f closure since cne can change! + -- See cpXX the SFEP/SFEP case for a similar situation. However, + -- FDE represent a state-less signal function, so *its* NoEvent + -- value never changes. Hence we only need to verify that it is + -- NoEvent once. + cpEXAux _ f1 f1ne (SFEP _ f2 s cne) = + sfEP f (s, cne) (vfyNoEv f1ne cne) + where + f scne@(s, cne) a = + case f1 (Event a) of + NoEvent -> (scne, cne, cne) + Event b -> + let (s', c, cne') = f2 s b in ((s', cne'), c, cne') + cpEXAux fd1 _ _ (SFCpAXA _ fd21 sf22 fd23) = + cpAXA (fdComp fd1 fd21) sf22 fd23 + -- The rationale for the following is that the case analysis + -- is typically not going to be more expensive than applying + -- the function and possibly a bit cheaper. Thus if events + -- are sparse, we might win, and if not, we don't loose to + -- much. + cpEXAux fd1 f1 f1ne sf2 = SFCpAXA tf fd1 sf2 FDI +{- + if sfIsInv sf2 then + cpEXInv fd1 f1 f1ne sf2 + else + SFCpAXA tf False fd1 sf2 FDI +-} + where + tf dt ea = (cpEXAux fd1 f1 f1ne sf2', c) + where + (sf2', c) = + case ea of + NoEvent -> (sfTF' sf2) dt f1ne + _ -> (sfTF' sf2) dt (f1 ea) + +{- + cpEXInv fd1 f1 f1ne sf2 = SFCpAXA tf True fd1 sf2 FDI + where + tf dt ea = sf2 `seq` (cpEXInv fd1 f1 f1ne sf2', c) + where + (sf2', c) = + case ea of + NoEvent -> (sfTF' sf2) dt f1ne + _ -> (sfTF' sf2) dt (f1 ea) +-} + +cpXE :: SF' a (Event b) -> (Event b -> c) -> c -> SF' a c +cpXE sf1 f2 f2ne = cpXEAux (FDE f2 f2ne) f2 f2ne sf1 + where + cpXEAux :: FunDesc (Event b) c -> (Event b -> c) -> c + -> SF' a (Event b) -> SF' a c + cpXEAux fd2 _ _ (SFArr _ fd1) = sfArr (fdComp fd1 fd2) + cpXEAux _ f2 f2ne (SFSScan _ f s eb) = sfSScan f' s (f2 eb) + where + f' s a = case f s a of + Nothing -> Nothing + Just (s', NoEvent) -> Just (s', f2ne) + Just (s', eb') -> Just (s', f2 eb') + cpXEAux _ f2 f2ne (SFEP _ f1 s ebne) = + sfEP f s (vfyNoEv ebne f2ne) + where + f s a = + case f1 s a of + (s', NoEvent, NoEvent) -> (s', f2ne, f2ne) + (s', eb, NoEvent) -> (s', f2 eb, f2ne) + _ -> usrErr "AFRP" "cpXEAux" "Assertion failed: Functions on events must not map NoEvent to Event." + cpXEAux fd2 _ _ (SFCpAXA _ fd11 sf12 fd13) = + cpAXA fd11 sf12 (fdComp fd13 fd2) + cpXEAux fd2 f2 f2ne sf1 = SFCpAXA tf FDI sf1 fd2 +{- + if sfIsInv sf1 then + cpXEInv fd2 f2 f2ne sf1 + else + SFCpAXA tf False FDI sf1 fd2 +-} + where + tf dt a = (cpXEAux fd2 f2 f2ne sf1', + case eb of NoEvent -> f2ne; _ -> f2 eb) + where + (sf1', eb) = (sfTF' sf1) dt a + +{- + cpXEInv fd2 f2 f2ne sf1 = SFCpAXA tf True FDI sf1 fd2 + where + tf dt a = sf1 `seq` (cpXEInv fd2 f2 f2ne sf1', + case eb of NoEvent -> f2ne; _ -> f2 eb) + where + (sf1', eb) = (sfTF' sf1) dt a +-} + + +-- * Widening. +-- The definition exploits the following identities: +-- first identity = identity -- New +-- first (constant b) = arr (\(_, c) -> (b, c)) +-- (first (arr f)) = arr (\(a, c) -> (f a, c)) +firstPrim :: SF a b -> SF (a,c) (b,c) +firstPrim (SF {sfTF = tf10}) = SF {sfTF = tf0} + where + tf0 ~(a0, c0) = (fpAux sf1, (b0, c0)) + where + (sf1, b0) = tf10 a0 + + +-- Also used in parSplitPrim +fpAux :: SF' a b -> SF' (a,c) (b,c) +fpAux (SFArr _ FDI) = sfId -- New +fpAux (SFArr _ (FDC b)) = sfArrG (\(~(_, c)) -> (b, c)) +fpAux (SFArr _ fd1) = sfArrG (\(~(a, c)) -> ((fdFun fd1) a, c)) +fpAux sf1 = SF' tf + -- if sfIsInv sf1 then fpInv sf1 else SF' tf False + where + tf dt ~(a, c) = (fpAux sf1', (b, c)) + where + (sf1', b) = (sfTF' sf1) dt a + + +{- +fpInv :: SF' a b -> SF' (a,c) (b,c) +fpInv sf1 = SF' tf True + where + tf dt ~(a, c) = sf1 `seq` (fpInv sf1', (b, c)) + where + (sf1', b) = (sfTF' sf1) dt a +-} + + +-- Mirror image of first. +secondPrim :: SF a b -> SF (c,a) (c,b) +secondPrim (SF {sfTF = tf10}) = SF {sfTF = tf0} + where + tf0 ~(c0, a0) = (spAux sf1, (c0, b0)) + where + (sf1, b0) = tf10 a0 + + +-- Also used in parSplitPrim +spAux :: SF' a b -> SF' (c,a) (c,b) +spAux (SFArr _ FDI) = sfId -- New +spAux (SFArr _ (FDC b)) = sfArrG (\(~(c, _)) -> (c, b)) +spAux (SFArr _ fd1) = sfArrG (\(~(c, a)) -> (c, (fdFun fd1) a)) +spAux sf1 = SF' tf + -- if sfIsInv sf1 then spInv sf1 else SF' tf False + where + tf dt ~(c, a) = (spAux sf1', (c, b)) + where + (sf1', b) = (sfTF' sf1) dt a + + +{- +spInv :: SF' a b -> SF' (c,a) (c,b) +spInv sf1 = SF' tf True + where + tf dt ~(c, a) = sf1 `seq` (spInv sf1', (c, b)) + where + (sf1', b) = (sfTF' sf1) dt a +-} + + +-- * Parallel composition. +-- The definition exploits the following identities (that hold for SF): +-- identity *** identity = identity -- New +-- sf *** identity = first sf -- New +-- identity *** sf = second sf -- New +-- constant b *** constant d = constant (b, d) +-- constant b *** arr f2 = arr (\(_, c) -> (b, f2 c) +-- arr f1 *** constant d = arr (\(a, _) -> (f1 a, d) +-- arr f1 *** arr f2 = arr (\(a, b) -> (f1 a, f2 b) +parSplitPrim :: SF a b -> SF c d -> SF (a,c) (b,d) +parSplitPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0} + where + tf0 ~(a0, c0) = (psXX sf1 sf2, (b0, d0)) + where + (sf1, b0) = tf10 a0 + (sf2, d0) = tf20 c0 + + -- Naming convention: ps where and is one of: + -- X - arbitrary signal function + -- A - arbitrary pure arrow + -- C - constant arrow + + psXX :: SF' a b -> SF' c d -> SF' (a,c) (b,d) + psXX (SFArr _ fd1) (SFArr _ fd2) = sfArr (fdPar fd1 fd2) + psXX (SFArr _ FDI) sf2 = spAux sf2 -- New + psXX (SFArr _ (FDC b)) sf2 = psCX b sf2 + psXX (SFArr _ fd1) sf2 = psAX (fdFun fd1) sf2 + psXX sf1 (SFArr _ FDI) = fpAux sf1 -- New + psXX sf1 (SFArr _ (FDC d)) = psXC sf1 d + psXX sf1 (SFArr _ fd2) = psXA sf1 (fdFun fd2) +-- !!! Unclear if this really is a gain. +-- !!! potentially unnecessary tupling and untupling. +-- !!! To be investigated. +-- !!! 2005-07-01: At least for MEP 6, the corresponding opt for +-- !!! &&& was harmfull. On that basis, disable it here too. +-- psXX (SFCpAXA _ fd11 sf12 fd13) (SFCpAXA _ fd21 sf22 fd23) = +-- cpAXA (fdPar fd11 fd21) (psXX sf12 sf22) (fdPar fd13 fd23) + psXX sf1 sf2 = SF' tf +{- + if sfIsInv sf1 && sfIsInv sf2 then + psXXInv sf1 sf2 + else + SF' tf False +-} + where + tf dt ~(a, c) = (psXX sf1' sf2', (b, d)) + where + (sf1', b) = (sfTF' sf1) dt a + (sf2', d) = (sfTF' sf2) dt c + +{- + psXXInv :: SF' a b -> SF' c d -> SF' (a,c) (b,d) + psXXInv sf1 sf2 = SF' tf True + where + tf dt ~(a, c) = sf1 `seq` sf2 `seq` (psXXInv sf1' sf2', + (b, d)) + where + (sf1', b) = (sfTF' sf1) dt a + (sf2', d) = (sfTF' sf2) dt c +-} + + psCX :: b -> SF' c d -> SF' (a,c) (b,d) + psCX b (SFArr _ fd2) = sfArr (fdPar (FDC b) fd2) + psCX b sf2 = SF' tf +{- + if sfIsInv sf2 then + psCXInv b sf2 + else + SF' tf False +-} + where + tf dt ~(_, c) = (psCX b sf2', (b, d)) + where + (sf2', d) = (sfTF' sf2) dt c + +{- + psCXInv :: b -> SF' c d -> SF' (a,c) (b,d) + psCXInv b sf2 = SF' tf True + where + tf dt ~(_, c) = sf2 `seq` (psCXInv b sf2', (b, d)) + where + (sf2', d) = (sfTF' sf2) dt c +-} + + psXC :: SF' a b -> d -> SF' (a,c) (b,d) + psXC (SFArr _ fd1) d = sfArr (fdPar fd1 (FDC d)) + psXC sf1 d = SF' tf +{- + if sfIsInv sf1 then + psXCInv sf1 d + else + SF' tf False +-} + where + tf dt ~(a, _) = (psXC sf1' d, (b, d)) + where + (sf1', b) = (sfTF' sf1) dt a + +{- + psXCInv :: SF' a b -> d -> SF' (a,c) (b,d) + psXCInv sf1 d = SF' tf True + where + tf dt ~(a, _) = sf1 `seq` (psXCInv sf1' d, (b, d)) + where + (sf1', b) = (sfTF' sf1) dt a +-} + + psAX :: (a -> b) -> SF' c d -> SF' (a,c) (b,d) + psAX f1 (SFArr _ fd2) = sfArr (fdPar (FDG f1) fd2) + psAX f1 sf2 = SF' tf +{- + if sfIsInv sf2 then + psAXInv f1 sf2 + else + SF' tf False +-} + where + tf dt ~(a, c) = (psAX f1 sf2', (f1 a, d)) + where + (sf2', d) = (sfTF' sf2) dt c + +{- + psAXInv :: (a -> b) -> SF' c d -> SF' (a,c) (b,d) + psAXInv f1 sf2 = SF' tf True + where + tf dt ~(a, c) = sf2 `seq` (psAXInv f1 sf2', (f1 a, d)) + where + (sf2', d) = (sfTF' sf2) dt c +-} + + psXA :: SF' a b -> (c -> d) -> SF' (a,c) (b,d) + psXA (SFArr _ fd1) f2 = sfArr (fdPar fd1 (FDG f2)) + psXA sf1 f2 = SF' tf +{- + if sfIsInv sf1 then + psXAInv sf1 f2 + else + SF' tf False +-} + where + tf dt ~(a, c) = (psXA sf1' f2, (b, f2 c)) + where + (sf1', b) = (sfTF' sf1) dt a + +{- + psXAInv :: SF' a b -> (c -> d) -> SF' (a,c) (b,d) + psXAInv sf1 f2 = SF' tf True + where + tf dt ~(a, c) = sf1 `seq` (psXAInv sf1' f2, (b, f2 c)) + where + (sf1', b) = (sfTF' sf1) dt a +-} + + +-- !!! Hmmm. Why don't we optimize the FDE cases here??? +-- !!! Seems pretty obvious that we should! +-- !!! It should also be possible to optimize an event processor in +-- !!! parallel with another event processor or an Arr FDE. + +parFanOutPrim :: SF a b -> SF a c -> SF a (b, c) +parFanOutPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0} + where + tf0 a0 = (pfoXX sf1 sf2, (b0, c0)) + where + (sf1, b0) = tf10 a0 + (sf2, c0) = tf20 a0 + + -- Naming convention: pfo where and is one of: + -- X - arbitrary signal function + -- A - arbitrary pure arrow + -- I - identity arrow + -- C - constant arrow + + pfoXX :: SF' a b -> SF' a c -> SF' a (b ,c) + pfoXX (SFArr _ fd1) (SFArr _ fd2) = sfArr(fdFanOut fd1 fd2) + pfoXX (SFArr _ FDI) sf2 = pfoIX sf2 + pfoXX (SFArr _ (FDC b)) sf2 = pfoCX b sf2 + pfoXX (SFArr _ fd1) sf2 = pfoAX (fdFun fd1) sf2 + pfoXX sf1 (SFArr _ FDI) = pfoXI sf1 + pfoXX sf1 (SFArr _ (FDC c)) = pfoXC sf1 c + pfoXX sf1 (SFArr _ fd2) = pfoXA sf1 (fdFun fd2) +-- !!! Unclear if this really would be a gain +-- !!! 2005-07-01: NOT a win for MEP 6. +-- pfoXX (SFCpAXA _ fd11 sf12 fd13) (SFCpAXA _ fd21 sf22 fd23) = +-- cpAXA (fdPar fd11 fd21) (psXX sf12 sf22) (fdPar fd13 fd23) + pfoXX sf1 sf2 = SF' tf +{- + if sfIsInv sf1 && sfIsInv sf2 then + pfoXXInv sf1 sf2 + else + SF' tf False +-} + where + tf dt a = (pfoXX sf1' sf2', (b, c)) + where + (sf1', b) = (sfTF' sf1) dt a + (sf2', c) = (sfTF' sf2) dt a + +{- + pfoXXInv :: SF' a b -> SF' a c -> SF' a (b ,c) + pfoXXInv sf1 sf2 = SF' tf True + where + tf dt a = sf1 `seq` sf2 `seq` (pfoXXInv sf1' sf2', (b, c)) + where + (sf1', b) = (sfTF' sf1) dt a + (sf2', c) = (sfTF' sf2) dt a +-} + + pfoIX :: SF' a c -> SF' a (a ,c) + pfoIX (SFArr _ fd2) = sfArr (fdFanOut FDI fd2) + pfoIX sf2 = SF' tf +{- + if sfIsInv sf2 then + pfoIXInv sf2 + else + SF' tf False +-} + where + tf dt a = (pfoIX sf2', (a, c)) + where + (sf2', c) = (sfTF' sf2) dt a + +{- + pfoIXInv :: SF' a c -> SF' a (a ,c) + pfoIXInv sf2 = SF' tf True + where + tf dt a = sf2 `seq` (pfoIXInv sf2', (a, c)) + where + (sf2', c) = (sfTF' sf2) dt a +-} + + pfoXI :: SF' a b -> SF' a (b ,a) + pfoXI (SFArr _ fd1) = sfArr (fdFanOut fd1 FDI) + pfoXI sf1 = SF' tf +{- + if sfIsInv sf1 then + pfoXIInv sf1 + else + SF' tf False +-} + where + tf dt a = (pfoXI sf1', (b, a)) + where + (sf1', b) = (sfTF' sf1) dt a + +{- + pfoXIInv :: SF' a b -> SF' a (b ,a) + pfoXIInv sf1 = SF' tf True + where + tf dt a = sf1 `seq` (pfoXIInv sf1', (b, a)) + where + (sf1', b) = (sfTF' sf1) dt a +-} + + pfoCX :: b -> SF' a c -> SF' a (b ,c) + pfoCX b (SFArr _ fd2) = sfArr (fdFanOut (FDC b) fd2) + pfoCX b sf2 = SF' tf +{- + if sfIsInv sf2 then + pfoCXInv b sf2 + else + SF' tf False +-} + where + tf dt a = (pfoCX b sf2', (b, c)) + where + (sf2', c) = (sfTF' sf2) dt a + +{- + pfoCXInv :: b -> SF' a c -> SF' a (b ,c) + pfoCXInv b sf2 = SF' tf True + where + tf dt a = sf2 `seq` (pfoCXInv b sf2', (b, c)) + where + (sf2', c) = (sfTF' sf2) dt a +-} + + pfoXC :: SF' a b -> c -> SF' a (b ,c) + pfoXC (SFArr _ fd1) c = sfArr (fdFanOut fd1 (FDC c)) + pfoXC sf1 c = SF' tf +{- + if sfIsInv sf1 then + pfoXCInv sf1 c + else + SF' tf False +-} + where + tf dt a = (pfoXC sf1' c, (b, c)) + where + (sf1', b) = (sfTF' sf1) dt a + +{- + pfoXCInv :: SF' a b -> c -> SF' a (b ,c) + pfoXCInv sf1 c = SF' tf True + where + tf dt a = sf1 `seq` (pfoXCInv sf1' c, (b, c)) + where + (sf1', b) = (sfTF' sf1) dt a +-} + + pfoAX :: (a -> b) -> SF' a c -> SF' a (b ,c) + pfoAX f1 (SFArr _ fd2) = sfArr (fdFanOut (FDG f1) fd2) + pfoAX f1 sf2 = SF' tf +{- + if sfIsInv sf2 then + pfoAXInv f1 sf2 + else + SF' tf False +-} + where + tf dt a = (pfoAX f1 sf2', (f1 a, c)) + where + (sf2', c) = (sfTF' sf2) dt a + +{- + pfoAXInv :: (a -> b) -> SF' a c -> SF' a (b ,c) + pfoAXInv f1 sf2 = SF' tf True + where + tf dt a = sf2 `seq` (pfoAXInv f1 sf2', (f1 a, c)) + where + (sf2', c) = (sfTF' sf2) dt a +-} + + pfoXA :: SF' a b -> (a -> c) -> SF' a (b ,c) + pfoXA (SFArr _ fd1) f2 = sfArr (fdFanOut fd1 (FDG f2)) + pfoXA sf1 f2 = SF' tf +{- + if sfIsInv sf1 then + pfoXAInv sf1 f2 + else + SF' tf False +-} + where + tf dt a = (pfoXA sf1' f2, (b, f2 a)) + where + (sf1', b) = (sfTF' sf1) dt a + +{- + pfoXAInv :: SF' a b -> (a -> c) -> SF' a (b ,c) + pfoXAInv sf1 f2 = SF' tf True + where + tf dt a = sf1 `seq` (pfoXAInv sf1' f2, (b, f2 a)) + where + (sf1', b) = (sfTF' sf1) dt a +-} + + +-- * ArrowLoop instance and implementation + +instance ArrowLoop SF where + loop = loopPrim + + +loopPrim :: SF (a,c) (b,c) -> SF a b +loopPrim (SF {sfTF = tf10}) = SF {sfTF = tf0} + where + tf0 a0 = (loopAux sf1, b0) + where + (sf1, (b0, c0)) = tf10 (a0, c0) + + loopAux :: SF' (a,c) (b,c) -> SF' a b + loopAux (SFArr _ FDI) = sfId + loopAux (SFArr _ (FDC (b, _))) = sfConst b + loopAux (SFArr _ fd1) = + sfArrG (\a -> let (b,c) = (fdFun fd1) (a,c) in b) + loopAux sf1 = SF' tf +{- + if sfIsInv sf1 then + loopInv sf1 + else + SF' tf False +-} + where + tf dt a = (loopAux sf1', b) + where + (sf1', (b, c)) = (sfTF' sf1) dt (a, c) + +{- + loopInv :: SF' (a,c) (b,c) -> SF' a b + loopInv sf1 = SF' tf True + where + tf dt a = sf1 `seq` (loopInv sf1', b) + where + (sf1', (b, c)) = (sfTF' sf1) dt (a, c) +-} + +-- * Scanning +-- +sfSScan :: (c -> a -> Maybe (c, b)) -> c -> b -> SF' a b +sfSScan f c b = sf + where + sf = SFSScan tf f c b + tf _ a = case f c a of + Nothing -> (sf, b) + Just (c', b') -> (sfSScan f c' b', b') + +-- Vim modeline +-- vim:set tabstop=8 expandtab: diff --git a/src/FRP/Yampa/Internals.hs b/src/FRP/Yampa/Internals.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa/Internals.hs @@ -0,0 +1,25 @@ +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.Internals +-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : nilsson@cs.yale.edu +-- Stability : provisional +-- Portability : portable +-- +-- An interface giving access to some of the internal +-- details of the Yampa implementation. +-- +-- This interface is indended to be used when the need arises to break +-- abstraction barriers, e.g. for interfacing Yampa to the real world, for +-- debugging purposes, or the like. Be aware that the internal details +-- may change. Relying on this interface means that your code is not +-- insulated against such changes. +----------------------------------------------------------------------------------------- + +module FRP.Yampa.Internals ( + Event(..) +) where + +import FRP.Yampa.Event diff --git a/src/FRP/Yampa/Loop.hs b/src/FRP/Yampa/Loop.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa/Loop.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE GADTs, Rank2Types, CPP #-} +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.Loop +-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- +-- Portability : non-portable -GHC extensions- +-- +-- Well-initialised loops +----------------------------------------------------------------------------------------- + +module FRP.Yampa.Loop ( + -- * Loops with guaranteed well-defined feedback + loopPre, -- :: c -> SF (a,c) (b,c) -> SF a b + loopIntegral, -- :: (VectorSpace a, s ~ Scalar a, Fractional s) => SF (a,c) (b,c) -> SF a b +) where + + +import Control.Arrow + +import FRP.Yampa.InternalCore (SF) + +import FRP.Yampa.Integration +import FRP.Yampa.Delays +import Data.VectorSpace + +-- * Loops with guaranteed well-defined feedback + +-- | Loop with an initial value for the signal being fed back. +loopPre :: c -> SF (a,c) (b,c) -> SF a b +loopPre c_init sf = loop (second (iPre c_init) >>> sf) + +-- | Loop by integrating the second value in the pair and feeding the +-- result back. Because the integral at time 0 is zero, this is always +-- well defined. +loopIntegral :: (VectorSpace c, s ~ Scalar c, Fractional s) => SF (a,c) (b,c) -> SF a b +loopIntegral sf = loop (second integral >>> sf) + +-- Vim modeline +-- vim:set tabstop=8 expandtab: diff --git a/src/FRP/Yampa/MergeableRecord.hs b/src/FRP/Yampa/MergeableRecord.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa/MergeableRecord.hs @@ -0,0 +1,86 @@ +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.Miscellany +-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : nilsson@cs.yale.edu +-- Stability : provisional +-- Portability : portable +-- +-- Framework for record merging. +-- +-- Idea: +-- +-- MergeableRecord is intended to be a super class for classes providing +-- update operations on records. The ADT induced by such a set of operations +-- can be considered a "mergeable record", which can be merged into larger +-- mergeable records essentially by function composition. Finalization turns +-- a mergeable record into a record. +-- +-- Typical use: +-- +-- Given +-- +-- > data Foo = Foo {l1 :: T1, l2 :: T2} +-- +-- one define a mergeable record type (MR Foo) by the following instance: +-- +-- @ +-- instance MergeableRecord Foo where +-- mrDefault = Foo {l1 = v1_dflt, l2 = v2_dflt} +-- @ +-- +-- Typically, one would also provide definitions for setting the fields, +-- possibly (but not necessarily) overloaded: +-- +-- @ +-- instance HasL1 Foo where +-- setL1 v = mrMake (\foo -> foo {l1 = v}) +-- @ +-- +-- Now Foo records can be created as follows: +-- +-- @ +-- let foo1 = setL1 v1 +-- ... +-- let foo2 = setL2 v2 ~+~ foo1 +-- ... +-- let foo = setL1 vN ~+~ foo +-- let fooFinal = mrFinalize foo +-- @ +----------------------------------------------------------------------------------------- + +module FRP.Yampa.MergeableRecord ( + MergeableRecord(..), + MR, -- Abstract + mrMake, + (~+~), + mrMerge, + mrFinalize +) where + +class MergeableRecord a where + mrDefault :: a + + +-- Type constructor for mergeable records. +newtype MergeableRecord a => MR a = MR (a -> a) + + +-- Construction of a mergeable record. +mrMake :: MergeableRecord a => (a -> a) -> MR a +mrMake f = (MR f) + + +-- Merge two mergeable records. Left "overrides" in case of conflict. +(~+~) :: MergeableRecord a => MR a -> MR a -> MR a +(MR f1) ~+~ (MR f2) = MR (f1 . f2) + +mrMerge :: MergeableRecord a => MR a -> MR a -> MR a +mrMerge = (~+~) + + +-- Finalization: turn a mergeable record into a record. +mrFinalize :: MergeableRecord a => MR a -> a +mrFinalize (MR f) = f mrDefault diff --git a/src/FRP/Yampa/Miscellany.hs b/src/FRP/Yampa/Miscellany.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa/Miscellany.hs @@ -0,0 +1,195 @@ +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.Miscellany +-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : nilsson@cs.yale.edu +-- Stability : provisional +-- Portability : portable +-- +-- Collection of entities that really should be part +-- of the Haskell 98 prelude or simply have no better +-- home. +-- +----------------------------------------------------------------------------------------- + +module FRP.Yampa.Miscellany ( +-- Reverse function composition + ( # ), -- :: (a -> b) -> (b -> c) -> (a -> c), infixl 9 + +-- Arrow plumbing aids + dup, -- :: a -> (a,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) + +-- 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) +) where + +import Control.Arrow + +infixl 9 # +infixl 7 `fDiv`, `fMod` + + +------------------------------------------------------------------------------ +-- Reverse function composition +------------------------------------------------------------------------------ + +-- !!! Reverse function composition should go. +-- !!! Better to use <<< and >>> for, respectively, +-- !!! function composition and reverse function composition. + +{-# DEPRECATED (#) "Use Control.Arrow.(>>>) and Control.Arrow.(<<<)." #-} +( # ) :: (a -> b) -> (b -> c) -> (a -> c) +f # g = g . f + + +------------------------------------------------------------------------------ +-- Arrow plumbing aids +------------------------------------------------------------------------------ + +dup :: a -> (a,a) +dup x = (x,x) + +------------------------------------------------------------------------------ +-- Maps over lists of pairs +------------------------------------------------------------------------------ + +{-# DEPRECATED mapFst "mapFst is not used by Yampa and will be removed from the next release" #-} +mapFst :: (a -> b) -> [(a,c)] -> [(b,c)] +mapFst f = map (\(x,y) -> (f x, y)) + +{-# DEPRECATED mapSnd "mapSnd is not used by Yampa and will be removed from the next release" #-} +mapSnd :: (a -> b) -> [(c,a)] -> [(c,b)] +mapSnd f = map (\(x,y) -> (x, f y)) + + +------------------------------------------------------------------------------ +-- Generalized tuple selectors +------------------------------------------------------------------------------ + +{-# DEPRECATED sel3_1, sel3_2, sel3_3 "Use the tuple package instead." #-} +-- Triples +sel3_1 :: (a, b, c) -> a +sel3_1 (x,_,_) = x +sel3_2 :: (a, b, c) -> b +sel3_2 (_,x,_) = x +sel3_3 :: (a, b, c) -> c +sel3_3 (_,_,x) = x + + +{-# DEPRECATED sel4_1, sel4_2, sel4_3, sel4_4 "Use the tuple package instead." #-} +-- 4-tuples +sel4_1 :: (a, b, c, d) -> a +sel4_1 (x,_,_,_) = x +sel4_2 :: (a, b, c, d) -> b +sel4_2 (_,x,_,_) = x +sel4_3 :: (a, b, c, d) -> c +sel4_3 (_,_,x,_) = x +sel4_4 :: (a, b, c, d) -> d +sel4_4 (_,_,_,x) = x + + +-- 5-tuples + +{-# DEPRECATED sel5_1, sel5_2, sel5_3, sel5_4, sel5_5 "Use the tuple package instead." #-} +sel5_1 :: (a, b, c, d, e) -> a +sel5_1 (x,_,_,_,_) = x +sel5_2 :: (a, b, c, d, e) -> b +sel5_2 (_,x,_,_,_) = x +sel5_3 :: (a, b, c, d, e) -> c +sel5_3 (_,_,x,_,_) = x +sel5_4 :: (a, b, c, d, e) -> d +sel5_4 (_,_,_,x,_) = x +sel5_5 :: (a, b, c, d, e) -> e +sel5_5 (_,_,_,_,x) = x + + +------------------------------------------------------------------------------ +-- Floating point utilities +------------------------------------------------------------------------------ + +-- Floating-point div and modulo operators. + +{-# DEPRECATED fDiv, fMod, fDivMod "These are not used by Yampa and will be removed." #-} +fDiv :: (RealFrac a) => a -> a -> Integer +fDiv x y = fst (fDivMod x y) + + +fMod :: (RealFrac a) => a -> a -> a +fMod x y = snd (fDivMod x y) + + +fDivMod :: (RealFrac a) => a -> a -> (Integer, a) +fDivMod x y = (q, r) + where + q = (floor (x/y)) + r = x - fromIntegral q * y + +-- * Arrows +------------------------------------------------------------------------------ +-- 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 ($) diff --git a/src/FRP/Yampa/Random.hs b/src/FRP/Yampa/Random.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa/Random.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE GADTs, Rank2Types, CPP #-} +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.Random +-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +----------------------------------------------------------------------------------------- + +module FRP.Yampa.Random ( + RandomGen(..), + Random(..), + +-- * 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) + +) where + +import System.Random (RandomGen(..), Random(..)) + +import FRP.Yampa.InternalCore (SF(..), SF'(..), Time) +import FRP.Yampa.Diagnostics +import FRP.Yampa.Event + +------------------------------------------------------------------------------ +-- Noise (i.e. random signal generators) and stochastic processes +------------------------------------------------------------------------------ + +-- | Noise (random signal) with default range for type in question; +-- based on "randoms". +noise :: (RandomGen g, Random b) => g -> SF a b +noise g0 = streamToSF (randoms g0) + + +-- | Noise (random signal) with specified range; based on "randomRs". +noiseR :: (RandomGen g, Random b) => (b,b) -> g -> SF a b +noiseR range g0 = streamToSF (randomRs range g0) + + +-- Internal. Not very useful for other purposes since we do not have any +-- control over the intervals between each "sample". Or? A version with +-- time-stamped samples would be similar to embedSynch (applied to identity). +-- The list argument must be a stream (infinite list) at present. + +streamToSF :: [b] -> SF a b +streamToSF [] = intErr "AFRP" "streamToSF" "Empty list!" +streamToSF (b:bs) = SF {sfTF = tf0} + where + tf0 _ = (stsfAux bs, b) + + stsfAux [] = intErr "AFRP" "streamToSF" "Empty list!" + -- Invarying since stsfAux [] is an error. + stsfAux (b:bs) = SF' tf -- True + where + tf _ _ = (stsfAux bs, b) + +{- New def, untested: + +streamToSF = sscan2 f + where + f [] _ = intErr "AFRP" "streamToSF" "Empty list!" + f (b:bs) _ = (bs, b) + +-} + + +-- | Stochastic event source with events occurring on average once every t_avg +-- seconds. However, no more than one event results from any one sampling +-- interval in the case of relatively sparse sampling, thus avoiding an +-- "event backlog" should sampling become more frequent at some later +-- point in time. + +-- !!! Maybe it would better to give a frequency? But like this to make +-- !!! consitent with "repeatedly". +occasionally :: RandomGen g => g -> Time -> b -> SF a (Event b) +occasionally g t_avg x | t_avg > 0 = SF {sfTF = tf0} + | otherwise = usrErr "AFRP" "occasionally" + "Non-positive average interval." + where + -- Generally, if events occur with an average frequency of f, the + -- probability of at least one event occurring in an interval of t + -- is given by (1 - exp (-f*t)). The goal in the following is to + -- decide whether at least one event occurred in the interval of size + -- dt preceding the current sample point. For the first point, + -- we can think of the preceding interval as being 0, implying + -- no probability of an event occurring. + + tf0 _ = (occAux (randoms g :: [Time]), NoEvent) + + occAux [] = undefined + occAux (r:rs) = SF' tf -- True + where + tf dt _ = let p = 1 - exp (-(dt/t_avg)) -- Probability for at least one event. + in (occAux rs, if r < p then Event x else NoEvent) + + +-- Vim modeline +-- vim:set tabstop=8 expandtab: diff --git a/src/FRP/Yampa/Scan.hs b/src/FRP/Yampa/Scan.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa/Scan.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE GADTs, Rank2Types, CPP #-} +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.Scan +-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +----------------------------------------------------------------------------------------- + +module FRP.Yampa.Scan ( +-- ** Simple, stateful signal processing + sscan, -- :: (b -> a -> b) -> b -> SF a b + sscanPrim, -- :: (c -> a -> Maybe (c, b)) -> c -> b -> SF a b +) where + +import FRP.Yampa.InternalCore (SF(..), sfSScan) + +------------------------------------------------------------------------------ +-- Simple, stateful signal processing +------------------------------------------------------------------------------ + +-- New sscan primitive. It should be possible to define lots of functions +-- in terms of this one. Eventually a new constructor will be introduced if +-- this works out. + +sscan :: (b -> a -> b) -> b -> SF a b +sscan f b_init = sscanPrim f' b_init b_init + where + f' b a = let b' = f b a in Just (b', b') + +sscanPrim :: (c -> a -> Maybe (c, b)) -> c -> b -> SF a b +sscanPrim f c_init b_init = SF {sfTF = tf0} + where + tf0 a0 = case f c_init a0 of + Nothing -> (sfSScan f c_init b_init, b_init) + Just (c', b') -> (sfSScan f c' b', b') + +-- Vim modeline +-- vim:set tabstop=8 expandtab: diff --git a/src/FRP/Yampa/Simulation.hs b/src/FRP/Yampa/Simulation.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa/Simulation.hs @@ -0,0 +1,301 @@ +{-# LANGUAGE GADTs, Rank2Types, CPP #-} +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.Simulation +-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +----------------------------------------------------------------------------------------- + +module FRP.Yampa.Simulation ( +-- * Execution/simulation +-- ** Reactimation + reactimate, -- :: IO a + -- -> (Bool -> IO (DTime, Maybe a)) + -- -> (Bool -> b -> IO Bool) + -- -> SF a b + -- -> IO () + ReactHandle, + reactInit, -- IO a -- init + -- -> (ReactHandle a b -> Bool -> b -> IO Bool) -- actuate + -- -> SF a b + -- -> IO (ReactHandle a b) + -- process a single input sample: + react, -- ReactHandle a b + -- -> (DTime,Maybe a) + -- -> IO Bool + +-- ** Embedding + -- (tentative: will be revisited) + embed, -- :: SF a b -> (a, [(DTime, Maybe a)]) -> [b] + embedSynch, -- :: SF a b -> (a, [(DTime, Maybe a)]) -> SF Double b + deltaEncode, -- :: Eq a => DTime -> [a] -> (a, [(DTime, Maybe a)]) + deltaEncodeBy, -- :: (a -> a -> Bool) -> DTime -> [a] + -- -> (a, [(DTime, Maybe a)]) + +) where + +import Control.Monad (unless) +import Data.IORef +import Data.Maybe (fromMaybe) + +import FRP.Yampa.InternalCore (SF(..), SF'(..), sfTF', DTime) + +import FRP.Yampa.Diagnostics + +------------------------------------------------------------------------------ +-- 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. + +-- | Convenience function to run a signal function indefinitely, using +-- a IO actions to obtain new input and process the output. +-- +-- This function first runs the initialization action, which provides the +-- initial input for the signal transformer at time 0. +-- +-- Afterwards, an input sensing action is used to obtain new input (if any) and +-- the time since the last iteration. The argument to the input sensing function +-- indicates if it can block. If no new input is received, it is assumed to be +-- the same as in the last iteration. +-- +-- After applying the signal function to the input, the actuation IO action +-- is executed. The first argument indicates if the output has changed, the second +-- gives the actual output). Actuation functions may choose to ignore the first +-- argument altogether. This action should return True if the reactimation +-- must stop, and False if it should continue. +-- +-- Note that this becomes the program's /main loop/, which makes using this +-- function incompatible with GLUT, Gtk and other graphics libraries. It may also +-- impose a sizeable constraint in larger projects in which different subparts run +-- at different time steps. If you need to control the main +-- loop yourself for these or other reasons, use 'reactInit' and 'react'. + +reactimate :: IO a -- ^ IO initialization action + -> (Bool -> IO (DTime, Maybe a)) -- ^ IO input sensing action + -> (Bool -> b -> IO Bool) -- ^ IO actuaction (output processing) action + -> SF a b -- ^ Signal function + -> 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' = fromMaybe a ma' + (sf', b') = (sfTF' sf) dt a' + loop sf' a' b' + + +-- An API for animating a signal function when some other library +-- needs to own the top-level control flow: + +-- reactimate's state, maintained across samples: +data ReactState a b = ReactState { + rsActuate :: ReactHandle a b -> Bool -> b -> IO Bool, + rsSF :: SF' a b, + rsA :: a, + rsB :: b + } + +-- | A reference to reactimate's state, maintained across samples. +type ReactHandle a b = IORef (ReactState a b) + +-- | Initialize a 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 }) + _ <- 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' = fromMaybe a ma' + (sf',b') = (sfTF' sf) dt a' + writeIORef rh (rs {rsSF = sf',rsA = a',rsB = b'}) + done <- actuate rh True b' + return done + + +------------------------------------------------------------------------------ +-- Embedding +------------------------------------------------------------------------------ + +-- New embed interface. We will probably have to revisit this. To run an +-- embedded signal function while retaining full control (e.g. start and +-- stop at will), one would probably need a continuation-based interface +-- (as well as a continuation based underlying implementation). +-- +-- E.g. here are interesting alternative (or maybe complementary) +-- signatures: +-- +-- sample :: SF a b -> SF (Event a) (Event b) +-- sample' :: SF a b -> SF (Event (DTime, a)) (Event b) +-- +-- Maybe it should be called "subSample", since that's the only thing +-- that can be achieved. At least does not have the problem with missing +-- events when supersampling. +-- +-- subSampleSynch :: SF a b -> SF (Event a) (Event b) +-- Time progresses at the same rate in the embedded system. +-- But it is only sampled on the events. +-- E.g. +-- repeatedly 0.1 () >>> subSampleSynch sf >>> hold +-- +-- subSample :: DTime -> SF a b -> SF (Event a) (Event b) +-- Time advanced by dt for each event, not synchronized with the outer clock. + +-- | Given a signal function and a pair with an initial +-- input sample for the input signal, and a list of sampling +-- times, possibly with new input samples at those times, +-- it produces a list of output samples. +-- +-- This is a simplified, purely-functional version of 'reactimate'. +embed :: SF a b -> (a, [(DTime, Maybe a)]) -> [b] +embed sf0 (a0, dtas) = b0 : loop a0 sf dtas + where + (sf, b0) = (sfTF sf0) a0 + + loop _ _ [] = [] + loop a_prev sf ((dt, ma) : dtas) = + b : (a `seq` b `seq` loop a sf' dtas) + where + a = fromMaybe a_prev ma + (sf', b) = (sfTF' sf) dt a + + +-- | Synchronous embedding. The embedded signal function is run on the supplied +-- input and time stream at a given (but variable) ratio >= 0 to the outer +-- time flow. When the ratio is 0, the embedded signal function is paused. + +-- What about running an embedded signal function at a fixed (guaranteed) +-- sampling frequency? E.g. super sampling if the outer sampling is slower, +-- subsampling otherwise. AS WELL as at a given ratio to the outer one. +-- +-- Ah, but that's more or less what embedSync does. +-- So just simplify the interface. But maybe it should also be possible +-- to feed in input from the enclosing system. + +-- !!! Should "dropped frames" be forced to avoid space leaks? +-- !!! It's kind of hard to se why, but "frame dropping" was a problem +-- !!! in the old robot simulator. Try to find an example! + +embedSynch :: SF a b -> (a, [(DTime, Maybe a)]) -> SF Double b +embedSynch sf0 (a0, dtas) = SF {sfTF = tf0} + where + tts = scanl (\t (dt, _) -> t + dt) 0 dtas + bbs@(b:_) = embed sf0 (a0, dtas) + + tf0 _ = (esAux 0 (zip tts bbs), b) + + esAux _ [] = intErr "AFRP" "embedSynch" "Empty list!" + -- Invarying below since esAux [] is an error. + esAux tp_prev tbtbs = SF' tf -- True + where + tf dt r | r < 0 = usrErr "AFRP" "embedSynch" + "Negative ratio." + | otherwise = let tp = tp_prev + dt * r + (b, tbtbs') = advance tp tbtbs + in + (esAux tp tbtbs', b) + + -- Advance the time stamped stream to the perceived time tp. + -- Under the assumption that the perceived time never goes + -- backwards (non-negative ratio), advance maintains the + -- invariant that the perceived time is always >= the first + -- time stamp. + advance _ tbtbs@[(_, b)] = (b, tbtbs) + advance tp tbtbtbs@((_, b) : tbtbs@((t', _) : _)) + | tp < t' = (b, tbtbtbs) + | t' <= tp = advance tp tbtbs + advance _ _ = undefined + +-- | Spaces a list of samples by a fixed time delta, avoiding +-- unnecessary samples when the input has not changed since +-- the last sample. +deltaEncode :: Eq a => DTime -> [a] -> (a, [(DTime, Maybe a)]) +deltaEncode _ [] = usrErr "AFRP" "deltaEncode" "Empty input list." +deltaEncode dt aas@(_:_) = deltaEncodeBy (==) dt aas + + +-- | 'deltaEncode' parameterized by the equality test. +deltaEncodeBy :: (a -> a -> Bool) -> DTime -> [a] -> (a, [(DTime, Maybe a)]) +deltaEncodeBy _ _ [] = usrErr "AFRP" "deltaEncodeBy" "Empty input list." +deltaEncodeBy eq dt (a0:as) = (a0, zip (repeat dt) (debAux a0 as)) + where + debAux _ [] = [] + debAux a_prev (a:as) | a `eq` a_prev = Nothing : debAux a as + | otherwise = Just a : debAux a as + +-- Embedding and missing events. +-- Suppose a subsystem is super sampled. Then some of the output +-- samples will have to be dropped. If we are unlycky, the dropped +-- samples could be occurring events that we'd rather not miss. +-- This is a real problem. +-- Similarly, when feeding input into a super-sampled system, +-- we may need to extrapolate the input, assuming that it is +-- constant. But if (part of) the input is an occurring event, we'd +-- rather not duplicate that!!! +-- This suggests that: +-- * output samples should be merged through a user-supplied merge +-- function. +-- * input samples should be extrapolated if necessary through a +-- user-supplied extrapolation function. +-- +-- Possible signature: +-- +-- resample :: Time -> (c -> [a]) -> SF a b -> ([b] -> d) -> SF c d +-- +-- But what do we do if the inner system runs more slowly than the +-- outer one? Then we need to extrapolate the output from the +-- inner system, and we have the same problem with events AGAIN! + +-- Vim modeline +-- vim:set tabstop=8 expandtab: diff --git a/src/FRP/Yampa/Switches.hs b/src/FRP/Yampa/Switches.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa/Switches.hs @@ -0,0 +1,811 @@ +{-# LANGUAGE GADTs, Rank2Types, CPP #-} +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.Switches +-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +----------------------------------------------------------------------------------------- + +module FRP.Yampa.Switches ( + -- Re-exported module, classes, and types + + -- * Switching + -- ** Basic switchers + switch, dSwitch, -- :: SF a (b, Event c) -> (c -> SF a b) -> SF a b + rSwitch, drSwitch, -- :: SF a b -> SF (a,Event (SF a b)) b + kSwitch, dkSwitch, -- :: SF a b + -- -> SF (a,b) (Event c) + -- -> (SF a b -> c -> SF a b) + -- -> SF a b + + -- ** Parallel composition and switching + -- *** Parallel composition and switching over collections with broadcasting + parB, -- :: Functor col => col (SF a b) -> SF a (col b) + pSwitchB,dpSwitchB, -- :: Functor col => + -- col (SF a b) + -- -> SF (a, col b) (Event c) + -- -> (col (SF a b) -> c -> SF a (col b)) + -- -> SF a (col b) + rpSwitchB,drpSwitchB,-- :: Functor col => + -- col (SF a b) + -- -> SF (a, Event (col (SF a b)->col (SF a b))) + -- (col b) + + -- *** 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) + -- + -- 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] + +) where + +import Control.Arrow + +import FRP.Yampa.Diagnostics +import FRP.Yampa.InternalCore (SF(..), SF'(..), sfTF', sfConst, fdFun, FunDesc(..), sfArrG, DTime) + +import FRP.Yampa.Basic +import FRP.Yampa.Event + +------------------------------------------------------------------------------ +-- Basic switchers +------------------------------------------------------------------------------ + +-- !!! Interesting case. It seems we need scoped type variables +-- !!! to be able to write down the local type signatures. +-- !!! On the other hand, the scoped type variables seem to +-- !!! prohibit the kind of unification that is needed for GADTs??? +-- !!! Maybe this could be made to wok if it actually WAS known +-- !!! that scoped type variables indeed corresponds to universally +-- !!! quantified variables? Or if one were to keep track of those +-- !!! scoped type variables that actually do? +-- !!! +-- !!! Find a simpler case to experiment further. For now, elim. +-- !!! the free variable. + +{- +-- Basic switch. +switch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b +switch (SF {sfTF = tf10} :: SF a (b, Event c)) (k :: c -> SF a b) = SF {sfTF = tf0} + where + tf0 a0 = + case tf10 a0 of + (sf1, (b0, NoEvent)) -> (switchAux sf1, b0) + (_, (_, Event c0)) -> sfTF (k c0) a0 + + -- It would be nice to optimize further here. E.g. if it would be + -- possible to observe the event source only. + switchAux :: SF' a (b, Event c) -> SF' a b + switchAux (SFId _) = switchAuxA1 id -- New + switchAux (SFConst _ (b, NoEvent)) = sfConst b + switchAux (SFArr _ f1) = switchAuxA1 f1 + switchAux sf1 = SF' tf + where + tf dt a = + case (sfTF' sf1) dt a of + (sf1', (b, NoEvent)) -> (switchAux sf1', b) + (_, (_, Event c)) -> sfTF (k c) a + + -- Could be optimized a little bit further by having a case for + -- identity, switchAuxI1 + + -- Note: While switch behaves as a stateless arrow at this point, that + -- could change after a switch. Hence, SF' overall. + switchAuxA1 :: (a -> (b, Event c)) -> SF' a b + switchAuxA1 f1 = sf + where + sf = SF' tf + tf _ a = + case f1 a of + (b, NoEvent) -> (sf, b) + (_, Event c) -> sfTF (k c) a +-} + +-- | Basic switch. +-- +-- By default, the first signal function is applied. +-- +-- Whenever the second value in the pair actually is an event, +-- the value carried by the event is used to obtain a new signal +-- function to be applied *at that time and at future times*. +-- +-- Until that happens, the first value in the pair is produced +-- in the output signal. +-- +-- Important note: at the time of switching, the second +-- signal function is applied immediately. If that second +-- SF can also switch at time zero, then a double (nested) +-- switch might take place. If the second SF refers to the +-- first one, the switch might take place infinitely many +-- times and never be resolved. +-- +-- Remember: The continuation is evaluated strictly at the time +-- of switching! +switch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b +switch (SF {sfTF = tf10}) k = SF {sfTF = tf0} + where + tf0 a0 = + case tf10 a0 of + (sf1, (b0, NoEvent)) -> (switchAux sf1 k, b0) + (_, (_, Event c0)) -> sfTF (k c0) a0 + + -- It would be nice to optimize further here. E.g. if it would be + -- possible to observe the event source only. + switchAux :: SF' a (b, Event c) -> (c -> SF a b) -> SF' a b + switchAux (SFArr _ (FDC (b, NoEvent))) _ = sfConst b + switchAux (SFArr _ fd1) k = switchAuxA1 (fdFun fd1) k + switchAux sf1 k = SF' tf +{- + if sfIsInv sf1 then + switchInv sf1 k + else + SF' tf False +-} + where + tf dt a = + case (sfTF' sf1) dt a of + (sf1', (b, NoEvent)) -> (switchAux sf1' k, b) + (_, (_, Event c)) -> sfTF (k c) a + +{- + -- Note: subordinate signal function being invariant does NOT + -- imply that the overall signal function is. + switchInv :: SF' a (b, Event c) -> (c -> SF a b) -> SF' a b + switchInv sf1 k = SF' tf False + where + tf dt a = + case (sfTF' sf1) dt a of + (sf1', (b, NoEvent)) -> (switchInv sf1' k, b) + (_, (_, Event c)) -> sfTF (k c) a +-} + + -- !!! Could be optimized a little bit further by having a case for + -- !!! identity, switchAuxI1. But I'd expect identity is so unlikely + -- !!! that there is no point. + + -- Note: While switch behaves as a stateless arrow at this point, that + -- could change after a switch. Hence, SF' overall. + switchAuxA1 :: (a -> (b, Event c)) -> (c -> SF a b) -> SF' a b + switchAuxA1 f1 k = sf + where + sf = SF' tf -- False + tf _ a = + case f1 a of + (b, NoEvent) -> (sf, b) + (_, Event c) -> sfTF (k c) a + + +-- | Switch with delayed observation. +-- +-- By default, the first signal function is applied. +-- +-- Whenever the second value in the pair actually is an event, +-- the value carried by the event is used to obtain a new signal +-- function to be applied *at future times*. +-- +-- Until that happens, the first value in the pair is produced +-- in the output signal. +-- +-- Important note: at the time of switching, the second +-- signal function is used immediately, but the current +-- input is fed by it (even though the actual output signal +-- value at time 0 is discarded). +-- +-- If that second SF can also switch at time zero, then a +-- double (nested) -- switch might take place. If the second SF refers to the +-- first one, the switch might take place infinitely many times and never be +-- resolved. +-- +-- Remember: The continuation is evaluated strictly at the time +-- of switching! + +-- Alternative name: "decoupled switch"? +-- (The SFId optimization is highly unlikley to be of much use, but it +-- does raise an interesting typing issue.) +dSwitch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b +dSwitch (SF {sfTF = tf10}) k = SF {sfTF = tf0} + where + tf0 a0 = + let (sf1, (b0, ec0)) = tf10 a0 + in (case ec0 of + NoEvent -> dSwitchAux sf1 k + Event c0 -> fst (sfTF (k c0) a0), + b0) + + -- It would be nice to optimize further here. E.g. if it would be + -- possible to observe the event source only. + dSwitchAux :: SF' a (b, Event c) -> (c -> SF a b) -> SF' a b + dSwitchAux (SFArr _ (FDC (b, NoEvent))) _ = sfConst b + dSwitchAux (SFArr _ fd1) k = dSwitchAuxA1 (fdFun fd1) k + dSwitchAux sf1 k = SF' tf +{- + if sfIsInv sf1 then + dSwitchInv sf1 k + else + SF' tf False +-} + where + tf dt a = + let (sf1', (b, ec)) = (sfTF' sf1) dt a + in (case ec of + NoEvent -> dSwitchAux sf1' k + Event c -> fst (sfTF (k c) a), + + b) + +{- + -- Note: that the subordinate signal function is invariant does NOT + -- imply that the overall signal function is. + dSwitchInv :: SF' a (b, Event c) -> (c -> SF a b) -> SF' a b + dSwitchInv sf1 k = SF' tf False + where + tf dt a = + let (sf1', (b, ec)) = (sfTF' sf1) dt a + in (case ec of + NoEvent -> dSwitchInv sf1' k + Event c -> fst (sfTF (k c) a), + + b) +-} + + -- !!! Could be optimized a little bit further by having a case for + -- !!! identity, switchAuxI1 + + -- Note: While dSwitch behaves as a stateless arrow at this point, that + -- could change after a switch. Hence, SF' overall. + dSwitchAuxA1 :: (a -> (b, Event c)) -> (c -> SF a b) -> SF' a b + dSwitchAuxA1 f1 k = sf + where + sf = SF' tf -- False + tf _ a = + let (b, ec) = f1 a + in (case ec of + NoEvent -> sf + Event c -> fst (sfTF (k c) a), + + b) + + +-- | Recurring switch. +-- +-- See for more +-- information on how this switch works. + +-- !!! Suboptimal. Overall, the constructor is invarying since rSwitch is +-- !!! being invoked recursively on a switch. In fact, we don't even care +-- !!! whether the subordinate signal function is invarying or not. +-- !!! We could make use of a signal function transformer sfInv to +-- !!! mark the constructor as invarying. Would that make sense? +-- !!! The price would be an extra loop with case analysis. +-- !!! The potential gain is fewer case analyses in superior loops. +rSwitch :: SF a b -> SF (a, Event (SF a b)) b +rSwitch sf = switch (first sf) ((noEventSnd >=-) . rSwitch) + +{- +-- Old version. New is more efficient. Which one is clearer? +rSwitch :: SF a b -> SF (a, Event (SF a b)) b +rSwitch sf = switch (first sf) rSwitch' + where + rSwitch' sf = switch (sf *** notYet) rSwitch' +-} + + +-- | Recurring switch with delayed observation. +-- +-- See for more +-- information on how this switch works. +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. +-- +-- See for more +-- information on how this switch works. + +-- !!! Has not been optimized properly. +-- !!! Nor has opts been tested! +-- !!! Don't forget Inv opts! +kSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b +kSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0} + where + tf0 a0 = + let (sf1, b0) = tf10 a0 + in + case tfe0 (a0, b0) of + (sfe, NoEvent) -> (kSwitchAux sf1 sfe, b0) + (_, Event c0) -> sfTF (k sf10 c0) a0 + +-- Same problem as above: must pass k explicitly??? +-- kSwitchAux (SFId _) sfe = kSwitchAuxI1 sfe + kSwitchAux (SFArr _ (FDC b)) sfe = kSwitchAuxC1 b sfe + kSwitchAux (SFArr _ fd1) sfe = kSwitchAuxA1 (fdFun fd1) sfe + -- kSwitchAux (SFArrE _ f1) sfe = kSwitchAuxA1 f1 sfe + -- kSwitchAux (SFArrEE _ f1) sfe = kSwitchAuxA1 f1 sfe + kSwitchAux sf1 (SFArr _ (FDC NoEvent)) = sf1 + kSwitchAux sf1 (SFArr _ fde) = kSwitchAuxAE sf1 (fdFun fde) + -- kSwitchAux sf1 (SFArrE _ fe) = kSwitchAuxAE sf1 fe + -- kSwitchAux sf1 (SFArrEE _ fe) = kSwitchAuxAE sf1 fe + kSwitchAux sf1 sfe = SF' tf -- False + where + tf dt a = + let (sf1', b) = (sfTF' sf1) dt a + in + case (sfTF' sfe) dt (a, b) of + (sfe', NoEvent) -> (kSwitchAux sf1' sfe', b) + (_, Event c) -> sfTF (k (freeze sf1 dt) c) a + +{- +-- !!! Untested optimization! + kSwitchAuxI1 (SFConst _ NoEvent) = sfId + kSwitchAuxI1 (SFArr _ fe) = kSwitchAuxI1AE fe + kSwitchAuxI1 sfe = SF' tf + where + tf dt a = + case (sfTF' sfe) dt (a, a) of + (sfe', NoEvent) -> (kSwitchAuxI1 sfe', a) + (_, Event c) -> sfTF (k identity c) a +-} + +-- !!! Untested optimization! + kSwitchAuxC1 b (SFArr _ (FDC NoEvent)) = sfConst b + kSwitchAuxC1 b (SFArr _ fde) = kSwitchAuxC1AE b (fdFun fde) + -- kSwitchAuxC1 b (SFArrE _ fe) = kSwitchAuxC1AE b fe + -- kSwitchAuxC1 b (SFArrEE _ fe) = kSwitchAuxC1AE b fe + kSwitchAuxC1 b sfe = SF' tf -- False + where + tf dt a = + case (sfTF' sfe) dt (a, b) of + (sfe', NoEvent) -> (kSwitchAuxC1 b sfe', b) + (_, Event c) -> sfTF (k (constant b) c) a + +-- !!! Untested optimization! + kSwitchAuxA1 f1 (SFArr _ (FDC NoEvent)) = sfArrG f1 + kSwitchAuxA1 f1 (SFArr _ fde) = kSwitchAuxA1AE f1 (fdFun fde) + -- kSwitchAuxA1 f1 (SFArrE _ fe) = kSwitchAuxA1AE f1 fe + -- kSwitchAuxA1 f1 (SFArrEE _ fe) = kSwitchAuxA1AE f1 fe + kSwitchAuxA1 f1 sfe = SF' tf -- False + where + tf dt a = + let b = f1 a + in + case (sfTF' sfe) dt (a, b) of + (sfe', NoEvent) -> (kSwitchAuxA1 f1 sfe', b) + (_, Event c) -> sfTF (k (arr f1) c) a + + -- !!! Untested optimization! + -- kSwitchAuxAE (SFId _) fe = kSwitchAuxI1AE fe + kSwitchAuxAE (SFArr _ (FDC b)) fe = kSwitchAuxC1AE b fe + kSwitchAuxAE (SFArr _ fd1) fe = kSwitchAuxA1AE (fdFun fd1) fe + -- kSwitchAuxAE (SFArrE _ f1) fe = kSwitchAuxA1AE f1 fe + -- kSwitchAuxAE (SFArrEE _ f1) fe = kSwitchAuxA1AE f1 fe + kSwitchAuxAE sf1 fe = SF' tf -- False + where + tf dt a = + let (sf1', b) = (sfTF' sf1) dt a + in + case fe (a, b) of + NoEvent -> (kSwitchAuxAE sf1' fe, b) + Event c -> sfTF (k (freeze sf1 dt) c) a + +{- +-- !!! Untested optimization! + kSwitchAuxI1AE fe = SF' tf -- False + where + tf dt a = + case fe (a, a) of + NoEvent -> (kSwitchAuxI1AE fe, a) + Event c -> sfTF (k identity c) a +-} + +-- !!! Untested optimization! + kSwitchAuxC1AE b fe = SF' tf -- False + where + tf _ a = + case fe (a, b) of + NoEvent -> (kSwitchAuxC1AE b fe, b) + Event c -> sfTF (k (constant b) c) a + +-- !!! Untested optimization! + kSwitchAuxA1AE f1 fe = SF' tf -- False + where + tf _ a = + let b = f1 a + in + case fe (a, b) of + NoEvent -> (kSwitchAuxA1AE f1 fe, b) + Event c -> sfTF (k (arr f1) c) a + + +-- | 'kSwitch' with delayed observation. +-- +-- See for more +-- information on how this switch works. + +-- !!! Has not been optimized properly. Should be like kSwitch. +dkSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b +dkSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0} + where + tf0 a0 = + let (sf1, b0) = tf10 a0 + in (case tfe0 (a0, b0) of + (sfe, NoEvent) -> dkSwitchAux sf1 sfe + (_, Event c0) -> fst (sfTF (k sf10 c0) a0), + b0) + + dkSwitchAux sf1 (SFArr _ (FDC NoEvent)) = sf1 + dkSwitchAux sf1 sfe = SF' tf -- False + where + tf dt a = + let (sf1', b) = (sfTF' sf1) dt a + in (case (sfTF' sfe) dt (a, b) of + (sfe', NoEvent) -> dkSwitchAux sf1' sfe' + (_, Event c) -> fst (sfTF (k (freeze sf1 dt) c) a), + b) + + +------------------------------------------------------------------------------ +-- Parallel composition and switching over collections with broadcasting +------------------------------------------------------------------------------ + +-- | Tuple a value up with every element of a collection of signal +-- functions. +broadcast :: Functor col => a -> col sf -> col (a, sf) +broadcast a = fmap (\sf -> (a, sf)) + + +-- !!! Hmm. We should really optimize here. +-- !!! Check for Arr in parallel! +-- !!! Check for Arr FDE in parallel!!! +-- !!! Check for EP in parallel!!!!! +-- !!! Cf &&&. +-- !!! But how??? All we know is that the collection is a functor ... +-- !!! Maybe that kind of generality does not make much sense for +-- !!! par and parB? (Although it is niceto be able to switch into a +-- !!! par or parB from within a pSwitch[B].) +-- !!! If we had a parBList, that could be defined in terms of &&&, surely? +-- !!! E.g. +-- !!! parBList [] = constant [] +-- !!! parBList (sf:sfs) = sf &&& parBList sfs >>> arr (\(x,xs) -> x:xs) +-- !!! +-- !!! This ought to optimize quite well. E.g. +-- !!! parBList [arr1,arr2,arr3] +-- !!! = arr1 &&& parBList [arr2,arr3] >>> arrX +-- !!! = arr1 &&& (arr2 &&& parBList [arr3] >>> arrX) >>> arrX +-- !!! = arr1 &&& (arr2 &&& (arr3 &&& parBList [] >>> arrX) >>> arrX) >>> arrX +-- !!! = arr1 &&& (arr2 &&& (arr3C >>> arrX) >>> arrX) >>> arrX +-- !!! = arr1 &&& (arr2 &&& (arr3CcpX) >>> arrX) >>> arrX +-- !!! = arr1 &&& (arr23CcpX >>> arrX) >>> arrX +-- !!! = arr1 &&& (arr23CcpXcpX) >>> arrX +-- !!! = arr123CcpXcpXcpX + +-- | Spatial parallel composition of a signal function collection. +-- Given a collection of signal functions, it returns a signal +-- function that 'broadcast's its input signal to every element +-- of the collection, to return a signal carrying a collection +-- of outputs. See 'par'. +-- +-- For more information on how parallel composition works, check +-- +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). See 'pSwitch'. +-- +-- For more information on how parallel composition works, check +-- +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 + +-- | Delayed parallel switch with broadcasting (dynamic collection of +-- signal functions spatially composed in parallel). See 'dpSwitch'. +-- +-- For more information on how parallel composition works, check +-- +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 + +-- For more information on how parallel composition works, check +-- +rpSwitchB :: Functor col => + col (SF a b) -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b) +rpSwitchB = rpSwitch broadcast + +-- For more information on how parallel composition works, check +-- +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. +-- +par :: Functor col => + (forall sf . (a -> col sf -> col (b, sf))) -- ^ Determines the input to each signal function + -- in the collection. IMPORTANT! The routing function MUST + -- preserve the structure of the signal function collection. + + -> col (SF b c) -- ^ Signal function collection. + -> SF a (col c) +par rf sfs0 = SF {sfTF = tf0} + where + tf0 a0 = + let bsfs0 = rf a0 sfs0 + sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0 + sfs = fmap fst sfcs0 + cs0 = fmap snd sfcs0 + in + (parAux rf sfs, cs0) + + +-- Internal definition. Also used in parallel swithers. +parAux :: Functor col => + (forall sf . (a -> col sf -> col (b, sf))) + -> col (SF' b c) + -> SF' a (col c) +parAux rf sfs = SF' tf -- True + where + tf dt a = + let bsfs = rf a sfs + sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs + sfs' = fmap fst sfcs' + cs = fmap snd sfcs' + in + (parAux rf sfs', cs) + + +-- | Parallel switch parameterized on the routing function. This is the most +-- general switch from which all other (non-delayed) switches in principle +-- can be derived. The signal function collection is spatially composed in +-- parallel and run until the event signal function has an occurrence. Once +-- the switching event occurs, all signal function are "frozen" and their +-- continuations are passed to the continuation function, along with the +-- event value. +-- + +-- rf ......... Routing function: determines the input to each signal function +-- in the collection. IMPORTANT! The routing function has an +-- obligation to preserve the structure of the signal function +-- collection. +-- sfs0 ....... Signal function collection. +-- sfe0 ....... Signal function generating the switching event. +-- k .......... Continuation to be invoked once event occurs. +-- Returns the resulting signal function. +-- +-- !!! Could be optimized on the event source being SFArr, SFArrE, SFArrEE +pSwitch :: Functor col + => (forall sf . (a -> col sf -> col (b, sf))) -- ^ 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. + + -> col (SF b c) -- ^ Signal function collection. + -> SF (a, col c) (Event d) -- ^ Signal function generating the switching event. + -> (col (SF b c) -> d -> SF a (col c)) -- ^ Continuation to be invoked once event occurs. + -> SF a (col c) +pSwitch rf sfs0 sfe0 k = SF {sfTF = tf0} + where + tf0 a0 = + let bsfs0 = rf a0 sfs0 + sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0 + sfs = fmap fst sfcs0 + cs0 = fmap snd sfcs0 + in + case (sfTF sfe0) (a0, cs0) of + (sfe, NoEvent) -> (pSwitchAux sfs sfe, cs0) + (_, Event d0) -> sfTF (k sfs0 d0) a0 + + pSwitchAux sfs (SFArr _ (FDC NoEvent)) = parAux rf sfs + pSwitchAux sfs sfe = SF' tf -- False + where + tf dt a = + let bsfs = rf a sfs + sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs + sfs' = fmap fst sfcs' + cs = fmap snd sfcs' + in + case (sfTF' sfe) dt (a, cs) of + (sfe', NoEvent) -> (pSwitchAux sfs' sfe', cs) + (_, Event d) -> sfTF (k (freezeCol sfs dt) d) a + + +-- | Parallel switch with delayed observation parameterized on the routing +-- function. +-- +-- The collection argument to the function invoked on the +-- switching event is of particular interest: it captures the +-- continuations of the signal functions running in the collection +-- maintained by 'dpSwitch' at the time of the switching event, +-- thus making it possible to preserve their state across a switch. +-- Since the continuations are plain, ordinary signal functions, +-- they can be resumed, discarded, stored, or combined with +-- other signal functions. + +-- !!! Could be optimized on the event source being SFArr, SFArrE, SFArrEE. +-- +dpSwitch :: Functor col => + (forall sf . (a -> col sf -> col (b, sf))) -- ^ Routing function. Its purpose is + -- to pair up each running signal function in the collection + -- maintained by 'dpSwitch' with the input it is going to see + -- at each point in time. All the routing function can do is specify + -- how the input is distributed. + -> col (SF b c) -- ^ Initial collection of signal functions. + -> SF (a, col c) (Event d) -- ^ Signal function that observes the external + -- input signal and the output signals from the collection in order + -- to produce a switching event. + -> (col (SF b c) -> d -> SF a (col c)) -- ^ The fourth argument is a function that is invoked when the + -- switching event occurs, yielding a new signal function to switch + -- into based on the collection of signal functions previously + -- running and the value carried by the switching event. This + -- allows the collection to be updated and then switched back + -- in, typically by employing 'dpSwitch' again. + -> SF a (col c) +dpSwitch rf sfs0 sfe0 k = SF {sfTF = tf0} + where + tf0 a0 = + let bsfs0 = rf a0 sfs0 + sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0 + cs0 = fmap snd sfcs0 + in + (case (sfTF sfe0) (a0, cs0) of + (sfe, NoEvent) -> dpSwitchAux (fmap fst sfcs0) sfe + (_, Event d0) -> fst (sfTF (k sfs0 d0) a0), + cs0) + + dpSwitchAux sfs (SFArr _ (FDC NoEvent)) = parAux rf sfs + dpSwitchAux sfs sfe = SF' tf -- False + where + tf dt a = + let bsfs = rf a sfs + sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs + cs = fmap snd sfcs' + in + (case (sfTF' sfe) dt (a, cs) of + (sfe', NoEvent) -> dpSwitchAux (fmap fst sfcs') + sfe' + (_, Event d) -> fst (sfTF (k (freezeCol sfs dt) + d) + a), + cs) + + +-- 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 +-} + +------------------------------------------------------------------------------ +-- * Parallel composition/switchers with "zip" routing +------------------------------------------------------------------------------ + + +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") + +-- IPerez: This is actually unsafezip. Zip is actually safe. It works +-- regardless of which list is smallest. This version of zip is right-biased: +-- the second list determines the size of the final list. +safeZip :: String -> [a] -> [b] -> [(a,b)] +safeZip fn l1 l2 = safeZip' l1 l2 + where + safeZip' :: [a] -> [b] -> [(a, b)] + safeZip' _ [] = [] + safeZip' as (b:bs) = (head' as, b) : safeZip' (tail' as) bs + + head' :: [a] -> a + head' [] = err + head' (a:_) = a + + tail' :: [a] -> [a] + tail' [] = err + tail' (_:as) = as + + err :: a + err = usrErr "FRP.Yampa.Switches" fn "Input list too short." + + +-- Freezes a "running" signal function, i.e., turns it into a continuation in +-- the form of a plain signal function. +freeze :: SF' a b -> DTime -> SF a b +freeze sf dt = SF {sfTF = (sfTF' sf) dt} + +freezeCol :: Functor col => col (SF' a b) -> DTime -> col (SF a b) +freezeCol sfs dt = fmap (`freeze` dt) sfs + +-- Vim modeline +-- vim:set tabstop=8 expandtab: diff --git a/src/FRP/Yampa/Task.hs b/src/FRP/Yampa/Task.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa/Task.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE CPP, Rank2Types #-} +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.Task +-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : nilsson@cs.yale.edu +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Task abstraction on top of signal transformers. +-- +----------------------------------------------------------------------------------------- + +module FRP.Yampa.Task ( + Task, + mkTask, -- :: SF a (b, Event c) -> Task a b c + runTask, -- :: Task a b c -> SF a (Either b c) -- Might change. + runTask_, -- :: Task a b c -> SF a b + taskToSF, -- :: Task a b c -> SF a (b, Event c) -- Might change. + constT, -- :: b -> Task a b c + sleepT, -- :: Time -> b -> Task a b () + snapT, -- :: Task a b a + timeOut, -- :: Task a b c -> Time -> Task a b (Maybe c) + abortWhen, -- :: Task a b c -> SF a (Event d) -> Task a b (Either c d) + repeatUntil, -- :: Monad m => m a -> (a -> Bool) -> m a + for, -- :: Monad m => a -> (a -> a) -> (a -> Bool) -> m b -> m () + forAll, -- :: Monad m => [a] -> (a -> m b) -> m () + forEver -- :: Monad m => m a -> m b +) where + +import Control.Monad (when, forM_) +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative (Applicative(..)) +#endif + +import FRP.Yampa +import FRP.Yampa.EventS (snap) +import FRP.Yampa.Diagnostics + +infixl 0 `timeOut`, `abortWhen`, `repeatUntil` + + +------------------------------------------------------------------------------ +-- The Task type +------------------------------------------------------------------------------ + +-- CPS-based representation allowing a termination to be detected. +-- (Note the rank 2 polymorphic type!) +-- The representation can be changed if necessary, but the Monad laws +-- follow trivially in this case. +newtype Task a b c = + Task (forall d . (c -> SF a (Either b d)) -> SF a (Either b d)) + + +unTask :: Task a b c -> ((c -> SF a (Either b d)) -> SF a (Either b d)) +unTask (Task f) = f + + +mkTask :: SF a (b, Event c) -> Task a b c +mkTask st = Task (switch (st >>> first (arr Left))) + + +-- "Runs" a task (unusually bad name?). The output from the resulting +-- signal transformer is tagged with Left while the underlying task is +-- running. Once the task has terminated, the output goes constant with +-- the value Right x, where x is the value of the terminating event. +runTask :: Task a b c -> SF a (Either b c) +runTask tk = (unTask tk) (constant . Right) + + +-- 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 + + +------------------------------------------------------------------------------ +-- Functor, Applicative and Monad instance +------------------------------------------------------------------------------ + +instance Functor (Task a b) where + fmap f tk = Task (\k -> unTask tk (k . f)) + +instance Applicative (Task a b) where + pure x = Task (\k -> k x) + f <*> v = Task (\k -> (unTask f) (\c -> unTask v (k . c))) + +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 = when (p i) $ m >> for (f i) f p m + + +-- Perform the monadic operation for each element in the list. +forAll :: Monad m => [a] -> (a -> m b) -> m () +forAll = forM_ + + +-- Repeat m for ever. +forEver :: Monad m => m a -> m b +forEver m = m >> forEver m + + +-- Alternatives/other potentially useful signatures: +-- until :: a -> (a -> M a) -> (a -> Bool) -> M a +-- for: a -> b -> (a -> b -> a) -> (a -> b -> Bool) -> (a -> b -> M b) -> M b +-- while??? It could be: +-- while :: a -> (a -> Bool) -> (a -> M a) -> M a + + +------------------------------------------------------------------------------ +-- Monad transformers? +------------------------------------------------------------------------------ + +-- What about monad transformers if we want to compose this monad with +-- other capabilities??? diff --git a/src/FRP/Yampa/Time.hs b/src/FRP/Yampa/Time.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa/Time.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE GADTs, Rank2Types, CPP #-} +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.Time +-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +----------------------------------------------------------------------------------------- + +module FRP.Yampa.Time ( + localTime, -- :: SF a Time + time, -- :: SF a Time, Other name for localTime. +) where + +import Control.Arrow + +import FRP.Yampa.InternalCore (SF, Time) +import FRP.Yampa.Basic (constant) +import FRP.Yampa.Integration (integral) + +-- | 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 + +-- Vim modeline +-- vim:set tabstop=8 expandtab: diff --git a/src/FRP/Yampa/Utilities.hs b/src/FRP/Yampa/Utilities.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa/Utilities.hs @@ -0,0 +1,61 @@ +----------------------------------------------------------------------------------------- +-- | +-- Module : FRP.Yampa.Utilities +-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : nilsson@cs.yale.edu +-- Stability : provisional +-- Portability : portable +-- +-- Derived utility definitions. +-- +-- ToDo: +-- +-- * Possibly add +-- impulse :: (AffineSpace a, k ~ Scalar a, Diff k) => a -> Event a +-- But to do that, we need access to Event, which we currently do not have. +-- +-- * The general arrow utilities should be moved to a module +-- FRP.Yampa.Utilities. +-- +-- * I'm not sure structuring the Yampa \"core\" according to what is +-- core functionality and what's not is all that useful. There are +-- many cases where we want to implement combinators that fairly +-- easily could be implemented in terms of others as primitives simply +-- because we expect that that implementation is going to be much more +-- efficient, and that the combinators are used sufficiently often to +-- warrant doing this. E.g. 'switch' should be a primitive, even though +-- it could be derived from 'pSwitch'. +-- +-- * Reconsider 'recur'. If an event source has an immediate occurrence, +-- we'll get into a loop. For example: recur now. Maybe suppress +-- initial occurrences? Initial occurrences are rather pointless in this +-- case anyway. +----------------------------------------------------------------------------------------- + +module FRP.Yampa.Utilities (sampleWindow) where + +import Control.Arrow + +import FRP.Yampa.Basic +import FRP.Yampa.Core +import FRP.Yampa.EventS +import FRP.Yampa.Hybrid + +-- * Window sampling +-- First argument is the window length wl, second is the sampling interval t. +-- The output list should contain (min (truncate (T/t) wl)) samples, where +-- T is the time the signal function has been running. This requires some +-- care in case of sparse sampling. In case of sparse sampling, the +-- current input value is assumed to have been present at all points where +-- sampling was missed. + +sampleWindow :: Int -> Time -> SF a (Event [a]) +sampleWindow wl q = + identity &&& afterEachCat (repeat (q, ())) + >>> arr (\(a, e) -> fmap (map (const a)) e) + >>> accumBy updateWindow [] + where + updateWindow w as = drop (max (length w' - wl) 0) w' + where w' = w ++ as diff --git a/tests/AFRPTests.hs b/tests/AFRPTests.hs new file mode 100644 --- /dev/null +++ b/tests/AFRPTests.hs @@ -0,0 +1,192 @@ +{- $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. +-- +-- 2005-11-26: A simple way of making many test cases more robust would +-- be to have a version of deltaEncode that adds a little extra time +-- to the very first delta time. That way sampling would always be slightly +-- "late". +-- +-- But since we often compare time stamps, we'd also either have +-- to adjust the "~=" relation to tolerate "jitter" of that magnitute, +-- or we'd have to formulate many tests more carefully to allow a +-- certain "fuzziness". + +module AFRPTests where + +import FRP.Yampa +import FRP.Yampa.Task (forAll) + +import AFRPTestsCommon +import AFRPTestsArr +import AFRPTestsComp +import AFRPTestsFirstSecond +import AFRPTestsLaws +import AFRPTestsLoop +import AFRPTestsLoopLaws +import AFRPTestsBasicSF +import AFRPTestsSscan +import AFRPTestsEvSrc +import AFRPTestsCOC +import AFRPTestsSwitch +import AFRPTestsKSwitch +import AFRPTestsRSwitch +import AFRPTestsPSwitch +import AFRPTestsRPSwitch +import AFRPTestsWFG +import AFRPTestsAccum +import AFRPTestsPre +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 + && sscan_tr + && evsrc_tr + && coc_tr + && switch_tr + && kswitch_tr + && rswitch_tr + && pswitch_tr + && rpswitch_tr + && wfg_tr + && accum_tr + && pre_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), + ("sscan", sscan_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), + ("pre", pre_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) + + + diff --git a/tests/AFRPTestsAccum.hs b/tests/AFRPTestsAccum.hs new file mode 100644 --- /dev/null +++ b/tests/AFRPTestsAccum.hs @@ -0,0 +1,361 @@ +{- $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 * +* University of Nottingham, 2005 * +* * +****************************************************************************** +-} + +module AFRPTestsAccum ( + accum_tr, + accum_trs, + accum_st0, + accum_st0r, + accum_st1, + accum_st1r +) where + +import Data.Maybe (fromJust) + +import FRP.Yampa +import FRP.Yampa.Internals (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_inp5 = deltaEncode 0.25 (repeat ()) + + +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_t8 :: [Event Int] +accum_t8 = take 40 $ embed (repeatedly 1.0 1 + >>> accumBy (+) 0 + >>> accumBy (+) 0) + accum_inp5 + +accum_t8r :: [Event Int] +accum_t8r = [NoEvent, NoEvent, NoEvent, NoEvent, + Event 1, NoEvent, NoEvent, NoEvent, + Event 3, NoEvent, NoEvent, NoEvent, + Event 6, NoEvent, NoEvent, NoEvent, + Event 10, NoEvent, NoEvent, NoEvent, + Event 15, NoEvent, NoEvent, NoEvent, + Event 21, NoEvent, NoEvent, NoEvent, + Event 28, NoEvent, NoEvent, NoEvent, + Event 36, NoEvent, NoEvent, NoEvent, + Event 45, NoEvent, NoEvent, NoEvent] + + +accum_t9 :: [Int] +accum_t9 = take 40 $ embed (repeatedly 1.0 1 + >>> accumBy (+) 0 + >>> accumBy (+) 0 + >>> hold 0) + accum_inp5 + +accum_t9r :: [Int] +accum_t9r = [0,0,0,0,1,1,1,1,3,3,3,3,6,6,6,6,10,10,10,10,15,15,15,15, + 21,21,21,21,28,28,28,28,36,36,36,36,45,45,45,45] + + +accum_t10 :: [Int] +accum_t10 = take 40 $ embed (repeatedly 1.0 1 + >>> accumBy (+) 0 + >>> accumHoldBy (+) 0) + accum_inp5 + +accum_t10r :: [Int] +accum_t10r = accum_t9 -- Should agree! + + +accum_t11 :: [Int] +accum_t11 = take 40 $ embed (repeatedly 1.0 1 + >>> accumBy (+) 0 + >>> accumBy (+) 0 + >>> dHold 0) + accum_inp5 + +accum_t11r :: [Int] +accum_t11r = [0,0,0,0,0,1,1,1,1,3,3,3,3,6,6,6,6,10,10,10,10,15,15,15, + 15,21,21,21,21,28,28,28,28,36,36,36,36,45,45,45] + + +accum_t12 :: [Int] +accum_t12 = take 40 $ embed (repeatedly 1.0 1 + >>> accumBy (+) 0 + >>> dAccumHoldBy (+) 0) + accum_inp5 + +accum_t12r :: [Int] +accum_t12r = accum_t11 -- Should agree! + + +accum_accFiltFun3 :: Int -> Int -> (Int, Maybe Int) +accum_accFiltFun3 s a = + let s' = s + a + in + if odd s' then + (s', Just s') + else + (s', Nothing) + + +accum_t13 :: [Event Int] +accum_t13 = take 40 $ embed (repeatedly 1.0 1 + >>> accumFilter accum_accFiltFun3 0 + >>> accumBy (+) 0 + >>> accumBy (+) 0) + accum_inp5 + +accum_t13r :: [Event Int] +accum_t13r = [NoEvent, NoEvent, NoEvent, NoEvent, + Event 1, NoEvent, NoEvent, NoEvent, + NoEvent, NoEvent, NoEvent, NoEvent, + Event 5, NoEvent, NoEvent, NoEvent, + NoEvent, NoEvent, NoEvent, NoEvent, + Event 14, NoEvent, NoEvent, NoEvent, + NoEvent, NoEvent, NoEvent, NoEvent, + Event 30, NoEvent, NoEvent, NoEvent, + NoEvent, NoEvent, NoEvent, NoEvent, + Event 55, NoEvent, NoEvent, NoEvent] + + +accum_t14 :: [Int] +accum_t14 = take 40 $ embed (repeatedly 1.0 1 + >>> accumFilter accum_accFiltFun3 0 + >>> accumBy (+) 0 + >>> accumBy (+) 0 + >>> hold 0) + accum_inp5 + +accum_t14r :: [Int] +accum_t14r = [0,0,0,0,1,1,1,1,1,1,1,1,5,5,5,5,5,5,5,5,14,14,14,14, + 14,14,14,14,30,30,30,30,30,30,30,30,55,55,55,55] + + +accum_t15 :: [Int] +accum_t15 = take 40 $ embed (repeatedly 1.0 1 + >>> accumFilter accum_accFiltFun3 0 + >>> accumBy (+) 0 + >>> accumHoldBy (+) 0) + accum_inp5 + +accum_t15r :: [Int] +accum_t15r = accum_t14 -- Should agree! + + +accum_t16 :: [Int] +accum_t16 = take 40 $ embed (repeatedly 1.0 1 + >>> accumFilter accum_accFiltFun3 0 + >>> accumBy (+) 0 + >>> accumBy (+) 0 + >>> dHold 0) + accum_inp5 + +accum_t16r :: [Int] +accum_t16r = [0,0,0,0,0,1,1,1,1,1,1,1,1,5,5,5,5,5,5,5,5,14,14,14, + 14,14,14,14,14,30,30,30,30,30,30,30,30,55,55,55] + + +accum_t17 :: [Int] +accum_t17 = take 40 $ embed (repeatedly 1.0 1 + >>> accumFilter accum_accFiltFun3 0 + >>> accumBy (+) 0 + >>> dAccumHoldBy (+) 0) + accum_inp5 + +accum_t17r :: [Int] +accum_t17r = accum_t16 -- 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_t8 == accum_t8r, + accum_t9 == accum_t9r, + accum_t10 == accum_t10r, + accum_t11 == accum_t11r, + accum_t12 == accum_t12r, + accum_t13 == accum_t13r, + accum_t14 == accum_t14r, + accum_t15 == accum_t15r, + accum_t16 == accum_t16r, + accum_t17 == accum_t17r + ] + +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 diff --git a/tests/AFRPTestsArr.hs b/tests/AFRPTestsArr.hs new file mode 100644 --- /dev/null +++ b/tests/AFRPTestsArr.hs @@ -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 FRP.Yampa + +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 diff --git a/tests/AFRPTestsBasicSF.hs b/tests/AFRPTestsBasicSF.hs new file mode 100644 --- /dev/null +++ b/tests/AFRPTestsBasicSF.hs @@ -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 FRP.Yampa + +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 diff --git a/tests/AFRPTestsCOC.hs b/tests/AFRPTestsCOC.hs new file mode 100644 --- /dev/null +++ b/tests/AFRPTestsCOC.hs @@ -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 FRP.Yampa + +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 diff --git a/tests/AFRPTestsCommon.hs b/tests/AFRPTestsCommon.hs new file mode 100644 --- /dev/null +++ b/tests/AFRPTestsCommon.hs @@ -0,0 +1,167 @@ +{- $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 System.IO.Unsafe (unsafePerformIO) +import Data.IORef (newIORef, writeIORef, readIORef) + +import FRP.Yampa + +------------------------------------------------------------------------------ +-- 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 + && x5 ~= y5 + +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..] :: [Int] ] + 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 + + -- return output + readIORef outputr + +------------------------------------------------------------------------------ +-- Some utilities used for testing laws +------------------------------------------------------------------------------ + +assoc :: ((a,b),c) -> (a,(b,c)) +assoc ((a,b),c) = (a,(b,c)) + +assocInv :: (a,(b,c)) -> ((a,b),c) +assocInv (a,(b,c)) = ((a,b),c) diff --git a/tests/AFRPTestsComp.hs b/tests/AFRPTestsComp.hs new file mode 100644 --- /dev/null +++ b/tests/AFRPTestsComp.hs @@ -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 FRP.Yampa + +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 diff --git a/tests/AFRPTestsDelay.hs b/tests/AFRPTestsDelay.hs new file mode 100644 --- /dev/null +++ b/tests/AFRPTestsDelay.hs @@ -0,0 +1,88 @@ +{- $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 FRP.Yampa + +import AFRPTestsCommon + +------------------------------------------------------------------------------ +-- Test cases for delays +------------------------------------------------------------------------------ + +delay_t0 = testSF1 (delay 0.0 undefined) +delay_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] + +delay_t1 = testSF1 (delay 0.0001 17) +delay_t1r = + [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_t2 = testSF2 (delay 0.0001 17) +delay_t2r = + [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_t3 = testSF1 (time + >>> arr (\t -> sin (0.5 * t * pi + pi)) + >>> loop (arr (\(x1,x2) -> let x' = max x1 x2 in (x',x')) + >>> second (delay 0.0001 0.0))) +delay_t3r = + take 25 + (let xs = [ sin (0.5 * t * pi + pi) | t <- [0.0, 0.25 ..] ] + in tail (scanl max 0 xs)) + +dts_t4 = take 15 (repeat 0.1) + ++ [0.5, 0.5] + ++ take 15 (repeat 0.1) + ++ [2.0] + ++ take 20 (repeat 0.1) + +input_t4 = (0, [ (dt, Just i) | (dt, i) <- zip dts_t4 [1..] ]) + +delay_t4, delay_t4r :: [Int] +delay_t4 = take 100 (embed (delay 1.05 (-1)) input_t4) +delay_t4r = + [ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -- 0.0 s -- 0.9 s + -1, 0, 1, 2, 3, 4, -- 1.0 s -- 1.5 s + 9, 14, 15, 15, 15, 15, -- 2.0 s -- 2.9 s + 15, 16, 16, 16, 16, 16, 17, 18, 19, 20, -- 3.0 s -- 3.9 s + 21, -- 4.0 s + 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, -- 6.0 s -- 6.9 s + 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, -- 7.0 s -- 7.9 s + 42 -- 8.0 s + ] + + +delay_t5 = take 100 (drop 6 (embed sf (deltaEncode 0.1 (repeat ())))) + where + sf = time >>> arr (\t -> sin (2*pi*t)) >>> delay 0.55 (-1.0) + +delay_t5r = take 100 (drop 6 (embed sf (deltaEncode 0.1 (repeat ())))) + where + sf = time >>> arr (\t -> sin (2*pi*(t-0.6))) + + +delay_trs = + [ delay_t0 ~= delay_t0r, + delay_t1 ~= delay_t1r, + delay_t2 ~= delay_t2r, + delay_t3 ~= delay_t3r, + delay_t4 == delay_t4r, + delay_t5 ~= delay_t5r + ] + +delay_tr = and delay_trs diff --git a/tests/AFRPTestsDer.hs b/tests/AFRPTestsDer.hs new file mode 100644 --- /dev/null +++ b/tests/AFRPTestsDer.hs @@ -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 FRP.Yampa + +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 diff --git a/tests/AFRPTestsEmbed.hs b/tests/AFRPTestsEmbed.hs new file mode 100644 --- /dev/null +++ b/tests/AFRPTestsEmbed.hs @@ -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 FRP.Yampa + +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 diff --git a/tests/AFRPTestsEvSrc.hs b/tests/AFRPTestsEvSrc.hs new file mode 100644 --- /dev/null +++ b/tests/AFRPTestsEvSrc.hs @@ -0,0 +1,584 @@ +{- $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 FRP.Yampa +import FRP.Yampa.Internals (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.29999 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), (0.00, 11), (0.00, 12)]) + +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 [Int]] +evsrc_t10 = testSF1 (afterEachCat [(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_t10r :: [Event [Int]] +evsrc_t10r = + [Event [1,2], Event [3,4], Event [5], NoEvent, -- 0.0 s + NoEvent, Event [6,7,8], 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_t11 :: [Event [Int]] +evsrc_t11 = testSF1 (afterEachCat [(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_t11r :: [Event [Int]] +evsrc_t11r = + [NoEvent, NoEvent, NoEvent, NoEvent, -- 0.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 1.0 s + NoEvent, Event [0,1,2,3], Event [4,5], NoEvent, -- 2.0 s + NoEvent, Event [6,7,8], Event [9], NoEvent, -- 3.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 4.0 s + NoEvent, NoEvent, Event [10], NoEvent, -- 5.0 s + NoEvent] + + +evsrc_t12 :: [Event ()] +evsrc_t12 = testSF1 (localTime >>> arr (>=0) >>> edge) + +evsrc_t12r = + [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_t13 :: [Event ()] +evsrc_t13 = testSF1 (localTime >>> arr (>=4.26) >>> edge) + +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 edge detector. +evsrc_isEdge False False = Nothing +evsrc_isEdge False True = Just () +evsrc_isEdge True True = Nothing +evsrc_isEdge True False = Nothing + + +evsrc_t14 :: [Event ()] +evsrc_t14 = testSF1 (localTime >>> arr (>=0) >>> edgeBy evsrc_isEdge False) + +evsrc_t14r = + [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_t15 :: [Event ()] +evsrc_t15 = testSF1 (localTime >>> arr (>=4.26) >>> edgeBy evsrc_isEdge False) + +evsrc_t15r = + [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_t16 :: [Event Bool] +evsrc_t16 = testSF1 (localTime + >>> arr (\t -> t >=2.01 && t <= 4.51) + >>> edgeBy evsrc_isEdge2 True) + +evsrc_t16r = + [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_t17 :: [Event Int] +evsrc_t17 = testSF1 (now 17 &&& repeatedly 0.795 42 + >>> arr (uncurry merge) + >>> notYet) + +evsrc_t17r :: [Event Int] +evsrc_t17r = + [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_t18 :: [Event Int] +evsrc_t18 = testSF1 (now 42 >>> once) + +evsrc_t18r :: [Event Int] +evsrc_t18r = + [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_t19 :: [Event Int] +evsrc_t19 = testSF1 (repeatedly 0.8 42 >>> once) + +evsrc_t19r :: [Event Int] +evsrc_t19r = + [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_t20 :: [Event Int] +evsrc_t20 = testSF1 (now 42 >>> takeEvents 0) + +evsrc_t20r :: [Event Int] +evsrc_t20r = + [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_t21 :: [Event Int] +evsrc_t21 = testSF1 (now 42 >>> takeEvents 1) + +evsrc_t21r :: [Event Int] +evsrc_t21r = + [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_t22 :: [Event Int] +evsrc_t22 = testSF1 (repeatedly 0.8 42 >>> takeEvents 4) + +evsrc_t22r :: [Event Int] +evsrc_t22r = + [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_t23 :: [Event Int] +evsrc_t23 = testSF1 (repeatedly 0.2 42 >>> takeEvents 4) + +evsrc_t23r :: [Event Int] +evsrc_t23r = + [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_t24 :: [Event Int] +evsrc_t24 = testSF1 (now 42 >>> dropEvents 0) + +evsrc_t24r :: [Event Int] +evsrc_t24r = + [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_t25 :: [Event Int] +evsrc_t25 = testSF1 (now 42 >>> dropEvents 1) + +evsrc_t25r :: [Event Int] +evsrc_t25r = + [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_t26 :: [Event Int] +-- Drop 5 events to get rid of the event at 4.0 s which may or may not happen +-- exactly there. +evsrc_t26 = testSF1 (repeatedly 0.8 42 >>> dropEvents 5) + +evsrc_t26r :: [Event Int] +evsrc_t26r = + [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_t27 :: [Event Int] +evsrc_t27 = testSF1 (repeatedly 0.2 42 >>> dropEvents 4) + +evsrc_t27r :: [Event Int] +evsrc_t27r = + [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_t28 :: [(Event Int, Event Int)] +evsrc_t28 = embed (repeatedly 0.5 () + >>> accumBy (\n _ -> n + 1) 0 + >>> identity &&& delayEvent 2.0) + (deltaEncode 0.125 (replicate 50 ())) + +evsrc_t28r = + [ (NoEvent,NoEvent), (NoEvent,NoEvent), -- 0.0 s + (NoEvent,NoEvent), (NoEvent,NoEvent), + (Event 1,NoEvent), (NoEvent,NoEvent), -- 0.5 s + (NoEvent,NoEvent), (NoEvent,NoEvent), + (Event 2,NoEvent), (NoEvent,NoEvent), -- 1.0 s + (NoEvent,NoEvent), (NoEvent,NoEvent), + (Event 3,NoEvent), (NoEvent,NoEvent), -- 1.5 s + (NoEvent,NoEvent), (NoEvent,NoEvent), + (Event 4,NoEvent), (NoEvent,NoEvent), -- 2.0 s + (NoEvent,NoEvent), (NoEvent,NoEvent), + (Event 5,Event 1), (NoEvent,NoEvent), -- 2.5 s + (NoEvent,NoEvent), (NoEvent,NoEvent), + (Event 6,Event 2), (NoEvent,NoEvent), -- 3.0 s + (NoEvent,NoEvent), (NoEvent,NoEvent), + (Event 7,Event 3), (NoEvent,NoEvent), -- 3.5 s + (NoEvent,NoEvent), (NoEvent,NoEvent), + (Event 8,Event 4), (NoEvent,NoEvent), -- 4.0 s + (NoEvent,NoEvent), (NoEvent,NoEvent), + (Event 9,Event 5), (NoEvent,NoEvent), -- 4.5 s + (NoEvent,NoEvent), (NoEvent,NoEvent), + (Event 10,Event 6), (NoEvent,NoEvent), -- 5.0 s + (NoEvent,NoEvent), (NoEvent,NoEvent), + (Event 11,Event 7), (NoEvent,NoEvent), -- 5.5 s + (NoEvent,NoEvent), (NoEvent,NoEvent), + (Event 12,Event 8), (NoEvent,NoEvent) -- 6.0 s + ] + +evsrc_t29 :: [Event [Double]] +evsrc_t29 = embed (time &&& repeatedly 0.5001 () + >>> arr (\(t,e) -> e `tag` t) + >>> delayEventCat 3.0) + input + where + dts = replicate 40 0.1 ++ [2.0] ++ replicate 40 0.1 + input = ((), [(dt, Just ()) | dt <- dts]) + +{- Resulting input to the delay for reference: +[ NoEvent, NoEvent, NoEvent, NoEvent, NoEvent, -- 0.0 s + NoEvent, Event 0.6, NoEvent, NoEvent, NoEvent, -- 0.5 s + NoEvent, Event 1.1, NoEvent, NoEvent, NoEvent, -- 1.0 s + NoEvent, Event 1.6, NoEvent, NoEvent, NoEvent, -- 1.5 s + NoEvent, Event 2.1, NoEvent, NoEvent, NoEvent, -- 2.0 s + NoEvent, Event 2.6, NoEvent, NoEvent, NoEvent, -- 2.5 s + NoEvent, Event 3.1, NoEvent, NoEvent, NoEvent, -- 3.0 s + NoEvent, Event 3.6, NoEvent, NoEvent, NoEvent, -- 3.5 s + NoEvent, -- 4.0 s + Event 6.0, Event 6.1, NoEvent, NoEvent, NoEvent, -- 6.0 s + NoEvent, Event 6.6, NoEvent, NoEvent, NoEvent, -- 6.5 s + NoEvent, Event 7.1, NoEvent, NoEvent, NoEvent, -- 7.0 s + NoEvent, Event 7.6, NoEvent, NoEvent, NoEvent, -- 7.5 s + NoEvent, Event 8.1, NoEvent, NoEvent, NoEvent, -- 8.0 s + NoEvent, Event 8.6, NoEvent, NoEvent, NoEvent, -- 8.5 s + NoEvent, Event 9.1, NoEvent, NoEvent, NoEvent, -- 9.0 s + NoEvent, Event 9.6, NoEvent, NoEvent, NoEvent, -- 9.5 s + NoEvent ] -- 10.0 s +-} + +evsrc_t29r = + [ NoEvent, NoEvent, NoEvent, NoEvent, NoEvent, -- 0.0 s + NoEvent, NoEvent, NoEvent, NoEvent, NoEvent, -- 0.5 s + NoEvent, NoEvent, NoEvent, NoEvent, NoEvent, -- 1.0 s + NoEvent, NoEvent, NoEvent, NoEvent, NoEvent, -- 1.5 s + NoEvent, NoEvent, NoEvent, NoEvent, NoEvent, -- 2.0 s + NoEvent, NoEvent, NoEvent, NoEvent, NoEvent, -- 2.5 s + NoEvent, NoEvent, NoEvent, NoEvent, NoEvent, -- 3.0 s + NoEvent, Event [0.6], NoEvent, NoEvent, NoEvent, -- 3.5 s + NoEvent, -- 4.0 s + Event [1.1, 1.6, 2.1, 2.6], -- 6.0 s + NoEvent, Event [3.1], NoEvent, NoEvent, + NoEvent, NoEvent, Event [3.6], NoEvent, NoEvent, -- 6.5 s + NoEvent, NoEvent, NoEvent, NoEvent, NoEvent, -- 7.0 s + NoEvent, NoEvent, NoEvent, NoEvent, NoEvent, -- 7.5 s + NoEvent, NoEvent, NoEvent, NoEvent, NoEvent, -- 8.0 s + NoEvent, NoEvent, NoEvent, NoEvent, NoEvent, -- 8.5 s + NoEvent, Event [6.0], Event [6.1], NoEvent, NoEvent, -- 9.0 s + NoEvent, NoEvent, Event [6.6], NoEvent, NoEvent, -- 9.5 s + NoEvent -- 10.0 s + ] + +-- "delayEvent" in a feedback loop. Should work like "repeatedly". +evsrc_t30 :: [(Event ())] +evsrc_t30 = embed (now () + >>> (loop $ + arr (uncurry lMerge) + >>> delayEvent 1.0 + >>> arr dup)) + (deltaEncode 0.125 (replicate 50 ())) + + +evsrc_t30r :: [(Event ())] +evsrc_t30r = + [ NoEvent, NoEvent, NoEvent, NoEvent, -- 0.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 0.5 s + Event (), NoEvent, NoEvent, NoEvent, -- 1.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 1.5 s + Event (), NoEvent, NoEvent, NoEvent, -- 2.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 2.5 s + Event (), NoEvent, NoEvent, NoEvent, -- 3.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 3.5 s + Event (), NoEvent, NoEvent, NoEvent, -- 4.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 4.5 s + Event (), NoEvent, NoEvent, NoEvent, -- 5.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 5.5 s + Event (), NoEvent -- 6.0 s + ] + + +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_t26 ~= evsrc_t26r, + evsrc_t27 ~= evsrc_t27r, + evsrc_t28 ~= evsrc_t28r, + evsrc_t29 ~= evsrc_t29r, + evsrc_t30 ~= evsrc_t30r + ] + +evsrc_tr = and evsrc_trs diff --git a/tests/AFRPTestsFirstSecond.hs b/tests/AFRPTestsFirstSecond.hs new file mode 100644 --- /dev/null +++ b/tests/AFRPTestsFirstSecond.hs @@ -0,0 +1,127 @@ +{- $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 Data.Tuple (swap) + +import FRP.Yampa + +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 diff --git a/tests/AFRPTestsKSwitch.hs b/tests/AFRPTestsKSwitch.hs new file mode 100644 --- /dev/null +++ b/tests/AFRPTestsKSwitch.hs @@ -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 FRP.Yampa + +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 diff --git a/tests/AFRPTestsLaws.hs b/tests/AFRPTestsLaws.hs new file mode 100644 --- /dev/null +++ b/tests/AFRPTestsLaws.hs @@ -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 FRP.Yampa + +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 ((*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 (id *** (+3.0)))) +laws_t6_rhs :: [(Double, Double)] +laws_t6_rhs = testSF1 (arr dup >>> (arr (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 diff --git a/tests/AFRPTestsLoop.hs b/tests/AFRPTestsLoop.hs new file mode 100644 --- /dev/null +++ b/tests/AFRPTestsLoop.hs @@ -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 FRP.Yampa + +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 diff --git a/tests/AFRPTestsLoopIntegral.hs b/tests/AFRPTestsLoopIntegral.hs new file mode 100644 --- /dev/null +++ b/tests/AFRPTestsLoopIntegral.hs @@ -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 FRP.Yampa + +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 diff --git a/tests/AFRPTestsLoopLaws.hs b/tests/AFRPTestsLoopLaws.hs new file mode 100644 --- /dev/null +++ b/tests/AFRPTestsLoopLaws.hs @@ -0,0 +1,109 @@ +{- $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 Data.Tuple(swap) + +import FRP.Yampa + +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 = 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 assocInv >>> 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 assocInv))) + + +-- 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 diff --git a/tests/AFRPTestsLoopPre.hs b/tests/AFRPTestsLoopPre.hs new file mode 100644 --- /dev/null +++ b/tests/AFRPTestsLoopPre.hs @@ -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 FRP.Yampa + +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 diff --git a/tests/AFRPTestsPSwitch.hs b/tests/AFRPTestsPSwitch.hs new file mode 100644 --- /dev/null +++ b/tests/AFRPTestsPSwitch.hs @@ -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 Data.List (findIndex) + +import FRP.Yampa +import FRP.Yampa.Internals (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) diff --git a/tests/AFRPTestsPre.hs b/tests/AFRPTestsPre.hs new file mode 100644 --- /dev/null +++ b/tests/AFRPTestsPre.hs @@ -0,0 +1,208 @@ +{- $Id: AFRPTestsDelay.hs,v 1.2 2003/11/10 21:28:58 antony Exp $ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTestsPre * +* Purpose: Test cases for pre and (derived) combinators * +* that (semantically) involves a pre. * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* Copyright (c) University of Nottingham, 2005 * +* * +****************************************************************************** +-} + +module AFRPTestsPre (pre_tr, pre_trs) where + +import FRP.Yampa + +import AFRPTestsCommon + +------------------------------------------------------------------------------ +-- Test cases for pre and related combinators +------------------------------------------------------------------------------ + +pre_t0 = testSF1 (iPre 17) +pre_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] + +pre_t1 = testSF2 (iPre 17) +pre_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] + +pre_t2 = testSF1 (time + >>> arr (\t -> sin (0.5 * t * pi + pi)) + >>> loop (arr (\(x1,x2) -> let x' = max x1 x2 in (x',x')) + >>> second (iPre 0.0))) + +pre_t2r = + take 25 + (let xs = [ sin (0.5 * t * pi + pi) | t <- [0.0, 0.25 ..] ] + in tail (scanl max 0 xs)) + + +-- This is a (somewhat strange) way of doing a counter that +-- stops after reaching a threshold. Note that the ingoing event +-- is *control dependent* on the output of the counter, so +-- "dHold" really has to have the capability of delivering an +-- output without looking at the current input at all. +pre_t3, pre_t3r :: [Int] +pre_t3 = take 50 (embed sf (deltaEncode 0.25 (repeat ()))) + where + sf = repeatedly 1.0 () + >>> (loop $ + arr (\(e,c) -> (e `tag` (c + 1)) `gate` (c < 10)) + >>> dHold 0 + >>> arr dup) +pre_t3r = [0,0,0,0, -- 0s + 0,1,1,1, -- 1s + 1,2,2,2, -- 2s + 2,3,3,3, -- 3s + 3,4,4,4, -- 4s + 4,5,5,5, -- 5s + 5,6,6,6, -- 6s + 6,7,7,7, -- 7s + 7,8,8,8, -- 8s + 8,9,9,9, -- 9s + 9,10,10,10, -- 10s + 10,10,10,10, -- 11s + 10,10] -- 12s + +-- Version of the above that tests that thigs still work OK also if +-- there is an initial event. +pre_t4, pre_t4r :: [Int] +pre_t4 = take 50 (embed sf (deltaEncode 0.25 (repeat ()))) + where + sf = (now () &&& repeatedly 1.0 ()) >>> arr (uncurry lMerge) + >>> (loop $ + arr (\(e,c) -> (e `tag` (c + 1)) `gate` (c < 10)) + >>> dHold 0 + >>> arr dup) +pre_t4r = [0,1,1,1, -- 0s + 1,2,2,2, -- 1s + 2,3,3,3, -- 2s + 3,4,4,4, -- 3s + 4,5,5,5, -- 4s + 5,6,6,6, -- 5s + 6,7,7,7, -- 6s + 7,8,8,8, -- 7s + 8,9,9,9, -- 8s + 9,10,10,10, -- 9s + 10,10,10,10, -- 10s + 10,10,10,10, -- 11s + 10,10] -- 12s + + +-- Similar test to "pre_t3" above but for dAccumHold. +pre_t5, pre_t5r :: [Int] +pre_t5 = take 50 (embed sf (deltaEncode 0.25 (repeat ()))) + where + sf = repeatedly 1.0 () + >>> (loop $ + arr (\(e,c) -> (e `tag` (+1)) `gate` (c < 10)) + >>> dAccumHold 0 + >>> arr dup) +pre_t5r = [0,0,0,0, -- 0s + 0,1,1,1, -- 1s + 1,2,2,2, -- 2s + 2,3,3,3, -- 3s + 3,4,4,4, -- 4s + 4,5,5,5, -- 5s + 5,6,6,6, -- 6s + 6,7,7,7, -- 7s + 7,8,8,8, -- 8s + 8,9,9,9, -- 9s + 9,10,10,10, -- 10s + 10,10,10,10, -- 11s + 10,10] -- 12s + + +-- Similar test to "pre_t4" above but for dAccumHold. +pre_t6, pre_t6r :: [Int] +pre_t6 = take 50 (embed sf (deltaEncode 0.25 (repeat ()))) + where + sf = (now () &&& repeatedly 1.0 ()) >>> arr (uncurry lMerge) + >>> (loop $ + arr (\(e,c) -> (e `tag` (+1)) `gate` (c < 10)) + >>> dAccumHold 0 + >>> arr dup) +pre_t6r = [0,1,1,1, -- 0s + 1,2,2,2, -- 1s + 2,3,3,3, -- 2s + 3,4,4,4, -- 3s + 4,5,5,5, -- 4s + 5,6,6,6, -- 5s + 6,7,7,7, -- 6s + 7,8,8,8, -- 7s + 8,9,9,9, -- 8s + 9,10,10,10, -- 9s + 10,10,10,10, -- 10s + 10,10,10,10, -- 11s + 10,10] -- 12s + + +-- Similar test to "pre_t3" above but for dAccumHoldBy. +pre_t7, pre_t7r :: [Int] +pre_t7 = take 50 (embed sf (deltaEncode 0.25 (repeat ()))) + where + sf = repeatedly 1.0 () + >>> (loop $ + arr (\(e,c) -> e `gate` (c < 10)) + >>> dAccumHoldBy (\c _ -> c + 1) 0 + >>> arr dup) +pre_t7r = [0,0,0,0, -- 0s + 0,1,1,1, -- 1s + 1,2,2,2, -- 2s + 2,3,3,3, -- 3s + 3,4,4,4, -- 4s + 4,5,5,5, -- 5s + 5,6,6,6, -- 6s + 6,7,7,7, -- 7s + 7,8,8,8, -- 8s + 8,9,9,9, -- 9s + 9,10,10,10, -- 10s + 10,10,10,10, -- 11s + 10,10] -- 12s + + +-- Similar test to "pre_t4" above but for dAccumHoldBy. +pre_t8, pre_t8r :: [Int] +pre_t8 = take 50 (embed sf (deltaEncode 0.25 (repeat ()))) + where + sf = (now () &&& repeatedly 1.0 ()) >>> arr (uncurry lMerge) + >>> (loop $ + arr (\(e,c) -> e `gate` (c < 10)) + >>> dAccumHoldBy (\c _ -> c + 1) 0 + >>> arr dup) +pre_t8r = [0,1,1,1, -- 0s + 1,2,2,2, -- 1s + 2,3,3,3, -- 2s + 3,4,4,4, -- 3s + 4,5,5,5, -- 4s + 5,6,6,6, -- 5s + 6,7,7,7, -- 6s + 7,8,8,8, -- 7s + 8,9,9,9, -- 8s + 9,10,10,10, -- 9s + 10,10,10,10, -- 10s + 10,10,10,10, -- 11s + 10,10] -- 12s + + + +pre_trs = + [ pre_t0 ~= pre_t0r, + pre_t1 ~= pre_t1r, + pre_t2 ~= pre_t2r, + pre_t3 == pre_t3r, + pre_t4 == pre_t4r, + pre_t5 == pre_t5r, + pre_t6 == pre_t6r, + pre_t7 == pre_t7r, + pre_t8 == pre_t8r + ] + +pre_tr = and pre_trs diff --git a/tests/AFRPTestsRPSwitch.hs b/tests/AFRPTestsRPSwitch.hs new file mode 100644 --- /dev/null +++ b/tests/AFRPTestsRPSwitch.hs @@ -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 Data.Maybe (fromJust) +import Data.List (findIndex) + +import FRP.Yampa +import FRP.Yampa.Internals (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] diff --git a/tests/AFRPTestsRSwitch.hs b/tests/AFRPTestsRSwitch.hs new file mode 100644 --- /dev/null +++ b/tests/AFRPTestsRSwitch.hs @@ -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 Data.Maybe (fromJust) + +import FRP.Yampa +import FRP.Yampa.Internals (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 diff --git a/tests/AFRPTestsReact.hs b/tests/AFRPTestsReact.hs new file mode 100644 --- /dev/null +++ b/tests/AFRPTestsReact.hs @@ -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 System.IO.Unsafe (unsafePerformIO) +import Data.IORef (newIORef, writeIORef, readIORef) + +import FRP.Yampa + +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 diff --git a/tests/AFRPTestsSscan.hs b/tests/AFRPTestsSscan.hs new file mode 100644 --- /dev/null +++ b/tests/AFRPTestsSscan.hs @@ -0,0 +1,478 @@ +{- $Id$ +****************************************************************************** +* A F R P * +* * +* Module: AFRPTestsSscan * +* Purpose: Test cases for pre sscan * +* Authors: Antony Courtney and Henrik Nilsson * +* * +* Copyright (c) Yale University, 2003 * +* Copyright (c) University of Nottingham, 2005 * +* * +****************************************************************************** +-} + +module AFRPTestsSscan (sscan_tr, sscan_trs) where + +import FRP.Yampa +import FRP.Yampa.Internals + +import AFRPTestsCommon + +------------------------------------------------------------------------------ +-- Test cases sscan +------------------------------------------------------------------------------ + +-- pre and iPre in terms of sscan +pre_sscan :: SF a a +pre_sscan = sscanPrim f uninit uninit + where + f c a = Just (a, c) + uninit = error "pre_sscan: Uninitialized pre operator." + +iPre_sscan :: a -> SF a a +iPre_sscan = (--> pre_sscan) + + +sscan_t0, sscan_t0r :: [Double] +sscan_t0 = testSF1 (iPre_sscan 17) +sscan_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] + + +sscan_t1, sscan_t1r :: [Double] +sscan_t1 = testSF2 (iPre_sscan 17) +sscan_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] + + +sscan_t2, sscan_t2r :: [Double] +sscan_t2 = testSF1 (time + >>> arr (\t -> sin (0.5 * t * pi + pi)) + >>> loop (arr (\(x1,x2) -> let x' = max x1 x2 in (x',x')) + >>> second (iPre_sscan 0.0))) +sscan_t2r = + take 25 + (let xs = [ sin (0.5 * t * pi + pi) | t <- [0.0, 0.25 ..] ] + in tail (scanl max 0 xs)) + + + +sscan_t3, sscan_t3r :: [Double] +sscan_t3 = testSF1 (time + >>> arr (\t -> sin (0.5 * t * pi + pi)) + >>> sscan max 0.0) + +sscan_t3r = + take 25 + (let xs = [ sin (0.5 * t * pi + pi) | t <- [0.0, 0.25 ..] ] + in tail (scanl max 0 xs)) + + +hold_sscan :: a -> SF (Event a) a +hold_sscan a = sscanPrim f () a + where + f _ NoEvent = Nothing + f _ (Event a) = Just ((), a) + + +dHold_sscan :: a -> SF (Event a) a +dHold_sscan a = hold_sscan a >>> iPre_sscan a + + +-- This is a (somewhat strange) way of doing a counter that +-- stops after reaching a threshold. Note that the ingoing event +-- is *control dependent* on the output of the counter, so +-- "dHold" really has to have the capability of delivering an +-- output without looking at the current input at all. +sscan_t4, sscan_t4r :: [Int] +sscan_t4 = take 50 (embed sf (deltaEncode 0.25 (repeat ()))) + where + sf = repeatedly 1.0 () + >>> (loop $ + arr (\(e,c) -> (e `tag` (c + 1)) `gate` (c < 10)) + >>> dHold_sscan 0 + >>> arr dup) +sscan_t4r = [0,0,0,0, -- 0s + 0,1,1,1, -- 1s + 1,2,2,2, -- 2s + 2,3,3,3, -- 3s + 3,4,4,4, -- 4s + 4,5,5,5, -- 5s + 5,6,6,6, -- 6s + 6,7,7,7, -- 7s + 7,8,8,8, -- 8s + 8,9,9,9, -- 9s + 9,10,10,10, -- 10s + 10,10,10,10, -- 11s + 10,10] -- 12s + +-- Version of the above that tests that thigs still work OK also if +-- there is an initial event. +sscan_t5, sscan_t5r :: [Int] +sscan_t5 = take 50 (embed sf (deltaEncode 0.25 (repeat ()))) + where + sf = (now () &&& repeatedly 1.0 ()) >>> arr (uncurry lMerge) + >>> (loop $ + arr (\(e,c) -> (e `tag` (c + 1)) `gate` (c < 10)) + >>> dHold_sscan 0 + >>> arr dup) +sscan_t5r = [0,1,1,1, -- 0s + 1,2,2,2, -- 1s + 2,3,3,3, -- 2s + 3,4,4,4, -- 3s + 4,5,5,5, -- 4s + 5,6,6,6, -- 5s + 6,7,7,7, -- 6s + 7,8,8,8, -- 7s + 8,9,9,9, -- 8s + 9,10,10,10, -- 9s + 10,10,10,10, -- 10s + 10,10,10,10, -- 11s + 10,10] -- 12s + + +-- Version of the sscan_t4 in terms of sscan +sscan_t6, sscan_t6r :: [Int] +sscan_t6 = take 50 (embed sf (deltaEncode 0.25 (repeat ()))) + where + sf = repeatedly 1.0 () >>> (sscanPrim f 0 0) + + f c NoEvent = Nothing + f c (Event _) | c < 10 = Just (c', c') + | otherwise = Nothing + where + c' = c + 1 + + +sscan_t6r = [0,0,0,0, -- 0s + 1,1,1,1, -- 1s + 2,2,2,2, -- 2s + 3,3,3,3, -- 3s + 4,4,4,4, -- 4s + 5,5,5,5, -- 5s + 6,6,6,6, -- 6s + 7,7,7,7, -- 7s + 8,8,8,8, -- 8s + 9,9,9,9, -- 9s + 10,10,10,10, -- 10s + 10,10,10,10, -- 11s + 10,10] -- 12s + +-- Version of sscan_t5 directly in terms of sscan. +sscan_t7, sscan_t7r :: [Int] +sscan_t7 = take 50 (embed sf (deltaEncode 0.25 (repeat ()))) + where + sf = (now () &&& repeatedly 1.0 ()) >>> arr (uncurry lMerge) + >>> (sscanPrim f 0 0) + + f c NoEvent = Nothing + f c (Event _) | c < 10 = Just (c', c') + | otherwise = Nothing + where + c' = c + 1 + + +sscan_t7r = [1,1,1,1, -- 0s + 2,2,2,2, -- 1s + 3,3,3,3, -- 2s + 4,4,4,4, -- 3s + 5,5,5,5, -- 4s + 6,6,6,6, -- 5s + 7,7,7,7, -- 6s + 8,8,8,8, -- 7s + 9,9,9,9, -- 8s + 10,10,10,10, -- 9s + 10,10,10,10, -- 10s + 10,10,10,10, -- 11s + 10,10] -- 12s + + +edge_sscan :: SF Bool (Event ()) +edge_sscan = sscanPrim f 2 NoEvent + where + f 0 False = Nothing + f 0 True = Just (1, Event ()) + f 1 False = Just (0, NoEvent) + f 1 True = Just (2, NoEvent) + f 2 False = Just (0, NoEvent) + f 2 True = Nothing + + +sscan_t8 :: [Event ()] +sscan_t8 = testSF1 (localTime >>> arr (>=0) >>> edge_sscan) + +sscan_t8r = + [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] + + +sscan_t9 :: [Event ()] +sscan_t9 = testSF1 (localTime >>> arr (>=4.26) >>> edge_sscan) + +sscan_t9r = + [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] + + +maybeToEvent :: Maybe a -> Event a +maybeToEvent Nothing = NoEvent +maybeToEvent (Just a) = Event a + + +edgeBy_sscan :: (a -> a -> Maybe b) -> a -> SF a (Event b) +edgeBy_sscan f a = sscanPrim g a NoEvent + where + g a_prev a = Just (a, maybeToEvent (f a_prev a)) + + +-- Raising edge detector. +sscan_isEdge False False = Nothing +sscan_isEdge False True = Just () +sscan_isEdge True True = Nothing +sscan_isEdge True False = Nothing + + +sscan_t10 :: [Event ()] +sscan_t10 = testSF1 (localTime + >>> arr (>=0) + >>> edgeBy_sscan sscan_isEdge False) + +sscan_t10r = + [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] + +sscan_t11 :: [Event ()] +sscan_t11 = testSF1 (localTime + >>> arr (>=4.26) + >>> edgeBy_sscan sscan_isEdge False) + +sscan_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 and falling edge detector. +sscan_isEdge2 False False = Nothing +sscan_isEdge2 False True = Just True +sscan_isEdge2 True True = Nothing +sscan_isEdge2 True False = Just False + +sscan_t12 :: [Event Bool] +sscan_t12 = testSF1 (localTime + >>> arr (\t -> t >=2.01 && t <= 4.51) + >>> edgeBy_sscan sscan_isEdge2 True) + +sscan_t12r = + [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] + + + +smaximum_sscan :: Ord a => SF a a +smaximum_sscan = + switch (identity &&& now () >>> arr (\(a,e) -> (a, e `tag` a))) + (\a0 -> sscanPrim (\c a -> if a > c + then (Just (a,a)) + else Nothing) + a0 a0) + + +sscan_t13, sscan_t13r :: [Double] +sscan_t13 = take 100 (embed sf (deltaEncode 0.1 (repeat ()))) + where + sf = time + >>> arr (\t -> (t + 1) * cos (pi * t + pi)) + >>> smaximum_sscan + +sscan_t13r = + take 100 + (let xs = [ (t + 1) * cos (pi * t + pi) | t <- [0.0, 0.1 ..] ] + in tail (scanl max (-100) xs)) + + +-- Some tests of signal functions that may be implemented using sscan +-- internally and their combinations with other sscan-based signal +-- functions and event processors. + +sscan_t14, sscan_t14r :: [Event Int] +sscan_t14 = take 100 (embed sf (deltaEncode 0.1 (repeat ()))) + where + sf :: SF () (Event Int) + sf = time >>> arr (\t -> sin (2 * t)) + >>> arr (>0) + >>> edge + >>> arr (`tag` (+1)) + >>> accum 0 + +sscan_t14r = + [NoEvent,Event 1,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,Event 2,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,Event 3,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + Event 4,NoEvent,NoEvent,NoEvent,NoEvent] + +sscan_t15, sscan_t15r :: [Int] +sscan_t15 = take 100 (embed sf (deltaEncode 0.1 (repeat ()))) + where + sf :: SF () Int + sf = time >>> arr (\t -> sin (2 * t)) + >>> arr (>0) + >>> edge + >>> arr (`tag` (+1)) + >>> accumHold 0 + +sscan_t15r = + [0,1,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1, + 1,1,2,2,2,2,2,2,2,2, + 2,2,2,2,2,2,2,2,2,2, + 2,2,2,2,2,2,2,2,2,2, + 2,2,2,3,3,3,3,3,3,3, + 3,3,3,3,3,3,3,3,3,3, + 3,3,3,3,3,3,3,3,3,3, + 3,3,3,3,3,4,4,4,4,4] + +sscan_t16, sscan_t16r :: [Int] +sscan_t16 = take 100 (embed sf (deltaEncode 0.1 (repeat ()))) + where + sf :: SF () Int + sf = time >>> arr (\t -> sin (2 * t)) + >>> arr (>0) + >>> edge + >>> arr (`tag` (+1)) + >>> dAccumHold 0 + +sscan_t16r = + [0,0,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1, + 1,1,1,2,2,2,2,2,2,2, + 2,2,2,2,2,2,2,2,2,2, + 2,2,2,2,2,2,2,2,2,2, + 2,2,2,2,3,3,3,3,3,3, + 3,3,3,3,3,3,3,3,3,3, + 3,3,3,3,3,3,3,3,3,3, + 3,3,3,3,3,3,4,4,4,4] + +sscan_t17, sscan_t17r :: [Event Int] +sscan_t17 = take 100 (embed sf (deltaEncode 0.1 (repeat ()))) + where + sf :: SF () (Event Int) + sf = time >>> arr (\t -> sin (2 * t)) + >>> arr (>0) + >>> iPre False + >>> edge + >>> arr (`tag` (+1)) + >>> accum 0 + +sscan_t17r = + [NoEvent,NoEvent,Event 1,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,Event 2,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,Event 3, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,NoEvent,NoEvent,NoEvent,NoEvent, + NoEvent,Event 4,NoEvent,NoEvent,NoEvent] + +sscan_t18, sscan_t18r :: [Int] +sscan_t18 = take 100 (embed sf (deltaEncode 0.1 (repeat ()))) + where + sf :: SF () Int + sf = time >>> arr (\t -> sin (2 * t)) + >>> arr (>0) + >>> iPre False + >>> edge + >>> arr (`tag` (+1)) + >>> accumHold 0 + +sscan_t18r = + [0,0,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1, + 1,1,1,2,2,2,2,2,2,2, + 2,2,2,2,2,2,2,2,2,2, + 2,2,2,2,2,2,2,2,2,2, + 2,2,2,2,3,3,3,3,3,3, + 3,3,3,3,3,3,3,3,3,3, + 3,3,3,3,3,3,3,3,3,3, + 3,3,3,3,3,3,4,4,4,4] + +sscan_trs = + [ sscan_t0 ~= sscan_t0r, + sscan_t1 ~= sscan_t1r, + sscan_t2 ~= sscan_t2r, + sscan_t3 ~= sscan_t3r, + sscan_t4 == sscan_t4r, + sscan_t5 == sscan_t5r, + sscan_t6 == sscan_t6r, + sscan_t7 == sscan_t7r, + sscan_t8 == sscan_t8r, + sscan_t9 == sscan_t9r, + sscan_t10 == sscan_t10r, + sscan_t11 == sscan_t11r, + sscan_t12 == sscan_t12r, + sscan_t13 ~= sscan_t13r, + sscan_t14 ~= sscan_t14r, + sscan_t15 ~= sscan_t15r, + sscan_t16 ~= sscan_t16r, + sscan_t17 ~= sscan_t17r, + sscan_t18 ~= sscan_t18r + ] + +sscan_tr = and sscan_trs diff --git a/tests/AFRPTestsSwitch.hs b/tests/AFRPTestsSwitch.hs new file mode 100644 --- /dev/null +++ b/tests/AFRPTestsSwitch.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE GADTs #-} + +{- $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 FRP.Yampa +import FRP.Yampa.EventS +import FRP.Yampa.Internals (Event(NoEvent, Event)) + +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 ~ Scalar a, Fractional s) => SF (a, Event a) a +impulseIntegral2 = + switch (first integral >>> arr (\(a, ea) -> (a, fmap (^+^ a) ea))) + impulseIntegral2' + where + impulseIntegral2' :: (VectorSpace a, s ~ Scalar a, Fractional 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 + diff --git a/tests/AFRPTestsTask.hs b/tests/AFRPTestsTask.hs new file mode 100644 --- /dev/null +++ b/tests/AFRPTestsTask.hs @@ -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 FRP.Yampa +import FRP.Yampa.Task + +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 diff --git a/tests/AFRPTestsUtils.hs b/tests/AFRPTestsUtils.hs new file mode 100644 --- /dev/null +++ b/tests/AFRPTestsUtils.hs @@ -0,0 +1,374 @@ +{- $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 FRP.Yampa +import FRP.Yampa.Internals (Event(NoEvent, Event)) +import FRP.Yampa.Conditional +import FRP.Yampa.Integration +import FRP.Yampa.EventS +import FRP.Yampa.Hybrid +import FRP.Yampa.Utilities +import FRP.Yampa.Switches + +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_t14 :: [Event Int] +utils_t14 = testSF1 (after 1.0 1 `andThen` now 2 `andThen` after 2.0 3) + +utils_t14r = + [NoEvent, NoEvent, NoEvent, NoEvent, -- 0.0 s + Event 1, NoEvent, NoEvent, NoEvent, -- 1.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 2.0 s + Event 3, NoEvent, NoEvent, NoEvent, -- 3.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 4.0 s + NoEvent, NoEvent, NoEvent, NoEvent, -- 5.0 s + NoEvent] + +utils_t15 = take 50 (embed (time >>> sampleWindow 5 0.5) + (deltaEncode 0.125 (repeat ()))) + +utils_t15r = + [ NoEvent, NoEvent, NoEvent, NoEvent, -- 0.0 s + Event [0.5], NoEvent, NoEvent, NoEvent, -- 0.5 s + Event [0.5,1.0], NoEvent, NoEvent, NoEvent, -- 1.0 s + Event [0.5,1.0,1.5], NoEvent, NoEvent, NoEvent, -- 1.5 s + Event [0.5,1.0,1.5,2.0], NoEvent, NoEvent, NoEvent, -- 2.0 s + Event [0.5,1.0,1.5,2.0,2.5], NoEvent, NoEvent, NoEvent, -- 2.5 s + Event [1.0,1.5,2.0,2.5,3.0], NoEvent, NoEvent, NoEvent, -- 3.0 s + Event [1.5,2.0,2.5,3.0,3.5], NoEvent, NoEvent, NoEvent, -- 3.5 s + Event [2.0,2.5,3.0,3.5,4.0], NoEvent, NoEvent, NoEvent, -- 4.0 s + Event [2.5,3.0,3.5,4.0,4.5], NoEvent, NoEvent, NoEvent, -- 4.5 s + Event [3.0,3.5,4.0,4.5,5.0], NoEvent, NoEvent, NoEvent, -- 5.0 s + Event [3.5,4.0,4.5,5.0,5.5], NoEvent, NoEvent, NoEvent, -- 5.5 s + Event [4.0,4.5,5.0,5.5,6.0], NoEvent -- 6.0 s + ] + + +{- +-- Not robust +utils_t16 = take 50 (embed (time >>> sampleWindow 5 0.5) input) + where + input = ((), [(dt, Just ()) | dt <- dts]) + + dts = replicate 15 0.1 + ++ [1.0, 1.0] + ++ replicate 15 0.1 + ++ [2.0] + ++ replicate 10 0.1 + +utils_t16r = + [ NoEvent, NoEvent, NoEvent, NoEvent, NoEvent, -- 0.0 + NoEvent, Event [0.6], NoEvent, NoEvent, NoEvent, -- 0.5 + NoEvent, Event [0.6, 1.1], NoEvent, NoEvent, NoEvent, -- 1.0 + NoEvent, -- 1.5 + Event [0.6,1.1,2.5,2.5,2.5], -- 2.5 + Event [2.5,2.5,2.5,3.5,3.5], NoEvent, NoEvent, NoEvent, NoEvent, -- 3.5 + NoEvent, Event [2.5,2.5,3.5,3.5,4.1], NoEvent, NoEvent, NoEvent, -- 4.0 + NoEvent, Event [2.5,3.5,3.5,4.1,4.6], NoEvent, NoEvent, NoEvent, -- 4.5 + NoEvent, -- 5.0 + Event [7.0,7.0,7.0,7.0,7.0], NoEvent, NoEvent, NoEvent, NoEvent, -- 7.0 + NoEvent, Event [7.0,7.0,7.0,7.0,7.6], NoEvent, NoEvent, NoEvent, -- 7.5 + NoEvent -- 8.0 + ] +-} + +utils_t16 = take 50 (embed (time >>> sampleWindow 5 0.4999) input) + where + input = ((), [(dt, Just ()) | dt <- dts]) + + dts = replicate 15 0.1 + ++ [1.0, 1.0] + ++ replicate 15 0.1 + ++ [2.0] + ++ replicate 10 0.1 + +utils_t16r = + [ NoEvent, NoEvent, NoEvent, NoEvent, NoEvent, -- 0.0 + Event [0.5], NoEvent, NoEvent, NoEvent, NoEvent, -- 0.5 + Event [0.5, 1.0], NoEvent, NoEvent, NoEvent, NoEvent, -- 1.0 + Event [0.5, 1.0, 1.5], -- 1.5 + Event [0.5, 1.0, 1.5, 2.5, 2.5], -- 2.5 + Event [1.5, 2.5, 2.5, 3.5, 3.5], NoEvent, NoEvent, NoEvent, -- 3.5 + NoEvent, + Event [2.5, 2.5, 3.5, 3.5, 4.0], NoEvent, NoEvent, NoEvent, -- 4.0 + NoEvent, + Event [2.5, 3.5, 3.5, 4.0, 4.5], NoEvent, NoEvent, NoEvent, -- 4.5 + NoEvent, + Event [3.5, 3.5, 4.0, 4.5, 5.0], -- 5.0 + Event [5.0, 7.0, 7.0, 7.0, 7.0], NoEvent, NoEvent, NoEvent, -- 7.0 + NoEvent, + Event [7.0, 7.0, 7.0, 7.0, 7.5], NoEvent, NoEvent, NoEvent, -- 7.5 + NoEvent, + Event [7.0, 7.0, 7.0, 7.5, 8.0] -- 8.0 + ] + +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_t14 ~= utils_t14r, + utils_t15 ~= utils_t15r, + utils_t16 ~= utils_t16r + ] + +utils_tr = and utils_trs diff --git a/tests/AFRPTestsWFG.hs b/tests/AFRPTestsWFG.hs new file mode 100644 --- /dev/null +++ b/tests/AFRPTestsWFG.hs @@ -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 FRP.Yampa +import FRP.Yampa.Internals (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 diff --git a/tests/hlint.hs b/tests/hlint.hs new file mode 100644 --- /dev/null +++ b/tests/hlint.hs @@ -0,0 +1,23 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Main (hlint) +-- Copyright : (C) 2013 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : portable +-- +-- This module runs HLint on the lens source tree. +----------------------------------------------------------------------------- +module Main where + +import Control.Monad +import Language.Haskell.HLint +import System.Environment +import System.Exit + +main :: IO () +main = do + args <- getArgs + hints <- hlint $ ["src", "--cross"] ++ args + unless (null hints) exitFailure diff --git a/tests/testAFRPMain.hs b/tests/testAFRPMain.hs new file mode 100644 --- /dev/null +++ b/tests/testAFRPMain.hs @@ -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 System.IO +import System.Environment (getArgs, getProgName) + +-- 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) + +