Yampa 0.10.7 → 0.15
raw patch · 75 files changed
Files
- CHANGELOG +246/−61
- LICENSE +4/−1
- Yampa.cabal +305/−122
- benchmarks/Bench.hs +155/−0
- examples/Diagrams.hs +81/−0
- examples/Elevator/Elevator.hs +75/−86
- examples/Elevator/TestElevatorMain.hs +41/−56
- examples/TailgatingDetector/TailgatingDetector.hs +111/−149
- examples/TailgatingDetector/TestTGMain.hs +43/−61
- examples/yampa-game/MainBouncingBox.hs +1/−3
- examples/yampa-game/MainCircleMouse.hs +7/−5
- examples/yampa-game/MainWiimote.hs +4/−4
- examples/yampa-game/YampaSDL.hs +4/−0
- src/FRP/Yampa.hs +292/−352
- src/FRP/Yampa/AffineSpace.hs +0/−43
- src/FRP/Yampa/Arrow.hs +55/−0
- src/FRP/Yampa/Basic.hs +43/−50
- src/FRP/Yampa/Conditional.hs +78/−53
- src/FRP/Yampa/Core.hs +0/−26
- src/FRP/Yampa/Delays.hs +77/−100
- src/FRP/Yampa/Diagnostics.hs +18/−12
- src/FRP/Yampa/Event.hs +151/−228
- src/FRP/Yampa/EventS.hs +239/−469
- src/FRP/Yampa/Forceable.hs +0/−77
- src/FRP/Yampa/Geometry.hs +0/−28
- src/FRP/Yampa/Hybrid.hs +110/−194
- src/FRP/Yampa/Integration.hs +90/−61
- src/FRP/Yampa/InternalCore.hs +942/−1536
- src/FRP/Yampa/Internals.hs +0/−25
- src/FRP/Yampa/Loop.hs +28/−31
- src/FRP/Yampa/MergeableRecord.hs +0/−86
- src/FRP/Yampa/Miscellany.hs +0/−195
- src/FRP/Yampa/Point2.hs +0/−66
- src/FRP/Yampa/Point3.hs +0/−73
- src/FRP/Yampa/Random.hs +61/−82
- src/FRP/Yampa/Scan.hs +42/−33
- src/FRP/Yampa/Simulation.hs +215/−238
- src/FRP/Yampa/Switches.hs +744/−858
- src/FRP/Yampa/Task.hs +127/−173
- src/FRP/Yampa/Time.hs +32/−19
- src/FRP/Yampa/Utilities.hs +0/−61
- src/FRP/Yampa/Vector2.hs +0/−105
- src/FRP/Yampa/Vector3.hs +0/−123
- src/FRP/Yampa/VectorSpace.hs +0/−156
- tests/AFRPTests.hs +0/−191
- tests/AFRPTestsAccum.hs +0/−362
- tests/AFRPTestsArr.hs +0/−53
- tests/AFRPTestsBasicSF.hs +0/−70
- tests/AFRPTestsCOC.hs +0/−57
- tests/AFRPTestsCommon.hs +0/−168
- tests/AFRPTestsComp.hs +0/−72
- tests/AFRPTestsDelay.hs +0/−89
- tests/AFRPTestsDer.hs +0/−56
- tests/AFRPTestsEmbed.hs +0/−62
- tests/AFRPTestsEvSrc.hs +0/−585
- tests/AFRPTestsFirstSecond.hs +0/−128
- tests/AFRPTestsKSwitch.hs +0/−129
- tests/AFRPTestsLaws.hs +0/−90
- tests/AFRPTestsLoop.hs +0/−207
- tests/AFRPTestsLoopIntegral.hs +0/−105
- tests/AFRPTestsLoopLaws.hs +0/−110
- tests/AFRPTestsLoopPre.hs +0/−63
- tests/AFRPTestsPSwitch.hs +0/−326
- tests/AFRPTestsPre.hs +0/−209
- tests/AFRPTestsRPSwitch.hs +0/−247
- tests/AFRPTestsRSwitch.hs +0/−145
- tests/AFRPTestsReact.hs +0/−71
- tests/AFRPTestsSscan.hs +0/−474
- tests/AFRPTestsSwitch.hs +0/−215
- tests/AFRPTestsTask.hs +0/−218
- tests/AFRPTestsUtils.hs +0/−375
- tests/AFRPTestsWFG.hs +0/−104
- tests/HaddockCoverage.hs +4/−6
- tests/hlint.hs +0/−2
- tests/testAFRPMain.hs +0/−78
CHANGELOG view
@@ -1,101 +1,286 @@+2025-02-27 Ivan Perez <ivan.perez@keera.co.uk>+ * Version bump (0.15) (#322).+ * Deprecate FRP.Yampa.Arrow.arr3,arr4,arr5 (#313).++2024-12-07 Ivan Perez <ivan.perez@keera.co.uk>+ * Version bump (0.14.12) (#319).+ * Re-export missing definitions (#318).++2024-10-07 Ivan Perez <ivan.perez@keera.co.uk>+ * Version bump (0.14.11) (#310).+ * Add new publications by Schmidli et al. (#306).+ * Add new publication by Klinge et al. (#308).+ * Bump version bounds of dependencies (#309).+ * Thanks to @seliane.++2024-08-07 Ivan Perez <ivan.perez@keera.co.uk>+ * Version bump (0.14.10) (#302).+ * Implement integral using trapezoid rule (#263).++2024-06-08 Ivan Perez <ivan.perez@keera.co.uk>+ * Version bump (0.14.9) (#299).+ * Document FRP.Yampa.Random.streamToSF (#296).+ * Document FRP.Yampa.Switches.safeZip (#297).+ * Simplify FRP.Yampa.Switches.safeZip (#298).+ * Fix date in CHANGELOG (#300).++2024-04-07 Ivan Perez <ivan.perez@keera.co.uk>+ * Version bump (0.14.8) (#294).++2024-02-09 Ivan Perez <ivan.perez@keera.co.uk>+ * Version bump (0.14.7) (#289).+ * Remove postgresql repo before installation in CI script (#284).+ * Simplify definition of FRP.Yampa.Event.joinE (#285).+ * Simplify definition of FRP.Yampa.EventS.isJustEdge (#286).+ * Simplify definition of FRP.Yampa.Task.isEdge (#287).+ * Remove redundant imports from examples (#288).++2023-12-07 Ivan Perez <ivan.perez@keera.co.uk>+ * Version bump (0.14.6) (#282).+ * Document HTML + WebAssembly backend in README (#34).+ * Relax version bounds on deepseq (#280).+ * Update and improve documentation of Diagrams example (#281).+ * Thanks to @AntanasKal.++2023-10-07 Ivan Perez <ivan.perez@keera.co.uk>+ * Version bump (0.14.5) (#278).+ * Define Yampa.FRP.Task.return in terms of pure (#276).+ * Add link to new publication (#277).+ * Make FRP.Yampa.Event.maybeToEvent public (#267).++2023-08-07 Ivan Perez <ivan.perez@keera.co.uk>+ * Version bump (0.14.4) (#274).+ * Introduce benchmark (#167).+ * Add version bounds to dependencies (#273).++2023-06-07 Ivan Perez <ivan.perez@keera.co.uk>+ * Version bump (0.14.3) (#269).+ * Improve readability of CHANGELOGs (#261).+ * Conformance with style guide (#266).+ * Reflect new contribution process in README (#265).++2023-04-07 Ivan Perez <ivan.perez@keera.co.uk>+ * Version bump (0.14.2) (#259).+ * Conformance with style guide (#255).+ * Move example to yampa-test library (#257).+ * Add game to list of games and apps in README (#254).++2023-02-07 Ivan Perez <ivan.perez@keera.co.uk>+ * Version bump (0.14.1) (#251).+ * Replace broken links (#253).+ * Fix typo (#252).++2022-12-07 Ivan Perez <ivan.perez@keera.co.uk>+ * Version bump (0.14) (#242).+ * Adjust to work with simple-affine-space-0.2 (#241).++2022-10-07 Ivan Perez <ivan.perez@keera.co.uk>+ * Version bump (0.13.7) (#238).+ * Add version bounds to dependencies (#233).+ * Update years, copyright holders (#235).+ * Update distribution to bionic (#236).++2022-08-07 Ivan Perez <ivan.perez@haskell.sexy>+ * Version bump (0.13.6) (#232).+ * Fix typos in documentation (#224).+ * Replace AFRP with Yampa (#223).+ * Simplify implementation of mapFilterE (#221).+ * Re-structure README, add content, TOC (#227).+ * Fix typo (#230).+ * Replace funding link (#231).+ * Thanks to @architsinghal-mriirs.++2022-06-07 Ivan Perez <ivan.perez@haskell.sexy>+ * Version bump (0.13.5) (#220).+ * Remove vim modeline settings (#209).+ * Remove unnecessary comments from module export lists (#210).+ * Style consistency of separators (#211).+ * Adjust format of export lists (#212).+ * Align lists, tuples, records by leading comma (#213).+ * Compress multiple empty lines (#214).+ * Adjust indentation to two spaces (#215).+ * Make arrows less prominent in descriptions (#183).+ * Remove unnecessary import (#222).+ * Replace tabs with spaces (#205).+ * Format module header to conform to style guide (#207).++2022-04-07 Ivan Perez <ivan.perez@haskell.sexy>+ * Version bump (0.13.4) (#203).+ * Syntax rules (#196).+ * Remove regression tests (#201).+ * Remove unused extensions (#199).+ * Syntax rules (#200).+ * Remove commented code and notes (#202).+ * Rename tests (#195).+ * Add new game (#197).++2021-10-07 Ivan Perez <ivan.perez@haskell.sexy>+ * Version bump (0.13.3) (#193).+ * Add modules missing from other-modules in Cabal file (#181).+ * Limit line length to 80 characters (#190).+ * Standardize pragma style (#191).+ * Correct module/copyright info in haddock documentation (#192).+ * Restructure documentation in README (#184).+ * Fix installation instructions in README (#186).+ * Mention new games in README (#188).+ * Remove note from README (#189).++2021-09-15 Ivan Perez <ivan.perez@haskell.sexy>+ * Version bump (0.13.2), change cabal-version, add default language (#180).+ * Update links in Haddock (#179).+ * Update installation instructions in README (#177).+ * Update links in README (#178).+ * Update pointers to other projects in README (#162)+ * Update pointers to other projects in README (#160)+ * Update pointers to other projects in README (#153)+ * Enable testing haddock documentation in CI (#72).+ * Minor haddock documentation fixes (#175).++2019-10-15 Ivan Perez <ivan.perez@keera.co.uk>+ * Version bump (0.13.1).+ * Introduce examples as executables in Cabal file.+ * Add Peoplemon to README.+ * Fix errors in examples due to module reorg.+ * Change testing extension to use tasty.+ * Compile with GHC8.8 in CI.+ * Support MonadFail proposal and GHC 8.8.+ * Thanks to @sigrlami, @RyanGlScott and @CraigTreptow.++2018-11-02 Ivan Perez <ivan.perez@keera.co.uk>+ * Version bump (0.13).+ * Document related projects.+ * Clean API, remove deprecated constructs, move vector and point into+ separate library, hide Core.+ * Eliminate Forceable and MergeableRecord.+ * Add documentation.+ * Add Diagrams example.+ * Compile with GHC8.6 in CI (allowing failures).++2018-10-21 Ivan Perez <ivan.perez@keera.co.uk>+ * Version bump (0.12).+ * Document testing in README.+ * Introduce FutureSF, needed for testing.+ * Introduce testing library.+ * Thanks to @chriz-keera.++2018-08-11 Ivan Perez <ivan.perez@keera.co.uk>+ * Version bump (0.11.1).+ * Document papers in README.+ * Fix leak.+ * Thanks to @tresormuta, @chriz-keera.++2018-04-05 Ivan Perez <ivan.perez@keera.co.uk>+ * Version bump (0.11).+ * Add documentation; makes type synonym a newtype.+ * Remove deprecated import in tests.+ * Test on travis with GHC 7.6 to 8.4.+ * Thanks to @ptvirgo, @thalerjonathan, @turion.+ 2017-12-17 Ivan Perez <ivan.perez@keera.co.uk>- * Yampa.cabal: Version bump (0.10.7), adds flag descriptions,- fixes missing modules.- * README.md: Adds images to descriptions.- * doc/: New HCAR including iOS release.- * src/: Exposes new function, removes unused extensions,- simplifies code, adds documentation, fixes multiple bugs.- * stack.yaml: Fixes nix setup.- * tests/: Adapts to new API.- * examples/: Adapts to new API.- * Thanks to @chriz-keera, @suzumiyasmith, @meimisaki, - @RyanGlScott, @madjestic, @mgttlinger, @eapcochran, - @jonmouchou.+ * Version bump (0.10.7).+ * Add flag to cabal file to expose core.+ * Add flag to descriptions.+ * Fix missing modules in cabal file.+ * Add images to descriptions in README.+ * New HCAR entry including iOS release.+ * Expose new function.+ * Remove unused extensions.+ * Simplify code.+ * Add documentation.+ * Fix multiple bugs.+ * Fix nix setup.+ * Adapt tests to new API.+ * Adapt examples to new API.+ * Thanks to @chriz-keera, @suzumiyasmith, @meimisaki, @RyanGlScott,+ @madjestic, @mgttlinger, @eapcochran, @jonmouchou. 2017-08-28 Ivan Perez <ivan.perez@keera.co.uk>- * Yampa.cabal: Version bump (0.10.6.2), fixes issue with dependencies.- * stack.yaml: Includes minimal stack configuration.+ * Version bump (0.10.6.2).+ * Fix issue with dependencies in Cabal file.+ * Include minimal stack configuration. 2017-08-17 Ivan Perez <ivan.perez@keera.co.uk>- * Yampa.cabal: Version bump (0.10.6.1).- * examples/: new examples, using wiimote.- * src/: Minor improvements to documentation.+ * Version bump (0.10.6.1).+ * New examples, using wiimote.+ * Minor improvements to documentation. 2017-05-05 Ivan Perez <ivan.perez@keera.co.uk>- * Yampa.cabal: Version bump (0.10.6).- * tests/: do not warn if they contain tabs.- * src/: Includes combinators to deal with collections,- to iterate over time (for custom/discrete integration),- implements ArrowChoice.+ * Version bump (0.10.6).+ * Do not warn if tests contain tabs.+ * Include combinators to deal with collections.+ * Include combinators to iterate over time (for custom/discrete+ integration).+ * Implement ArrowChoice. 2017-04-26 Ivan Perez <ivan.perez@keera.co.uk>- * .travis.yml: Instruct TravisCI upload package to hackage.- * Yampa.cabal: Version bump (0.10.5.1).+ * Version bump (0.10.5.1).+ * Instruct TravisCI upload package to hackage. 2016-05-23 Ivan Perez <ivan.perez@keera.co.uk>- * src/: Adds new -:> combinator.- * Yampa.cabal: Version bump (0.10.5).+ * Version bump (0.10.5).+ * Add new -:> combinator. 2015-11-14 Ivan Perez <ivan.perez@keera.co.uk>- * tests/: Include haddock. Regression tests now exit with proper exit- code.- * src/: Includes more documentation.- * Yampa.cabal: Include haddock and regression test suites.- Version bump (0.10.4).+ * Version bump (0.10.4).+ * Include haddock in tests.+ * Regression tests now exit with proper exit code.+ * Include more documentation.+ * Include haddock and regression test suites. 2015-10-02 Ivan Perez <ivan.perez@keera.co.uk>- * src/: Event instances of Applicative and Alternative.- * Yampa.cabal: Version bump (0.10.3).+ * Version bump (0.10.3).+ * Event instances of Applicative and Alternative. 2015-06-19 Ivan Perez <ivan.perez@keera.co.uk>- * src:/ instances of DeepSeq (see #5).- * Yampa.cabal: Deepseq added to dependencies. Version bump (0.10.2).+ * Version bump (0.10.2).+ * Instances of DeepSeq (#5). 2015-05-06 Ivan Perez <ivan.perez@keera.co.uk>- * Yampa.cabal: disables tests by default. Version bump (0.10.1.1).+ * Version bump (0.10.1.1).+ * Disable tests by default in Cabal file. 2015-05-05 Ivan Perez <ivan.perez@keera.co.uk>- * Yampa.cabal: exposes internal modules for documentation purposes.- Version bump (0.10.1)+ * Version bump (0.10.1).+ * Expose internal modules for documentation purposes. 2015-05-05 Ivan Perez <ivan.perez@keera.co.uk>- * src/: Reorders code. Marks modules as deprecated. Removes useless functions.- * Yampa.cabal: version bump (0.10.0)+ * Version bump (0.10.0).+ * Reorder code.+ * Mark modules as deprecated.+ * Remove useless functions. 2015-05-05 Ivan Perez <ivan.perez@keera.co.uk>- * src/FRP/Yampa.hs: documentation. Removes tabs.- * README.md: links to games, related projects, documentation.- * Yampa.cabal: version bump (0.9.7)+ * Version bump (0.9.7).+ * Documentation added to FRP.Yampa.+ * Remove tabs from FRP.Yampa.+ * Link to games, related projects, documentation in README. 2015-03-30 Ivan Perez <ivan.perez@keera.co.uk>- * 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).+ * Version bump (0.9.6.1).+ * Add Functor and Applicative instances for Tasks for compatibility with+ base >= 4.8 (#7).+ * Thanks to Ryan Scott. 2015-03-04 Ivan Perez <ivan.perez@keera.co.uk>- * src/: Coding style improvements.+ * Coding style improvements. 2014-08-29 Ivan Perez <ivan.perez@keera.co.uk>-- * Yampa.cabal: version bump (0.9.6).- * src/: Adds a substantial amount of documentation.- * src/FRP/Yampa.hs: Adds a new pause combinator.+ * Version bump (0.9.6).+ * Add a substantial amount of documentation.+ * Add a new pause combinator. 2014-06-04 Ivan Perez <ivan.perez@keera.co.uk>-- * Adds project to hudson-backed continuous integration server.+ * Add project to hudson-backed continuous integration server. 2014-04-26 Ivan Perez <ivan.perez@keera.es>-- * Yampa.cabal: version bump (0.9.5).- * Adds CHANGELOG to cabal file.+ * Version bump (0.9.5).+ * Add CHANGELOG to cabal file. 2014-04-07 Ivan Perez <ivan.perez@keera.es>-- * Yampa.cabal: new maintainer, version bump (0.9.4).- * src/: documentation is exposed so that Haddock can process it.- * No interface changes.+ * Version bump (0.9.4).+ * New maintainer.+ * 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.
LICENSE view
@@ -1,4 +1,7 @@-Copyright (c) 2003, Henrik Nilsson, Antony Courtney and Yale University.+Copyright (c) 2014-2022, Ivan Perez+Copyright (c) 2007-2012, George Griogidge+Copyright (c) 2005-2006, Henrik Nilsson+Copyright (c) 2003-2004, Henrik Nilsson, Antony Courtney and Yale University. All rights reserved. Redistribution and use in source and binary forms, with or without
Yampa.cabal view
@@ -1,94 +1,104 @@-name: Yampa-version: 0.10.7-cabal-version: >= 1.8-license: BSD3-license-file: LICENSE-author: Henrik Nilsson, Antony Courtney-maintainer: Ivan Perez (ivan.perez@keera.co.uk)-homepage: http://www.haskell.org/haskellwiki/Yampa-category: Reactivity, FRP-synopsis: Library for programming hybrid systems.+-- 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.+cabal-version: >= 1.10+build-type: Simple -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.+name: Yampa+version: 0.15+author: Henrik Nilsson, Antony Courtney+maintainer: Ivan Perez (ivan.perez@keera.co.uk)+homepage: https://github.com/ivanperez-keera/Yampa/+license: BSD3+license-file: LICENSE+category: Reactivity, FRP+synopsis:+ Elegant Functional Reactive Programming Language for 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). -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,+ CHANGELOG, - examples/Elevator/Elevator.hs,- examples/Elevator/TestElevatorMain.hs,- examples/TailgatingDetector/TailgatingDetector.hs,- examples/TailgatingDetector/TestTGMain.hs,+ examples/Diagrams.hs - CHANGELOG+source-repository head+ type: git+ location: git://github.com/ivanperez-keera/Yampa.git+ subdir: yampa + -- You can disable the hlint test suite with -f-test-hlint flag test-hlint- Description: Enable hlint test suite- default: False- manual: True+ description: Enable hlint test suite+ default: False+ manual: True -- You can disable the haddock coverage test suite with -f-test-doc-coverage flag test-doc-coverage- Description: Enable haddock coverage test suite- default: False- manual: True---- You can disable the regression test suite with -f-test-regression-flag test-regression- Description: Enable regression test suite- default: True- manual: True+ description: Enable haddock coverage test suite+ default: False+ manual: True flag examples- Description: Enable examples+ description: Enable examples+ default: False+ manual: True++-- WARNING: The following flag exposes Yampa's core. You should avoid using+-- this at all. The only reason to expose it is that we are using Yampa for+-- research, and many extensions require that we expose the constructors. No+-- released project should depend on this. In general, you should always+-- install Yampa with this flag disabled.+flag expose-core+ description:+ You can enable exposing some of Yampa's core constructs using+ -fexpose-core.+ .+ Enabling this is an unsupported configuration, but it may be useful if you+ are building an extension of Yampa for research and do not wish to fork+ Yampa completely.+ .+ No released project should ever depend on this. default: False- manual: True+ manual: True + library- hs-source-dirs: src- ghc-options : -O3 -Wall -fno-warn-name-shadowing- build-Depends: base < 5, random, deepseq 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 (commonly used) types- FRP.Yampa.AffineSpace- FRP.Yampa.Geometry- FRP.Yampa.Point2- FRP.Yampa.Point3- FRP.Yampa.Vector2- FRP.Yampa.Vector3- FRP.Yampa.VectorSpace-- -- Auxiliary definitions- FRP.Yampa.Forceable- FRP.Yampa.MergeableRecord- FRP.Yampa.Miscellany- FRP.Yampa.Utilities+ FRP.Yampa.Arrow FRP.Yampa.Basic FRP.Yampa.Conditional FRP.Yampa.Delays- FRP.Yampa.Diagnostics+ FRP.Yampa.Event FRP.Yampa.EventS FRP.Yampa.Hybrid FRP.Yampa.Integration@@ -97,83 +107,256 @@ FRP.Yampa.Scan FRP.Yampa.Simulation FRP.Yampa.Switches+ FRP.Yampa.Task FRP.Yampa.Time other-modules:- FRP.Yampa.InternalCore+ -- Auxiliary (commonly used) types+ FRP.Yampa.Diagnostics + build-depends:+ base < 6++ , deepseq >= 1.3.0.1 && < 1.6+ , random >= 1.1 && < 1.3+ , simple-affine-space >= 0.1 && < 0.3++ default-language:+ Haskell2010++ hs-source-dirs:+ src++ ghc-options:+ -O3 -Wall -fno-warn-name-shadowing++ if !impl(ghc >= 8.0)+ build-depends:+ fail == 4.9.*++ if flag(expose-core)+ exposed-modules:+ FRP.Yampa.InternalCore+ else+ other-modules:+ FRP.Yampa.InternalCore++ test-suite hlint- type: exitcode-stdio-1.0- main-is: hlint.hs- hs-source-dirs: tests+ type:+ exitcode-stdio-1.0++ main-is:+ hlint.hs++ default-language:+ Haskell2010++ hs-source-dirs:+ tests+ if !flag(test-hlint)- buildable: False+ buildable:+ False else build-depends:- base,- hlint >= 1.7+ base >= 4 && < 5 + , hlint >= 1.7+ -- Verify that the code is thoroughly documented test-suite haddock-coverage- type: exitcode-stdio-1.0- main-is: HaddockCoverage.hs- ghc-options: -Wall- hs-source-dirs: tests+ type:+ exitcode-stdio-1.0 + main-is:+ HaddockCoverage.hs++ default-language:+ Haskell2010++ hs-source-dirs:+ tests++ ghc-options:+ -Wall+ if !flag(test-doc-coverage)- buildable: False+ buildable:+ False else build-depends:- base >= 4 && < 5,- directory,- filepath,- process,- regex-posix+ base >= 4 && < 5 -test-suite regression- type: exitcode-stdio-1.0- main-is: testAFRPMain.hs- hs-source-dirs: tests- if !flag(test-regression)- buildable: False- else- build-depends:- base,- Yampa+ , directory >= 1.2 && < 1.4+ , filepath >= 1.3.0.1 && < 1.6+ , process >= 1.1.0.2 && < 1.7+ , regex-posix >= 0.95 && < 0.97 + executable yampa-examples-sdl-bouncingbox- main-is: MainBouncingBox.hs- other-modules: YampaSDL- hs-source-dirs: examples/yampa-game/- ghc-options : -O3 -Wall -fno-warn-name-shadowing+ main-is:+ MainBouncingBox.hs++ other-modules:+ YampaSDL++ default-language:+ Haskell2010++ hs-source-dirs:+ examples/yampa-game/++ ghc-options:+ -O3 -Wall -fno-warn-name-shadowing+ if flag(examples)- buildable: True- build-Depends: base < 5, random, deepseq, SDL, Yampa+ buildable:+ True+ build-depends:+ base < 5++ , deepseq >= 1.3.0.1 && < 1.6+ , random >= 1.1 && < 1.3+ , SDL >= 0.6 && < 0.7+ , Yampa else- buildable: False+ buildable:+ False + executable yampa-examples-sdl-circlingmouse- main-is: MainCircleMouse.hs- other-modules: YampaSDL- hs-source-dirs: examples/yampa-game/- ghc-options : -O3 -Wall -fno-warn-name-shadowing+ main-is:+ MainCircleMouse.hs++ other-modules:+ YampaSDL++ default-language:+ Haskell2010++ hs-source-dirs:+ examples/yampa-game/++ ghc-options:+ -O3 -Wall -fno-warn-name-shadowing+ if flag(examples)- buildable: True- build-Depends: base < 5, random, deepseq, SDL, Yampa+ buildable:+ True+ build-depends:+ base < 5++ , deepseq >= 1.3.0.1 && < 1.6+ , random >= 1.1 && < 1.3+ , SDL >= 0.6 && < 0.7+ , Yampa else- buildable: False+ buildable:+ False + executable yampa-examples-sdl-wiimote- main-is: MainWiimote.hs- other-modules: YampaSDL- hs-source-dirs: examples/yampa-game/- ghc-options : -O3 -Wall -fno-warn-name-shadowing -rtsopts+ main-is:+ MainWiimote.hs++ other-modules:+ YampaSDL++ default-language:+ Haskell2010++ hs-source-dirs:+ examples/yampa-game/++ ghc-options:+ -O3 -Wall -fno-warn-name-shadowing -rtsopts+ if flag(examples)- buildable: True- build-depends: base < 5, random, deepseq, SDL, hcwiid, Yampa- else - buildable: False+ buildable:+ True+ build-depends:+ base < 5 -source-repository head- type: git- location: git://github.com/ivanperez-keera/Yampa.git+ , deepseq >= 1.3.0.1 && < 1.6+ , hcwiid >= 0.0.5 && < 0.1+ , random >= 1.1 && < 1.3+ , SDL >= 0.6 && < 0.7+ , Yampa+ else+ buildable:+ False+++executable yampa-examples-elevator+ main-is:+ TestElevatorMain.hs++ other-modules:+ Elevator++ default-language:+ Haskell2010++ hs-source-dirs:+ examples/Elevator++ ghc-options:+ -O3 -Wall -fno-warn-name-shadowing++ if flag(examples)+ buildable:+ True+ build-depends:+ base < 5+ , Yampa+ else+ buildable:+ False+++executable yampa-examples-tailgatingdetector+ main-is:+ TestTGMain.hs++ other-modules:+ TailgatingDetector++ default-language:+ Haskell2010++ hs-source-dirs:+ examples/TailgatingDetector++ ghc-options:+ -O3 -Wall -fno-warn-name-shadowing++ if flag(examples)+ buildable:+ True+ build-depends:+ base < 5+ , Yampa+ else+ buildable:+ False++benchmark yampa-bench+ type:+ exitcode-stdio-1.0++ main-is:+ Bench.hs++ build-depends:+ base < 5+ , criterion >= 0.5.0.0 && < 1.7+ , filepath >= 1.3.0.1 && < 1.6+ , time >= 1.4 && < 1.15+ , Yampa++ default-language:+ Haskell2010++ hs-source-dirs:+ benchmarks
+ benchmarks/Bench.hs view
@@ -0,0 +1,155 @@+-- |+-- Description : A benchmark for Yampa.+-- Copyright : (c) Ivan Perez, 2023+-- Authors : Ivan Perez+--+-- A benchmark for Yampa.+module Main where++import Criterion (bench, bgroup, nf)+import Criterion.Main (defaultConfig, defaultMainWith)+import Criterion.Types (Config(csvFile, resamples, verbosity)+ , Verbosity(Quiet))+import Data.Time.LocalTime (getZonedTime)+import Data.Time.Format (formatTime, defaultTimeLocale)+import System.Environment (getArgs, withArgs)+import System.FilePath ((</>))++import FRP.Yampa++-- | Run all benchmarks.+main :: IO ()+main = do+ config <- customConfig+ withArgs [] $+ defaultMainWith config+ [ bgroup "basic"+ [ bench "identity" $ nf basicIdentity 10000+ , bench "id" $ nf basicId 10000+ ]+ , bgroup "compositions"+ [ bench "identity" $ nf composeIdentity 10000+ , bench "idid" $ nf composeIdId 10000+ , bench "plus" $ nf composePlus 10000+ , bench "plusplus" $ nf composePlusPlus 10000+ , bench "plusmult" $ nf composePlusMult 10000+ , bench "mult" $ nf composeMult 10000+ , bench "multmult" $ nf composeMultMult 10000+ ]+ , bgroup "counter"+ [ bench "counter1" $ nf counter1 10000+ , bench "counter2" $ nf counter2 10000+ ]+ ]++-- * Benchmarks++-- ** Basic++-- | Yampa's specialized identity function.+basicIdentity :: Int -> [Int]+basicIdentity n = embed sf stream+ where+ sf = identity+ stream = deltaEncode 1.0 (replicate n 1)++-- | Standard function identity lifted to SFs.+basicId :: Int -> [Int]+basicId n = embed sf stream+ where+ sf = arr id+ stream = deltaEncode 1.0 (replicate n 1)++-- ** Compositions++-- | Composition of Yampa's specialized identity function.+composeIdentity :: Int -> [Int]+composeIdentity n = embed sf stream+ where+ sf = identity >>> identity+ stream = deltaEncode 1.0 (replicate n 1)++-- | Composition of standard function identity lifted to SFs.+composeIdId :: Int -> [Int]+composeIdId n = embed sf stream+ where+ sf = arr id >>> arr id+ stream = deltaEncode 1.0 (replicate n 1)++-- | Plus operation.+--+-- This is not a composition; it merely exists to serve as a comparison with+-- composePlusPlus.+composePlus :: Int -> [Int]+composePlus n = embed sf stream+ where+ sf = arr (+3)+ stream = deltaEncode 1.0 $ take n [1..]++-- | Composition of addition lifted to SFs.+composePlusPlus :: Int -> [Int]+composePlusPlus n = embed sf stream+ where+ sf = arr (+1) >>> arr (+2)+ stream = deltaEncode 1.0 $ take n [1..]++-- | Composition of addition with multiplication, lifted to SFs.+composePlusMult :: Int -> [Int]+composePlusMult n = embed sf stream+ where+ sf = arr (+100) >>> arr (*2)+ stream = deltaEncode 1.0 $ take n [10..]++-- | Multiplication operation.+--+-- This is not a composition; it merely exists to serve as a comparison with+-- composeMultMult.+composeMult :: Int -> [Int]+composeMult n = embed sf stream+ where+ sf = arr (*20)+ stream = deltaEncode 1.0 $ take n [10..]++-- | Composition of multiplication lifted to SFs.+composeMultMult :: Int -> [Int]+composeMultMult n = embed sf stream+ where+ sf = arr (*10) >>> arr (*2)+ stream = deltaEncode 1.0 $ take n [10..]++-- ** Counter++-- | Counter without explicit seq.+counter1 :: Int -> [Int]+counter1 n = embed sf stream+ where+ sf = loopPre 0 (arr (dup . uncurry (+)))+ stream = deltaEncode 1.0 (replicate n 1)++-- | Counter with explicit seq.+counter2 :: Int -> [Int]+counter2 n = embed sf stream+ where+ sf = loopPre 0 (arr ((\x -> x `seq` (x, x)). uncurry (+)))+ stream = deltaEncode 1.0 (replicate n 1)++-- * Auxiliary functions++-- Construct a config with increased number of sampling+-- and a custom name for the report.+customConfig :: IO Config+customConfig = do+ args <- getArgs++ let dir = case args of+ [] -> "."+ (x:xs) -> x++ -- Custom filename using the current time+ timeString <- (formatTime defaultTimeLocale "%F-%H%M%S") <$> getZonedTime+ let filename = concat [ timeString, "-", "bench.csv" ]++ return $ defaultConfig { csvFile = Just $ dir </> filename+ , resamples = 100000+ , verbosity = Quiet+ }
+ examples/Diagrams.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+-- |+-- Copyright : (c) Ivan Perez, 2018-2022+-- License : BSD-style (see the LICENSE file in the distribution)+-- Maintainer : ivan.perez@keera.co.uk+--+-- Example of connecting the diagrams drawing library with Yampa.+--+-- Based on:+-- https://archives.haskell.org/projects.haskell.org/diagrams/gallery/VectorField.html+--+-- Install diagrams with Cairo support, together with Yampa:+--+-- cabal v1-sandbox init+-- cabal v1-install Yampa diagrams diagrams-cairo+--+-- Compile in a sandbox with:+--+-- cabal v1-exec -- ghc --make examples/Diagrams.hs+--+-- And run with:+--+-- ./examples/Diagrams -w 400 -h 400 -o output.gif++import Diagrams.Backend.Cairo.CmdLine+import Diagrams.Prelude hiding (Time)+import FRP.Yampa hiding (norm, ( # ), (*^))++main :: IO ()+main = mainWith $ take 60 frames++-- | Frames of the animation.+frames :: [(Diagram B, Int)]+frames = zip ((embed sfVF $ deltaEncode 1 $ repeat ())) (repeat 1)++-- | Signal producing the diagram at a point in time.+sfVF :: SF () (Diagram B)+sfVF = proc () -> do+ t <- time -< ()+ let diag = ( field t # translateY 0.05 # lc white+ <> ( square 3.5 # lw none # alignBL))+ returnA -< diag++-- | Field of arrows as it changes over time.+field :: Time -> Diagram B+field t = position $ zip points (arrows t)++-- | Arrow points as they change over time.+points :: [Point V2 Double]+points = map p2 locs++-- | Arrow locations as they change over time.+locs :: [(Double, Double)]+locs = [(x, y) | x <- [0.1, 0.3 .. 3.25], y <- [0.1, 0.3 .. 3.25]]++-- | Arrows as they change over time.+arrows :: Time -> [Diagram B]+arrows t = map (arrowAtPoint t) locs++-- | Diagram of a star at a given point in time and space.+arrowAtPoint :: Time -> (Double, Double) -> Diagram B+arrowAtPoint t (x, y) = arrowAt' opts (p2 (x, y)) (sL *^ vf) # alignTL+ where+ vf = vectorField t (x, y)+ m = norm $ vectorField t (x, y)++ -- Head size is a function of the length of the vector+ -- as are tail size and shaft length.++ hs = 0.02 * m+ sW = 0.004 * m+ sL = 0.05 + 0.1 * m+ opts = (with & arrowHead .~ spike+ & headLength .~ normalized hs+ & shaftStyle %~ lwN sW)++-- | Direction vector depending on the time and the position in space.+vectorField :: Time -> (Double, Double) -> V2 Double+vectorField t (x, y) = r2 (sin (t + y + 1), sin (t + x + 1))
examples/Elevator/Elevator.hs view
@@ -1,37 +1,29 @@ {-# LANGUAGE Arrows #-}--{--******************************************************************************-* A F R P *-* *-* Module: Elevator *-* Purpose: Elevator simulation based on the Fran version *-* from Simon Thompson's paper "A functional reactive *-* animation of a lift using Fran". *-* Authors: Henrik Nilsson *-* *-* Copyright (c) The University of Nottingham, 2004 *-* *-******************************************************************************--}-+-- |+-- Module : Elevator+-- Description : Elevator simulation based on the Fran version by Thompson.+-- Copyright : (c) Ivan Perez, 2014-2022+-- (c) George Giorgidze, 2007-2012+-- (c) Henrik Nilsson, The University of Nottingham, 2004-2006+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : ivan.perez@keera.co.uk+-- Stability : provisional+-- Portability : non-portable (GHC extensions)+--+-- Elevator simulation based on the Fran version from Simon Thompson's paper "A+-- functional reactive animation of a lift using Fran". module Elevator where import FRP.Yampa-import FRP.Yampa.Utilities -- ((^<<), dHold) ---------------------------------------------------------------------------------- Auxiliary definitions---------------------------------------------------------------------------------type Position = Double -- [m]-type Distance = Double -- [m]-type Velocity = Double -- [m/s]+-- * Auxiliary definitions +type Position = Double -- [m]+type Distance = Double -- [m]+type Velocity = Double -- [m/s] ---------------------------------------------------------------------------------- Elevator simulator-------------------------------------------------------------------------------+-- * Elevator simulator lower, upper :: Position lower = 0@@ -41,67 +33,64 @@ upRate = 1 downRate = 1.1 - elevator :: SF (Event (), Event ()) Position elevator = proc (lbp,rbp) -> do- rec- -- This delayed hold can be thought of as modelling acceleration.- -- It is not "physical" to expect a desire to travel at a certain- -- velocity to be immediately reflected in the actual velocity.- -- (The reason we get into trouble here is that the stop/go events- -- depends instantaneously on "stopped" which in turn depends- -- instantaneously on "v".)- v <- dHold 0 -< stop `tag` 0- `lMerge`- goUp `tag` upRate- `lMerge`- goDown `tag` (-downRate)- - 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+ 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) - -- 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+ y <- (lower +) ^<< integral -< v - -- 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+ let atBottom = y <= lower+ atTop = y >= upper+ stopped = v == 0 -- Somewhat dubious ... - -- 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+ 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
examples/Elevator/TestElevatorMain.hs view
@@ -1,24 +1,15 @@-{--******************************************************************************-* A F R P *-* *-* Example: Elevator *-* Purpose: Testing of the Elevator simulator. *-* Authors: Henrik Nilsson *-* *-* Copyright (c) The University of Nottingham, 2004 *-* *-******************************************************************************--}-+-- |+-- Description : Testing of the Elevator simulator.+-- Copyright : The University of Nottingham, 2004+-- Authors : Henrik Nilsson+--+-- Part of Elevator example. module Main where import Data.List (sortBy, intersperse) import Data.Maybe (catMaybes) import FRP.Yampa-import FRP.Yampa.Utilities-import FRP.Yampa.Internals -- Just for testing purposes. import Elevator @@ -30,66 +21,60 @@ rbps :: SF a (Event ()) rbps = afterEach [(20.0, ()), (2.0, ()), (18.0, ()), (15.001, ())] - -- Looks for interesting events by inspecting the input events -- and the elevator position over the interval [0, t_max]. data State = Stopped | GoingUp | GoingDown deriving Eq - testElevator :: Time -> [(Time, ((Event (), Event ()), Position))] testElevator t_max = takeWhile ((<= t_max) . fst) tios- where- -- Time, Input, and Output- tios = embed (localTime &&& ((lbps &&& rbps >>^ dup)- >>> second elevator))- (deltaEncode smplPer (repeat ()))-+ where+ -- Time, Input, and Output+ tios = embed (localTime &&& ((lbps &&& rbps >>^ dup) >>> second elevator))+ (deltaEncode smplPer (repeat ())) findEvents :: [(Time, ((Event (), Event ()), Position))] -> [(Time, Position, String)] findEvents [] = [] findEvents tios@((_, (_, y)) : _) = feAux Stopped y tios- where- feAux _ _ [] = []- feAux sPre yPre ((t, ((lbp, rbp), y)) : tios') =- if not (null message) then - (t, y, message) : feAux s y tios'- else- feAux s y tios'- where- s = if y == yPre then- Stopped- else if yPre < y then- GoingUp- else- GoingDown+ where+ feAux _ _ [] = []+ feAux sPre yPre ((t, ((lbp, rbp), y)) : tios') =+ if not (null message)+ then (t, y, message) : feAux s y tios'+ else feAux s y tios'+ where+ s = if y == yPre+ then Stopped+ else if yPre < y+ then GoingUp+ else+ GoingDown - ms = if s /= sPre then- case s of- Stopped -> Just "elevator stopped"- GoingUp -> Just "elevator started going up"- GoingDown -> Just "elevator started going down"- else- Nothing+ ms = if s /= sPre+ then+ case s of+ Stopped -> Just "elevator stopped"+ GoingUp -> Just "elevator started going up"+ GoingDown -> Just "elevator started going down"+ else+ Nothing - mu = if isEvent lbp then- Just "up button pressed"- else- Nothing+ mu = if isEvent lbp+ then Just "up button pressed"+ else Nothing - md = if isEvent rbp then- Just "down button pressed"- else- Nothing+ md = if isEvent rbp+ then Just "down button pressed"+ else Nothing - message = concat (intersperse ", " (catMaybes [ms, mu, md]))+ message = concat (intersperse ", " (catMaybes [ms, mu, md])) formatEvent :: (Time, Position, String) -> String formatEvent (t, y, m) = "t = " ++ t' ++ ",\ty = " ++ y' ++ ":\t" ++ m- where- t' = show (fromIntegral (round (t * 100)) / 100)- y' = show (fromIntegral (round (y * 100)) / 100)+ where+ t' = show (fromIntegral (round (t * 100)) / 100)+ y' = show (fromIntegral (round (y * 100)) / 100) ppEvents [] = return () ppEvents (e : es) = putStrLn (formatEvent e) >> ppEvents es
examples/TailgatingDetector/TailgatingDetector.hs view
@@ -1,17 +1,9 @@ {-# LANGUAGE Arrows #-}--{--******************************************************************************-* A F R P *-* *-* Module: TailgatingDetector *-* Purpose: AFRP Expressitivity Test *-* Authors: Henrik Nilsson *-* *-* Copyright (c) Yale University, 2003 *-* *-******************************************************************************--}+-- |+-- Module : TailgatingDetector+-- Description : AFRP Expressitivity Test+-- Copyright : Yale University, 2003+-- Authors : Henrik Nilsson -- Context: an autonomous flying vehicle carrying out traffic surveillance -- through an on-board video camera.@@ -37,7 +29,6 @@ -- 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, (\\))@@ -45,68 +36,56 @@ import FRP.Yampa import FRP.Yampa.Conditional import FRP.Yampa.EventS-import FRP.Yampa.Utilities ----------------------------------------------------------------------------------- Testing framework-------------------------------------------------------------------------------+-- * Testing framework -type Position = Double -- [m]-type Distance = Double -- [m]-type Velocity = Double -- [m/s]+type Position = Double -- [m]+type Distance = Double -- [m]+type Velocity = Double -- [m/s] -- We'll call any ground vehicle "car". For our purposes, a car is -- represented by its ground position and ground velocity. type Car = (Position, Velocity) - -- A highway is just a list of cars. In this simple setting, we assume all -- cars are there all the time (no enter or exit ramps etc.) type Highway = [Car] - -- Type of the Video signal. Here just an association list of cars *in view* -- with *relative* positions. type Video = [(Int, Car)] - -- System info, such as height and ground speed. Here, just the position. type UAVStatus = Position - -- Various ways of making cars. switchAfter :: Time -> SF a b -> (b -> SF a b) -> SF a b switchAfter t sf k = switch (sf &&& after t () >>^ \(b,e) -> (b, e `tag` b)) k - mkCar1 :: Position -> Velocity -> SF a Car mkCar1 p0 v = constant v >>> (integral >>^ (+p0)) &&& identity mkCar2 :: Position -> Velocity -> Time -> Velocity -> SF a Car mkCar2 p0 v0 t0 v = switchAfter t0 (mkCar1 p0 v0) (flip mkCar1 v . fst) - mkCar3 :: Position->Velocity->Time->Velocity->Time->Velocity->SF a Car mkCar3 p0 v0 t0 v1 t1 v = switchAfter t0 (mkCar1 p0 v0) $ \(p1, _) ->- switchAfter t1 (mkCar1 p1 v1) $ \(p2, _) ->+ switchAfter t1 (mkCar1 p1 v1) $ \(p2, _) -> mkCar1 p2 v - highway :: SF a Highway-highway = parB [mkCar1 (-600) 30.9,- mkCar1 0 30,- mkCar3 (-1000) 40 95 30 200 30.9,- mkCar1 (-3000) 45,- mkCar1 700 28,- mkCar1 800 29.1]-+highway = parB [ mkCar1 (-600) 30.9+ , mkCar1 0 30+ , mkCar3 (-1000) 40 95 30 200 30.9+ , mkCar1 (-3000) 45+ , mkCar1 700 28+ , mkCar1 800 29.1+ ] -- The status of the UAV. For now, it's just flying at constant speed. uavStatus :: SF a UAVStatus uavStatus = constant 30 >>> integral - -- Tracks a car in the video stream. An event is generated when tracking is -- lost, which we assume only happens if the car leaves the field of vision. -- We don't concern ourselves with realistic creation of trackers.@@ -122,43 +101,39 @@ -- as cars enters the field of view. mkVideoAndTrackers :: SF (Highway, UAVStatus) (Video, Event CarTracker) mkVideoAndTrackers = arr mkVideo >>> identity &&& carEntry- where- mkVideo :: (Highway, Position) -> Video- mkVideo (cars, p_uav) =- [ (i, (p_rel, v))- | (i, (p, v)) <- zip [0..] cars,- let p_rel = p - p_uav, abs p_rel <= range]-- carEntry :: SF Video (Event CarTracker)- carEntry = edgeBy newCar []- where- newCar v_prev v =- case (map fst v) \\ (map fst v_prev) of- [] -> Nothing- (i : _) -> Just (mkCarTracker i)+ where+ mkVideo :: (Highway, Position) -> Video+ mkVideo (cars, p_uav) =+ [ (i, (p_rel, v))+ | (i, (p, v)) <- zip [0..] cars+ , let p_rel = p - p_uav, abs p_rel <= range+ ] - mkCarTracker :: Int -> CarTracker- mkCarTracker i = arr (lookup i . fst)- >>> trackAndHold undefined- &&& edgeBy justToNothing (Just undefined)- where- justToNothing Nothing Nothing = Nothing- justToNothing Nothing (Just _) = Nothing- justToNothing (Just _) (Just _) = Nothing- justToNothing (Just _) Nothing = Just ()+ carEntry :: SF Video (Event CarTracker)+ carEntry = edgeBy newCar []+ where+ newCar v_prev v =+ case (map fst v) \\ (map fst v_prev) of+ [] -> Nothing+ (i : _) -> Just (mkCarTracker i) + mkCarTracker :: Int -> CarTracker+ mkCarTracker i = arr (lookup i . fst)+ >>> trackAndHold undefined+ &&& edgeBy justToNothing (Just undefined)+ where+ justToNothing Nothing Nothing = Nothing+ justToNothing Nothing (Just _) = Nothing+ justToNothing (Just _) (Just _) = Nothing+ justToNothing (Just _) Nothing = Just () videoAndTrackers :: SF a (Video, Event CarTracker) videoAndTrackers = highway &&& uavStatus >>> mkVideoAndTrackers - smplFreq = 2.0 smplPer = 1/smplFreq ----------------------------------------------------------------------------------- Tailgating detector-------------------------------------------------------------------------------+-- * Tailgating detector -- Looks at the positions of two cars and determines if the first is -- tailgating the second. Tailgating is assumed to have occurred if:@@ -171,30 +146,26 @@ tailgating :: SF (Car, Car) (Event ()) tailgating = provided follow tooClose never- where- follow ((p1, v1), (p2, v2)) = p1 < p2- && v1 > 5.0- && abs ((v2 - v1)/v1) < 0.2- && (p2 - p1) / v1 < 5.0-- -- Under the assumption that car c1 is following car c2, generate an- -- event if car1 has been too close to car2 on average during the- -- last 30 s.- tooClose :: SF (Car, Car) (Event ())- tooClose = proc (c1, c2) -> do- ead <- recur (snapAfter 30 <<< avgDist) -< (c1, c2)- returnA -< (filterE (<1.0) ead) `tag` ()+ where+ follow ((p1, v1), (p2, v2)) = p1 < p2+ && v1 > 5.0+ && abs ((v2 - v1)/v1) < 0.2+ && (p2 - p1) / v1 < 5.0 - avgDist = proc ((p1, v1), (p2, v2)) -> do- let nd = (p2 - p1) / v1- ind <- integral -< nd- t <- localTime -< ()- returnA -< if t > 0 then ind / t else nd+ -- Under the assumption that car c1 is following car c2, generate an event+ -- if car1 has been too close to car2 on average during the last 30 s.+ tooClose :: SF (Car, Car) (Event ())+ tooClose = proc (c1, c2) -> do+ ead <- recur (snapAfter 30 <<< avgDist) -< (c1, c2)+ returnA -< (filterE (<1.0) ead) `tag` () + avgDist = proc ((p1, v1), (p2, v2)) -> do+ let nd = (p2 - p1) / v1+ ind <- integral -< nd+ t <- localTime -< ()+ returnA -< if t > 0 then ind / t else nd ---------------------------------------------------------------------------------- Multi-Car tracker-------------------------------------------------------------------------------+-- * Multi-Car tracker -- Auxiliary definitions @@ -202,10 +173,8 @@ data MCTCol a = MCTCol Id [(Id, a)] - instance Functor MCTCol where- fmap f (MCTCol n ias) = MCTCol n [ (i, f a) | (i, a) <- ias ]-+ fmap f (MCTCol n ias) = MCTCol n [ (i, f a) | (i, a) <- ias ] -- Tracking of individual cars in a group. The arrival of a new car is -- signalled by an external event, which causes a new tracker to be added@@ -226,49 +195,44 @@ mct :: SF (Video, UAVStatus, Event CarTracker) [(Id, Car)] mct = pSwitch route cts_init addOrDelCTs (\cts' f -> mctAux (f cts')) >>^ getCars- where- mctAux cts = pSwitch route- cts- (noEvent --> addOrDelCTs)- (\cts' f -> mctAux (f cts'))-- route (v, s, _) = fmap (\ct -> ((v, s), ct))+ where+ mctAux cts = pSwitch route+ cts+ (noEvent --> addOrDelCTs)+ (\cts' f -> mctAux (f cts')) - -- addOrDelCTs :: SF _ (Event (MCTCol CarTracker -> MCTCol carTracker))- addOrDelCTs = proc ((_, _, ect), ces) -> do- let eAdd = fmap addCT ect- let eDel = fmap delCTs (catEvents (getEvents ces))- returnA -< mergeBy (.) eAdd eDel+ route (v, s, _) = fmap (\ct -> ((v, s), ct)) - cts_init :: MCTCol CarTracker- cts_init = MCTCol 0 []+ -- addOrDelCTs :: SF _ (Event (MCTCol CarTracker -> MCTCol carTracker))+ addOrDelCTs = proc ((_, _, ect), ces) -> do+ let eAdd = fmap addCT ect+ let eDel = fmap delCTs (catEvents (getEvents ces))+ returnA -< mergeBy (.) eAdd eDel - addCT :: CarTracker -> MCTCol CarTracker -> MCTCol CarTracker- addCT ct (MCTCol n icts) = MCTCol (n+1) ((n, ct) : icts)+ cts_init :: MCTCol CarTracker+ cts_init = MCTCol 0 [] - delCTs :: [Id] -> MCTCol CarTracker -> MCTCol CarTracker- delCTs is (MCTCol n icts) =- MCTCol n (filter (flip notElem is . fst) icts)+ addCT :: CarTracker -> MCTCol CarTracker -> MCTCol CarTracker+ addCT ct (MCTCol n icts) = MCTCol (n+1) ((n, ct) : icts) - getCars :: MCTCol (Car, Event ()) -> [(Id, Car)]- getCars (MCTCol _ ices) = [(i, c) | (i, (c, _)) <- ices ]+ delCTs :: [Id] -> MCTCol CarTracker -> MCTCol CarTracker+ delCTs is (MCTCol n icts) =+ MCTCol n (filter (flip notElem is . fst) icts) - getEvents :: MCTCol (Car, Event ()) -> [Event Id]- getEvents (MCTCol _ ices) = [e `tag` i | (i,(_,e)) <- ices]+ getCars :: MCTCol (Car, Event ()) -> [(Id, Car)]+ getCars (MCTCol _ ices) = [(i, c) | (i, (c, _)) <- ices ] + getEvents :: MCTCol (Car, Event ()) -> [Event Id]+ getEvents (MCTCol _ ices) = [e `tag` i | (i,(_,e)) <- ices] ---------------------------------------------------------------------------------- Multi tailgating detector-------------------------------------------------------------------------------+-- * Multi tailgating detector -- Auxiliary definitions newtype MTGDCol a = MTGDCol [((Id,Id), a)] - instance Functor MTGDCol where- fmap f (MTGDCol iias) = MTGDCol [ (ii, f a) | (ii, a) <- iias ]-+ fmap f (MTGDCol iias) = MTGDCol [ (ii, f a) | (ii, a) <- iias ] -- Run tailgating above for each pair of tracked cars. A structural change -- to the list of tracked cars is signalled by an event, at which point@@ -284,43 +248,41 @@ eno <- newOrder -< ics' etgs <- rpSwitch route (MTGDCol []) -< (ics', fmap updateTGDs eno) returnA -< tailgaters etgs- where- route ics (MTGDCol iitgs) = MTGDCol $- let cs = map snd ics- in- [ (ii, (cc, tg))- | (cc, (ii, tg)) <- zip (zip cs (tail cs)) iitgs ]-- relPos (_, (p1, _)) (_, (p2, _)) = compare p1 p2+ where+ route ics (MTGDCol iitgs) = MTGDCol $+ let cs = map snd ics+ in [ (ii, (cc, tg))+ | (cc, (ii, tg)) <- zip (zip cs (tail cs)) iitgs+ ] - newOrder :: SF [(Id, Car)] (Event [Id])- newOrder = edgeBy (\ics ics' -> if sameOrder ics ics' then- Nothing- else- Just (map fst ics'))- []- where- sameOrder [] [] = True- sameOrder [] _ = False- sameOrder _ [] = False- sameOrder ((i,_):ics) ((i',_):ics')- | i == i' = sameOrder ics ics' - | otherwise = False+ relPos (_, (p1, _)) (_, (p2, _)) = compare p1 p2 - updateTGDs is (MTGDCol iitgs) = MTGDCol $- [ (ii, maybe tailgating id (lookup ii iitgs))- | ii <- zip is (tail is) ]+ newOrder :: SF [(Id, Car)] (Event [Id])+ newOrder = edgeBy (\ics ics' -> if sameOrder ics ics'+ then Nothing+ else Just (map fst ics'))+ []+ where+ sameOrder [] [] = True+ sameOrder [] _ = False+ sameOrder _ [] = False+ sameOrder ((i,_):ics) ((i',_):ics')+ | i == i' = sameOrder ics ics'+ | otherwise = False - tailgaters :: MTGDCol (Event ()) -> Event [(Id, Id)]- tailgaters (MTGDCol iies) = catEvents [ e `tag` ii | (ii, e) <- iies ]+ updateTGDs is (MTGDCol iitgs) = MTGDCol $+ [ (ii, maybe tailgating id (lookup ii iitgs))+ | ii <- zip is (tail is) ] + tailgaters :: MTGDCol (Event ()) -> Event [(Id, Id)]+ tailgaters (MTGDCol iies) = catEvents [ e `tag` ii | (ii, e) <- iies ] -- Finally, we can tie the individaul pieces together into a signal -- function which finds tailgaters: findTailgaters ::- SF (Video, UAVStatus, Event CarTracker) ([(Id, Car)], Event [(Id, Id)])+ SF (Video, UAVStatus, Event CarTracker) ([(Id, Car)], Event [(Id, Id)]) findTailgaters = proc (v, s, ect) -> do- ics <- mct -< (v, s, ect)- etgs <- mtgd -< ics- returnA -< (ics, etgs)+ ics <- mct -< (v, s, ect)+ etgs <- mtgd -< ics+ returnA -< (ics, etgs)
examples/TailgatingDetector/TestTGMain.hs view
@@ -1,61 +1,46 @@ {-# LANGUAGE Arrows #-}--{--******************************************************************************-* A F R P *-* *-* Example: Test TG *-* Purpose: Testing of the tailgating detector. *-* Authors: Henrik Nilsson *-* *-* Copyright (c) Yale University, 2003 *-* *-******************************************************************************--}-+-- |+-- Description : Testing of the tailgating detector.+-- Copyright : Yale University, 2003+-- Authors : Henrik Nilsson+--+-- Part of the TailgatingDetector example. module Main where import Data.List (sortBy) 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+ >>> filterVideo)+ (deltaEncode smplPer (repeat ()))+ where+ filterVideo = second (edgeBy change [])+ where+ change v_prev v =+ if (map fst (sortBy comparePos v_prev))+ /= (map fst (sortBy comparePos v))+ then Just v+ else Nothing + comparePos (_, (p1, _)) (_, (p2, _)) = compare p1 p2 ppTestVideo t = mapM_ (putStrLn . show) (testVideo t) - testTailgating t_max = filter (isEvent . snd) $ takeWhile (\(t, _) -> t <= t_max) $ embed (localTime- &&& (mkCar3 (-1000) 40 95 30 200 30.9- &&& mkCar1 0 30- >>> tailgating))- (deltaEncode smplPer (repeat ()))-+ &&& (mkCar3 (-1000) 40 95 30 200 30.9+ &&& mkCar1 0 30+ >>> tailgating))+ (deltaEncode smplPer (repeat ())) testMCT :: Time -> [(Time, Event [(Id, Car)])] testMCT t_max = filter (isEvent . snd) $@@ -66,38 +51,35 @@ &&& identity >>> arr (\((v, ect), s) -> (v, s, ect)) >>> mct)- >>> filterMCTOutput)- (deltaEncode smplPer (repeat ()))- where- filterMCTOutput = second (edgeBy change [])- where- change v_prev v =- if (map fst (sortBy comparePos v_prev))- /= (map fst (sortBy comparePos v)) then- Just v- else- Nothing -- comparePos (_, (p1, _)) (_, (p2, _)) = compare p1 p2+ >>> filterMCTOutput)+ (deltaEncode smplPer (repeat ()))+ where+ filterMCTOutput = second (edgeBy change [])+ where+ change v_prev v =+ if (map fst (sortBy comparePos v_prev))+ /= (map fst (sortBy comparePos v))+ then Just v+ else Nothing + comparePos (_, (p1, _)) (_, (p2, _)) = compare p1 p2 ppTestMCT t = mapM_ (putStrLn . show) (testMCT t) - testMTGD :: Time -> [(Time, (Event [(Id,Id)], [(Id, Car)]))]-testMTGD t_max = filter (isEvent . fst . snd) $- takeWhile (\(t, _) -> t <= t_max) $- 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 ()))+testMTGD t_max =+ filter (isEvent . fst . snd) $+ takeWhile (\(t, _) -> t <= t_max) $+ embed (localTime+ &&& (proc _ -> do s <- uavStatus -< ()+ h <- highway -< ()+ (v, ect) <- mkVideoAndTrackers -< (h, s)+ (ics, etgs) <- findTailgaters -< (v,s,ect)+ etgs <- mtgd -< ics+ returnA -< (etgs, ics)))+ (deltaEncode smplPer (repeat ())) ppTestMTGD t = mapM_ (putStrLn . show) (testMTGD t)- -- We could read the car specification from standard input. main = ppTestMTGD 2000
examples/yampa-game/MainBouncingBox.hs view
@@ -1,6 +1,4 @@ {-# LANGUAGE Arrows #-}-import Data.IORef-import Debug.Trace import FRP.Yampa as Yampa import Graphics.UI.SDL as SDL @@ -20,7 +18,7 @@ -- The first two arguments to reactimate are the value of the input signal -- at time zero and at subsequent times, together with the times between -- samples.--- +-- -- The third argument to reactimate is the output consumer that renders -- the signal. --
examples/yampa-game/MainCircleMouse.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE Arrows #-} import Data.IORef-import Debug.Trace import FRP.Yampa as Yampa import Graphics.UI.SDL as SDL @@ -20,7 +19,7 @@ -- The first two arguments to reactimate are the value of the input signal -- at time zero and at subsequent times, together with the times between -- samples.--- +-- -- The third argument to reactimate is the output consumer that renders -- the signal. --@@ -60,8 +59,8 @@ -- | Input controller data Controller = Controller- { controllerPos :: (Double, Double)- }+ { controllerPos :: (Double, Double)+ } -- | Give a controller, refresh its state and return the latest value. -- We need a non-blocking controller-polling function.@@ -70,7 +69,10 @@ state <- readIORef controllerState e <- pollEvent case e of- MouseMotion x y _ _ -> writeIORef controllerState (Controller (fromIntegral x, fromIntegral y)) >> sdlGetController controllerState+ MouseMotion x y _ _ -> do writeIORef+ controllerState+ (Controller (fromIntegral x, fromIntegral y))+ sdlGetController controllerState _ -> return state -- * Graphics
examples/yampa-game/MainWiimote.hs view
@@ -2,7 +2,6 @@ import Control.Monad import Data.IORef import Data.Maybe-import Debug.Trace import FRP.Yampa as Yampa import Graphics.UI.SDL as SDL import System.CWiid@@ -23,7 +22,7 @@ -- The first two arguments to reactimate are the value of the input signal -- at time zero and at subsequent times, together with the times between -- samples.--- +-- -- The third argument to reactimate is the output consumer that renders -- the signal. --@@ -110,7 +109,7 @@ let finX = width * propX finY = height * propY - return (finX, finY) + return (finX, finY) -- | Initializes the wiimote, optionally returning the sensing function. It -- returns Nothing if the Wiimote cannot be detected. Users should have a BT@@ -121,5 +120,6 @@ wm <- cwiidOpen case wm of Nothing -> return ()- Just wm' -> void $ cwiidSetRptMode wm' 15 -- Enable button reception, acc and IR+ Just wm' -> void $ cwiidSetRptMode wm' 15 -- Enable button reception, acc+ -- and IR return wm
examples/yampa-game/YampaSDL.hs view
@@ -1,3 +1,7 @@+-- |+-- Copyright : (c) Ivan Perez, 2017-2022+-- License : BSD-style (see the LICENSE file in the distribution)+-- Maintainer : ivan.perez@keera.co.uk module YampaSDL where import Data.IORef
src/FRP/Yampa.hs view
@@ -1,438 +1,381 @@-{-# LANGUAGE GADTs, Rank2Types, CPP #-}------------------------------------------------------------------------------------------- -- | -- Module : FRP.Yampa--- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003+-- Copyright : (c) Ivan Perez, 2014-2022+-- (c) George Giorgidze, 2007-2012+-- (c) Henrik Nilsson, 2005-2006+-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 -- 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 deterministic+-- hybrid (mixed discrete-time and continuous-time) systems. Yampa is based on+-- the concepts of Functional Reactive Programming (FRP). ----- 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 has been used to write professional Haskell cross-platform games for+-- iOS, Android, desktop and web. There is a library for testing Yampa+-- applications that allows you to use Temporal Logic and QuickCheck to test+-- your games. You can also use a time-travel debugger to connect to your+-- application running live and debug it step by step. ----- You can find examples, tutorials and documentation on Yampa here:+-- __Documentation__ ----- <https://wiki.haskell.org/Yampa>+-- You can find many examples, tutorials and documentation here: ----- <https://github.com/ivanperez-keera/Yampa/tree/master/examples>+-- <https://github.com/ivanperez-keera/Yampa> --+-- <https://github.com/ivanperez-keera/Yampa/tree/develop/yampa/examples> ----- Structuring a hybrid system in Yampa is done based on two main concepts:+-- <https://wiki.haskell.org/Yampa> ----- * 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.+-- __Yampa at a glance__ ----- * 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 Yampa network is structured as a Signal Function: a pure transformation+-- from a time-varying input to that produces a time-varying output. The Yampa+-- language provides signal function primitives, as well as SF combinators.+-- Primitives and combinators guarantee that SFs are well-formed and efficient. ----- 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).+-- For example, a game could take the changing mouse position (continuous-time+-- signal) and mouse clicks (discrete-time signal), combine them as part of+-- some game logic, and produce an animation with sound (continuously changing+-- picture). ----- 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. Also, please let us know if you see any problems--- with the new project structure.+-- /Signal and SF separation/ ----- Main Yampa modules:+-- To create a Yampa system, you need to think about three things: ----- * "FRP.Yampa" -- This exports all FRP-related functions+-- * How to obtain the input signals coming into your system. This typically+-- requires polling some input device or consuming a queue of input events. ----- * "FRP.Yampa.Task"+-- * How to consume the output signals produced by your system. This typically+-- requires taking output samples or chunks and rendering them or playing them. ----- Minimal Complete FRP Definition:+-- * How to transform the input signal into the output signal. This requires+-- thinking about the transformation applied as time progresses towards the+-- future, possibly switching from one transformation to another as the program+-- evolves. ----- * "FRP.Yampa.Core"+-- The first two aspects lie outside Yampa, and they determine the backends+-- that your system uses. Yampa is backend-agnostic, and you can connect it to+-- SDL, SDL2, OpenGL, Gloss, Diagrams, HTML5 Canvas. In addition, you can use+-- it with any input device you want, and it has been used with Nintendo+-- wiimotes, Microsoft Kinects and LeapMotions. ----- Different FRP aspects:+-- The last aspect is what defines Yampa as a language. You define a pure+-- Signal Function (@SF@) using primitives and combinators. You can find a+-- series of primitive SFs in "FRP.Yampa.Basic". For example, the function+-- 'constant' allows you to ignore the input signal and produce a constant+-- output, the function 'arr' allows you to apply a pure function to every+-- input value at every time, ignoring previous history. Signal Functions can+-- transform signals taking their history into account. For example, the+-- function 'integral' integrates the input signal. ----- * "FRP.Yampa.Basic"+-- /Execution/ ----- * "FRP.Yampa.Conditional"+-- 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). You can also use the function 'embed' to try your signal+-- functions with lists of input samples in GHCi. ----- * "FRP.Yampa.Delays"+-- For a simple example of an SDL application that creates a moving picture+-- around the mouse position, see: ----- * "FRP.Yampa.Event"+-- https://github.com/ivanperez-keera/Yampa/blob/develop/yampa/examples/yampa-game/MainCircleMouse.hs ----- * "FRP.Yampa.EventS" -- Event consuming/producing SFs. To be renamed.+-- /Hybrid systems/ ----- * "FRP.Yampa.Hybrid" -- Hybrid (discrete/continuous) SFs+-- Signals can change in continuous or in discrete time (known as 'Event's).+-- Events represent 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. The module "FRP.Yampa.Event"+-- allows you to manipulate events, the module "FRP.Yampa.EventS" deals with+-- event signal functions, and the "FRP.Yampa.Hybrid" allows you to go from a+-- continuous-time domain to a discrete domain, and vice-versa. ----- * "FRP.Yampa.Integration"+-- /Vector Spaces/ ----- * "FRP.Yampa.Loop"+-- Yampa uses vector spaces in time-aware primitives like 'integral'. However,+-- Yampa does not enforce the use of a particular vector space implementation,+-- meaning you could use 'integral' for example with other vector types like+-- V2, V1, etc. from the library linear. For an example, see+-- <https://gist.github.com/walseb/1e0a0ca98aaa9469ab5da04e24f482c2 this gist>. ----- * "FRP.Yampa.Random" ----- * "FRP.Yampa.Scan"+-- __Library Overview__ ----- * "FRP.Yampa.Switches"+-- * Main Yampa module ----- * "FRP.Yampa.Time"+-- * "FRP.Yampa" -- Exports all FRP-related functions. ----- * "FRP.Yampa.Simulation" -- Reactimation/evaluation+-- * Different FRP aspects ----- Internals:+-- * "FRP.Yampa.Basic" -- Primitive SFs. ----- * "FRP.Yampa.InternalCore" -- Module not exposed.+-- * "FRP.Yampa.Conditional" -- Apply one SF or another depending on+-- a condition. ----- Geometry:+-- * "FRP.Yampa.Delays" -- Delay a signal. ----- * "FRP.Yampa.Geometry"+-- * "FRP.Yampa.Event" -- Event combinators. ----- * "FRP.Yampa.AffineSpace"+-- * "FRP.Yampa.EventS" -- Event Signal Functions. ----- * "FRP.Yampa.VectorSpace"+-- * "FRP.Yampa.Hybrid" -- Continuous-time to Discrete-time+-- combinators. ----- * "FRP.Yampa.Point2"+-- * "FRP.Yampa.Integration" -- Integration and derivation and sums. ----- * "FRP.Yampa.Point3"+-- * "FRP.Yampa.Loop" -- Feedback loops. ----- * "FRP.Yampa.Vector2"+-- * "FRP.Yampa.Random" -- Random signals. ----- * "FRP.Yampa.Vector3"+-- * "FRP.Yampa.Scan" -- Scanning or folding a signal. ----- Old legacy code:+-- * "FRP.Yampa.Switches" -- Dynamically changing an SF based on the+-- value of a signal. ----- * "FRP.Yampa.Diagnostics"+-- * "FRP.Yampa.Task" -- SFs that terminate and are followed by+-- other SFs. ----- * "FRP.Yampa.Forceable"+-- * "FRP.Yampa.Time" -- Signals that represent time. ----- * "FRP.Yampa.Internals" -- No longer in use+-- * Execution ----- * "FRP.Yampa.MergeableRecord"+-- * "FRP.Yampa.Simulation" -- Reactimation/evaluation. ----- * "FRP.Yampa.Miscellany"+-- * Auxiliary modules ----- * "FRP.Yampa.Utilities"+-- * "FRP.Yampa.Arrow" -- Arrow-generic functions.+module FRP.Yampa+ (+ -- * Basic definitions+ Time+ , DTime+ , SF+ , Event(..) --- 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 :: <tfun> -> 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?------------------------------------------------------------------------------------------+ -- ** Lifting+ , arrPrim, arrEPrim -module FRP.Yampa (- -- Re-exported module, classes, and types- module Control.Arrow,- module FRP.Yampa.VectorSpace,- RandomGen(..),- Random(..),+ -- * Signal functions - -- * 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).+ -- ** Basic signal functions+ , identity+ , constant+ , localTime+ , time - -- Temporary!- -- SF(..), sfTF',+ -- ** Initialization+ , (-->)+ , (-:>)+ , (>--)+ , (-=>)+ , (>=-)+ , initially - -- 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+ -- ** Simple, stateful signal processing+ , sscan+ , sscanPrim - -- 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+ -- * Events+ -- ** Basic event sources+ , never+ , now+ , after+ , repeatedly+ , afterEach+ , afterEachCat+ , delayEvent+ , delayEventCat+ , edge+ , iEdge+ , edgeTag+ , edgeJust+ , edgeBy+ , maybeToEvent - -- ** Lifting- arrPrim, arrEPrim, -- For optimization+ -- ** Stateful event suppression+ , notYet+ , once+ , takeEvents+ , dropEvents - -- * Signal functions+ -- ** Hybrid SF combinators+ , snap+ , snapAfter+ , sample+ , sampleWindow - -- ** Basic signal functions- identity, -- :: SF a a- constant, -- :: b -> SF a b- localTime, -- :: SF a Time- time, -- :: SF a Time, Other name for localTime.+ -- ** Repetition and switching+ , recur+ , andThen - -- ** Initialization- (-->), -- :: b -> SF a b -> SF a b, infixr 0- (-:>), -- :: b -> SF a b -> SF a b, infixr 0- (>--), -- :: a -> SF a b -> SF a b, infixr 0- (-=>), -- :: (b -> b) -> SF a b -> SF a b infixr 0- (>=-), -- :: (a -> a) -> SF a b -> SF a b infixr 0- initially, -- :: a -> SF a a+ -- ** Pointwise functions on events+ , noEvent+ , noEventFst+ , noEventSnd+ , event+ , fromEvent+ , isEvent+ , isNoEvent+ , tag+ , tagWith+ , attach+ , lMerge+ , rMerge+ , merge+ , mergeBy+ , mapMerge+ , mergeEvents+ , catEvents+ , joinE+ , splitE+ , filterE+ , mapFilterE+ , gate - -- ** Simple, stateful signal processing- sscan, -- :: (b -> a -> b) -> b -> SF a b- sscanPrim, -- :: (c -> a -> Maybe (c, b)) -> c -> b -> SF a b+ -- * Switching+ -- ** Basic switchers+ , switch, dSwitch+ , rSwitch, drSwitch+ , kSwitch, dkSwitch - -- * Events- -- ** Basic event sources- never, -- :: SF a (Event b)- now, -- :: b -> SF a (Event b)- after, -- :: Time -> b -> SF a (Event b)- repeatedly, -- :: Time -> b -> SF a (Event b)- afterEach, -- :: [(Time,b)] -> SF a (Event b)- afterEachCat, -- :: [(Time,b)] -> SF a (Event [b])- delayEvent, -- :: Time -> SF (Event a) (Event a)- delayEventCat, -- :: Time -> SF (Event a) (Event [a])- edge, -- :: SF Bool (Event ())- iEdge, -- :: Bool -> SF Bool (Event ())- edgeTag, -- :: a -> SF Bool (Event a)- edgeJust, -- :: SF (Maybe a) (Event a)- edgeBy, -- :: (a -> a -> Maybe b) -> a -> SF a (Event b)- maybeToEvent, -- :: Maybe a -> Event a- - -- ** 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)+ -- ** Parallel composition and switching+ -- *** Parallel composition and switching with broadcasting+ , parB+ , pSwitchB, dpSwitchB+ , rpSwitchB, drpSwitchB - -- ** 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+ -- *** Parallel composition and switching with general routing+ , par+ , pSwitch, dpSwitch+ , rpSwitch, drpSwitch - -- * 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/switching (lists)+ -- *** Parallel composition/switching with zip routing (lists)+ , parZ+ , pSwitchZ, dpSwitchZ+ , rpSwitchZ, drpSwitchZ - -- ** 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/switching with replication (lists)+ , parC - -- *** 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+ , dHold+ , trackAndHold+ , dTrackAndHold - -- * 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+ , accumHold+ , dAccumHold+ , accumBy+ , accumHoldBy+ , dAccumHoldBy+ , accumFilter - -- ** 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+ , iPre+ , fby - -- * Delays- -- ** Basic delays- pre, -- :: SF a a- iPre, -- :: a -> SF a a+ -- ** Timed delays+ , delay - -- ** Timed delays- delay, -- :: Time -> a -> SF a a+ -- * Conditional+ -- ** Guards and automata-oriented combinators+ , provided - -- ** Variable delay- pause, -- :: b -> SF a b -> SF a Bool -> SF a b+ -- ** Variable delay+ , pause - -- * State keeping combinators+ -- * State keeping combinators - -- ** Loops with guaranteed well-defined feedback- loopPre, -- :: c -> SF (a,c) (b,c) -> SF a b- loopIntegral, -- :: VectorSpace c s => SF (a,c) (b,c) -> SF a b+ -- ** Loops with guaranteed well-defined feedback+ , loopPre+ , loopIntegral - -- ** Integration and differentiation- integral, -- :: VectorSpace a s => SF a a- imIntegral, -- :: VectorSpace a s => a -> SF a a- impulseIntegral, -- :: VectorSpace a k => SF (a, Event a) a- count, -- :: Integral b => SF (Event a) (Event b)- derivative, -- :: VectorSpace a s => SF a a -- Crude!+ -- ** Integration and differentiation+ , integral+ , imIntegral+ , trapezoidIntegral+ , impulseIntegral+ , count+ , derivative + -- Temporarily hidden, but will eventually be made public.+ , iterFrom - -- 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+ , noiseR+ , occasionally - -- * 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)+ , RandomGen(..)+ , Random(..) - -- * 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+ -- * Execution/simulation+ -- ** Reactimation+ , reactimate+ , ReactHandle+ , reactInit+ , react - -- ** 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)])+ -- ** Embedding+ , embed+ , embedSynch+ , deltaEncode+ , deltaEncodeBy - -- * Auxiliary definitions- -- Reverse function composition and arrow plumbing aids- ( # ), -- :: (a -> b) -> (b -> c) -> (a -> c), infixl 9- dup, -- :: a -> (a,a)+ , FutureSF+ , evalAtZero+ , evalAt+ , evalFuture -) where+ -- * Tasks+ -- ** The Task type+ , Task+ , mkTask+ , runTask+ , runTask_+ , taskToSF + -- ** Basic tasks+ , constT+ , sleepT+ , snapT++ -- ** Basic tasks combinators+ , timeOut+ , abortWhen++ -- * Auxiliary definitions+ -- Reverse function composition and arrow plumbing aids+ , dup+ , arr2+ , arr3+ , arr4+ , arr5++ -- * Re-exported module, classes, and types+ , module Control.Arrow+ , module Data.VectorSpace+ )+ where++-- External modules import Control.Arrow+import Data.VectorSpace -import FRP.Yampa.InternalCore+-- Internal modules+import FRP.Yampa.Arrow import FRP.Yampa.Basic import FRP.Yampa.Conditional import FRP.Yampa.Delays@@ -440,14 +383,11 @@ import FRP.Yampa.EventS import FRP.Yampa.Hybrid import FRP.Yampa.Integration+import FRP.Yampa.InternalCore 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.Task import FRP.Yampa.Time-import FRP.Yampa.VectorSpace---- Vim modeline--- vim:set tabstop=8 expandtab:
− src/FRP/Yampa/AffineSpace.hs
@@ -1,43 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}--------------------------------------------------------------------------------------------- |--- Module : FRP.Yampa.AffineSpace--- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : nilsson@cs.yale.edu--- Stability : provisional--- Portability : non-portable (GHC extensions)------ Affine space type relation.-----------------------------------------------------------------------------------------------module FRP.Yampa.AffineSpace where--import FRP.Yampa.VectorSpace----------------------------------------------------------------------------------- Affine Space type relation---------------------------------------------------------------------------------infix 6 .+^, .-^, .-.---- Maybe origin should not be a class method, even though an origin--- can be assocoated with any affine space.--- Maybe distance should not be a class method, in which case the constraint--- on the coefficient space (a) could be Fractional (i.e., a Field), which--- seems closer to the mathematical definition of affine space, provided--- the constraint on the coefficient space for VectorSpace is also Fractional.---- Minimal instance: origin, .+^, .^.-class (Floating a, VectorSpace v a) => AffineSpace p v a | p -> v, v -> a where- origin :: p- (.+^) :: p -> v -> p- (.-^) :: p -> v -> p- (.-.) :: p -> p -> v- distance :: p -> p -> a-- p .-^ v = p .+^ (negateVector v)-- distance p1 p2 = norm (p1 .-. p2)
+ src/FRP/Yampa/Arrow.hs view
@@ -0,0 +1,55 @@+-- |+-- Module : FRP.Yampa.Arrow+-- Copyright : (c) Ivan Perez, 2014-2022+-- (c) George Giorgidze, 2007-2012+-- (c) Henrik Nilsson, 2005-2006+-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : ivan.perez@keera.co.uk+-- Stability : provisional+-- Portability : portable+--+-- Arrow helper functions.+module FRP.Yampa.Arrow+ (+ -- * Arrow plumbing aids+ dup++ -- * Liftings+ , arr2+ , arr3+ , arr4+ , arr5+ )+ where++-- External imports+import Control.Arrow (Arrow, arr)++-- * Arrow plumbing aids++-- | Duplicate an input.+dup :: a -> (a, a)+dup x = (x, x)++-- * Liftings++-- | Lift a binary function onto an arrow.+arr2 :: Arrow a => (b -> c -> d) -> a (b, c) d+arr2 = arr . uncurry++{-# DEPRECATED arr3 "The function arr3 is deprecated in Yampa 0.15 and will be removed in future versions." #-}+-- | Lift a 3-ary function onto an arrow.+arr3 :: Arrow a => (b -> c -> d -> e) -> a (b, c, d) e+arr3 = arr . \h (b, c, d) -> h b c d++{-# DEPRECATED arr4 "The function arr4 is deprecated in Yampa 0.15 and will be removed in future versions." #-}+-- | Lift a 4-ary function onto an arrow.+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++{-# DEPRECATED arr5 "The function arr5 is deprecated in Yampa 0.15 and will be removed in future versions." #-}+-- | Lift a 5-ary function onto an arrow.+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
src/FRP/Yampa/Basic.hs view
@@ -1,45 +1,45 @@-{-# 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)+-- |+-- Module : FRP.Yampa.Basic+-- Copyright : (c) Ivan Perez, 2014-2022+-- (c) George Giorgidze, 2007-2012+-- (c) Henrik Nilsson, 2005-2006+-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004+-- License : BSD-style (see the LICENSE file in the distribution) ----- Maintainer : ivan.perez@keera.co.uk--- Stability : provisional--- Portability : non-portable (GHC extensions)---- | Defines basic signal functions, and elementary ways of altering them.+-- Maintainer : ivan.perez@keera.co.uk+-- Stability : provisional+-- Portability : non-portable (GHC extensions) --+-- Defines basic signal functions, and elementary ways of altering them.+-- -- This module defines very basic ways of creating and modifying signal -- functions. In particular, it defines ways of creating constant output -- producing SFs, and SFs that just pass the signal through unmodified. ----- It also defines ways of altering the input and the output signal only--- by inserting one value in the signal, or by transforming it.-module FRP.Yampa.Basic (-- -- * Basic signal functions- identity, -- :: SF a a- constant, -- :: b -> SF a b-- -- ** Initialization- (-->), -- :: b -> SF a b -> SF a b, infixr 0- (-:>), -- :: b -> SF a b -> SF a b, infixr 0- (>--), -- :: a -> SF a b -> SF a b, infixr 0- (-=>), -- :: (b -> b) -> SF a b -> SF a b infixr 0- (>=-), -- :: (a -> a) -> SF a b -> SF a b infixr 0- initially -- :: a -> SF a a-- ) where+-- It also defines ways of altering the input and the output signal only by+-- inserting one value in the signal, or by transforming it.+module FRP.Yampa.Basic+ (+ -- * Basic signal functions+ identity+ , constant + -- ** Initialization+ , (-->)+ , (-:>)+ , (>--)+ , (-=>)+ , (>=-)+ , initially+ )+ where +-- Internal imports import FRP.Yampa.InternalCore (SF(..), SF'(..), sfConst, sfId) infixr 0 -->, -:>, >--, -=>, >=- ---------------------------------------------------------------------------------- Basic signal functions-------------------------------------------------------------------------------+-- * Basic signal functions -- | Identity: identity = arr id --@@ -58,48 +58,41 @@ constant :: b -> SF a b constant b = SF {sfTF = \_ -> (sfConst b, b)} ---------------------------------------------------------------------------------- Initialization-------------------------------------------------------------------------------+-- * 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.+-- 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)} -- | Output pre-insert operator. ----- Insert a sample in the output, and from that point on, behave--- like the given sf.+-- Insert a sample in the output, and from that point on, behave like the given+-- sf. (-:>) :: b -> SF a b -> SF a b-b0 -:> (SF {sfTF = tf10}) = SF {sfTF = \a0 -> (ct, b0)}- where ct = SF' $ \_dt a0 -> tf10 a0+b0 -:> (SF {sfTF = tf10}) = SF {sfTF = \_a0 -> (ct, b0)}+ where+ ct = SF' $ \_dt a0 -> tf10 a0 -- | 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.+-- 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.+-- Applies a transformation 'f' only to the first output value at time zero. (-=>) :: (b -> b) -> SF a b -> SF a b f -=> (SF {sfTF = tf10}) =- SF {sfTF = \a0 -> let (sf1, b0) = tf10 a0 in (sf1, f b0)}-+ SF {sfTF = \a0 -> let (sf1, b0) = tf10 a0 in (sf1, f b0)} -- | Transform initial input value. ----- Applies a transformation 'f' only to the first input value at--- time zero.+-- 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)}
src/FRP/Yampa/Conditional.hs view
@@ -1,67 +1,92 @@-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+-- |+-- Module : FRP.Yampa+-- Copyright : (c) Ivan Perez, 2014-2022+-- (c) George Giorgidze, 2007-2012+-- (c) Henrik Nilsson, 2005-2006+-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : ivan.perez@keera.co.uk+-- Stability : provisional+-- Portability : non-portable (GHC extensions)+--+-- Apply SFs only under certain conditions.+module FRP.Yampa.Conditional+ (+ -- * Guards and automata-oriented combinators+ provided - ) where+ -- * Variable pause+ , pause+ )+ where -import Control.Arrow-import FRP.Yampa.Basic-import FRP.Yampa.InternalCore (SF(..), SF'(..), sfTF', Transition)-import FRP.Yampa.EventS-import FRP.Yampa.Switches+-- External imports+import Control.Arrow ((&&&), (^>>)) ---------------------------------------------------------------------------------- Guards and automata-oriented combinators-------------------------------------------------------------------------------+-- Internal imports+import FRP.Yampa.Basic (constant)+import FRP.Yampa.EventS (edge, snap)+import FRP.Yampa.InternalCore (SF (..), SF' (..), Transition, sfTF')+import FRP.Yampa.Switches (switch) +-- * Guards and automata-oriented combinators --- Runs sft only when the predicate p is satisfied, otherwise runs sff.+-- | Runs a signal function only when a given predicate is satisfied, otherwise+-- runs the other signal function.+--+-- This is similar to 'ArrowChoice', except that this resets the SFs after each+-- transition.+--+-- For example, the following integrates the incoming input numbers, using one+-- integral if the numbers are even, and another if the input numbers are odd.+-- Note how, every time we "switch", the old value of the integral is discarded.+--+-- >>> embed (provided (even . round) integral integral) (deltaEncode 1 [1, 1, 1, 2, 2, 2, 1, 1, 1, 2, 2, 2 :: Double])+-- [0.0,1.0,2.0,0.0,2.0,4.0,0.0,1.0,2.0,0.0,2.0,4.0] 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)+ where+ stt = switch (sft &&& (not . p ^>> edge)) (const stf)+ stf = switch (sff &&& (p ^>> edge)) (const stt) ---------------------------------------------------------------------------------- Variable pause in signal-------------------------------------------------------------------------------+-- * Variable pause --- | 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.+-- | 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')+pause bInit (SF { sfTF = tfP}) (SF {sfTF = tf10}) = SF {sfTF = tf0}+ where+ -- Initial transformation (no time delta): If the condition is True, return+ -- the accumulator bInit) Otherwise transform the input normally and+ -- recurse.+ tf0 a0 = case tfP a0 of+ (c, True) -> (pauseInit bInit tf10 c, bInit)+ (c, False) -> (pause' b0 k c, b0)+ where+ (k, b0) = tf10 a0 + -- Similar deal, but with a time delta+ pauseInit :: b -> (a -> Transition a b) -> SF' a Bool -> SF' a b+ pauseInit bInit' tf10' c = SF' tf0'+ where+ tf0' dt a = case (sfTF' c) dt a of+ (c', True) -> (pauseInit bInit' tf10' c', bInit')+ (c', False) -> (pause' b0 k c', b0)+ where+ (k, b0) = tf10' a + -- Very same deal (almost alpha-renameable)+ pause' :: b -> SF' a b -> SF' a Bool -> SF' a b+ pause' bInit' tf10' tfP' = SF' tf0'+ where+ tf0' dt a = case (sfTF' tfP') dt a of+ (tfP'', True) -> (pause' bInit' tf10' tfP'', bInit')+ (tfP'', False) -> (pause' b0' tf10'' tfP'', b0')+ where+ (tf10'', b0') = (sfTF' tf10') dt a
− src/FRP/Yampa/Core.hs
@@ -1,26 +0,0 @@-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
src/FRP/Yampa/Delays.hs view
@@ -1,124 +1,101 @@------------------------------------------------------------------------------------------ -- |--- Module : FRP.Yampa.Delays--- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003--- License : BSD-style (see the LICENSE file in the distribution)+-- Module : FRP.Yampa.Delays+-- Copyright : (c) Ivan Perez, 2014-2022+-- (c) George Giorgidze, 2007-2012+-- (c) Henrik Nilsson, 2005-2006+-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004+-- License : BSD-style (see the LICENSE file in the distribution) ----- Maintainer : ivan.perez@keera.co.uk--- Stability : provisional--- Portability : non-portable (GHC extensions)+-- 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+-- SF primitives and combinators to delay signals, introducing new values in+-- them.+module FRP.Yampa.Delays+ (+ -- * Basic delays+ pre+ , iPre+ , fby -import Control.Arrow+ -- * Timed delays+ , delay+ )+ where -import FRP.Yampa.Diagnostics-import FRP.Yampa.InternalCore (SF(..), SF'(..), Time)+-- External imports+import Control.Arrow ((>>>)) -import FRP.Yampa.Basic-import FRP.Yampa.Scan+-- Internal imports+import FRP.Yampa.Basic (identity, (-->))+import FRP.Yampa.Diagnostics (usrErr)+import FRP.Yampa.InternalCore (SF (..), SF' (..), Time)+import FRP.Yampa.Scan (sscanPrim) infixr 0 `fby` ---------------------------------------------------------------------------------- Delays-------------------------------------------------------------------------------+-- * Delays -- | Uninitialized delay operator.---- !!! Redefined using SFSScan--- !!! About 20% slower than old_pre on its own.+--+-- The output has an infinitesimal delay (1 sample), and the value at time zero+-- is undefined. pre :: SF a a pre = sscanPrim f uninit uninit- where- f c a = Just (a, c)- uninit = usrErr "AFRP" "pre" "Uninitialized pre operator."-+ where+ f c a = Just (a, c)+ uninit = usrErr "Yampa" "pre" "Uninitialized pre operator." -- | Initialized delay operator.+--+-- Creates an SF that delays the input signal, introducing an infinitesimal+-- delay (one sample), using the given argument to fill in the initial output at+-- time zero. 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.+-- | Lucid-Synchrone-like initialized delay (read "followed by"). ----- Sum of time deltas in the queue >= q.+-- Initialized delay combinator, introducing an infinitesimal delay (one sample)+-- in given 'SF', using the given argument to fill in the initial output at time+-- zero.+--+-- The difference with 'iPre' is that 'fby' takes an 'SF' as argument.+fby :: b -> SF a b -> SF a b+b0 `fby` sf = b0 --> sf >>> pre --- !!! 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.)+-- * Timed delays +-- | Delay a signal by a fixed time 't', using the second parameter to fill in+-- the initial 't' seconds. 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+delay q aInit | q < 0 = usrErr "Yampa" "delay" "Negative delay."+ | q == 0 = identity+ | otherwise = SF {sfTF = tf0}+ where+ tf0 a0 = (delayAux [] [(q, a0)] 0 aInit, aInit) + -- Invariants:+ -- tDiff 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 <= tDiff < bdt, where bdt is the buffered+ -- time delta for the sample on the front of the buffer queue.+ --+ -- Sum of time deltas in the queue >= q.+ delayAux _ [] _ _ = undefined+ delayAux rbuf buf@((bdt, ba) : buf') tDiff aPrev = SF' tf -- True+ where+ tf dt a | tDiff' < bdt = (delayAux rbuf' buf tDiff' aPrev, aPrev)+ | otherwise = nextSmpl rbuf' buf' (tDiff' - bdt) ba+ where+ tDiff' = tDiff + dt+ rbuf' = (dt, a) : rbuf --- Vim modeline--- vim:set tabstop=8 expandtab:+ nextSmpl rbuf [] tDiff a =+ nextSmpl [] (reverse rbuf) tDiff a+ nextSmpl rbuf buf@((bdt, ba) : buf') tDiff a+ | tDiff < bdt = (delayAux rbuf buf tDiff a, a)+ | otherwise = nextSmpl rbuf buf' (tDiff - bdt) ba
src/FRP/Yampa/Diagnostics.hs view
@@ -1,21 +1,27 @@------------------------------------------------------------------------------------------ -- |--- Module : FRP.Yampa.Diagnostics--- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003--- License : BSD-style (see the LICENSE file in the distribution)+-- Module : FRP.Yampa.Diagnostics+-- Copyright : (c) Ivan Perez, 2014-2022+-- (c) George Giorgidze, 2007-2012+-- (c) Henrik Nilsson, 2005-2006+-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004+-- License : BSD-style (see the LICENSE file in the distribution) ----- Maintainer : nilsson@cs.yale.edu--- Stability : provisional--- Portability : portable+-- Maintainer : ivan.perez@keera.co.uk+-- Stability : provisional+-- Portability : portable ----- Standardized error-reporting for Yampa--------------------------------------------------------------------------------------------module FRP.Yampa.Diagnostics where+-- Standardized error-reporting for Yampa.+module FRP.Yampa.Diagnostics+ ( usrErr+ , intErr+ )+ where +-- | Reports an error due to a violation of Yampa's preconditions/requirements. usrErr :: String -> String -> String -> a usrErr mn fn msg = error (mn ++ "." ++ fn ++ ": " ++ msg) +-- | Reports an error in Yampa's implementation. intErr :: String -> String -> String -> a intErr mn fn msg = error ("[internal error] " ++ mn ++ "." ++ fn ++ ": "- ++ msg)+ ++ msg)
src/FRP/Yampa/Event.hs view
@@ -1,125 +1,92 @@------------------------------------------------------------------------------------------+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- |--- 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+-- Module : FRP.Yampa.Event+-- Copyright : (c) Ivan Perez, 2014-2022+-- (c) George Giorgidze, 2007-2012+-- (c) Henrik Nilsson, 2005-2006+-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004+-- License : BSD-style (see the LICENSE file in the distribution) ----- Definition of Yampa Event type.+-- Maintainer : ivan.perez@keera.co.uk+-- Stability : provisional+-- Portability : portable ----- Yampa Events represent discrete time-signals, meaning those that do not--- change continuously. Examples of event-carrying signals would be mouse--- clicks (in between clicks it is assumed that there is no click), some--- keyboard events, button presses on wiimotes or window-manager events.+-- Events in Yampa represent discrete time-signals, meaning those that do not+-- change continuously. Examples of event-carrying signals would be mouse clicks+-- (in between clicks it is assumed that there is no click), some keyboard+-- events, button presses on wiimotes or window-manager events. ----- The type @Event@ is isomorphic to @Maybe@ (@Event a = NoEvent | Event a@)--- but, semantically, a @Maybe@-carrying signal could change continuously,--- whereas an @Event@-carrying signal should not. No mechanism in Yampa will--- check this or misbehave if this assumption is violated.+-- The type 'Event' is isomorphic to 'Maybe' (@Event a = NoEvent | Event a@)+-- but, semantically, a 'Maybe'-carrying signal could change continuously,+-- whereas an 'Event'-carrying signal should not: for two events in subsequent+-- samples, there should be an small enough sampling frequency such that we+-- sample between those two samples and there are no 'Event's between them.+-- Nevertheless, no mechanism in Yampa will check this or misbehave if this+-- assumption is violated. -- -- Events are essential for many other Yampa constructs, like switches (see--- @FRP.Yampa.Switches.switch@ for details).-------------------------------------------------------------------------------------- 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' could be 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'!------------------------------------------------------------------------------------------+-- 'FRP.Yampa.Switches.switch' for details).+module FRP.Yampa.Event+ (+ -- * The Event type+ Event(..)+ , noEvent+ , noEventFst+ , noEventSnd -module FRP.Yampa.Event where+ -- * Utility functions similar to those available for Maybe+ , event+ , fromEvent+ , isEvent+ , isNoEvent --- 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+ -- * Event tagging+ , tag+ , tagWith+ , attach -import Control.Applicative-import Control.DeepSeq (NFData(..))-import Data.Functor+ -- * Event merging (disjunction) and joining (conjunction)+ , lMerge+ , rMerge+ , merge+ , mergeBy+ , mapMerge+ , mergeEvents+ , catEvents+ , joinE+ , splitE -import FRP.Yampa.Diagnostics-import FRP.Yampa.Forceable+ -- * Event filtering+ , filterE+ , mapFilterE+ , gate + -- * Utilities for easy event construction+ , maybeToEvent + )+ where++-- External imports+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative (Applicative (..), (<$>))+#endif+import Control.Applicative (Alternative (..))+import Control.DeepSeq (NFData (..))+import qualified Control.Monad.Fail as Fail++-- Internal imports+import FRP.Yampa.Diagnostics (usrErr)+ 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.+-- * The Event type --- | A single possible event occurrence, that is, a value that may or may--- not occur. Events are used to represent values that are not produced+-- | 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)@@ -129,101 +96,79 @@ noEvent :: Event a noEvent = NoEvent - -- | Suppress any event in the first component of a pair. noEventFst :: (Event a, b) -> (Event c, b) noEventFst (_, b) = (NoEvent, b) - -- | Suppress any event in the second component of a pair. noEventSnd :: (a, Event b) -> (a, Event c) noEventSnd (a, _) = (a, NoEvent) ---- | Eq instance (equivalent to derived instance)+-- | Eq instance (equivalent to derived instance). instance Eq a => Eq (Event a) where- -- | Equal if both NoEvent or both Event carrying equal values.- NoEvent == NoEvent = True- (Event x) == (Event y) = x == y- _ == _ = False-+ -- | Equal if both NoEvent or both Event carrying equal values.+ NoEvent == NoEvent = True+ (Event x) == (Event y) = x == y+ _ == _ = False --- | Ord instance (equivalent to derived instance)+-- | Ord instance (equivalent to derived instance). instance Ord a => Ord (Event a) where- -- | NoEvent is smaller than Event, Event x < Event y if x < y- compare NoEvent NoEvent = EQ- compare NoEvent (Event _) = LT- compare (Event _) NoEvent = GT- compare (Event x) (Event y) = compare x y+ -- | NoEvent is smaller than Event, Event x < Event y if x < y.+ compare NoEvent NoEvent = EQ+ compare NoEvent (Event _) = LT+ compare (Event _) NoEvent = GT+ compare (Event x) (Event y) = compare x y -- | Functor instance (could be derived). instance Functor Event where- -- | Apply function to value carried by 'Event', if any.- fmap _ NoEvent = NoEvent- fmap f (Event a) = Event (f a)-+ -- | Apply function to value carried by 'Event', if any.+ fmap _ NoEvent = NoEvent+ fmap f (Event a) = Event (f a) -- | Applicative instance (similar to 'Maybe'). instance Applicative Event where- -- | Wrap a pure value in an 'Event'.- pure = Event- -- | If any value (function or arg) is 'NoEvent', everything is.- NoEvent <*> _ = NoEvent- Event f <*> x = f <$> x+ -- | Wrap a pure value in an 'Event'.+ pure = Event+ -- | If any value (function or arg) is 'NoEvent', everything is.+ NoEvent <*> _ = NoEvent+ Event f <*> x = f <$> x --- | Monad instance+-- | Monad instance. instance Monad Event where- -- | Combine events, return 'NoEvent' if any value in the- -- sequence is 'NoEvent'.- (Event x) >>= k = k x- NoEvent >>= _ = NoEvent-- (>>) = (*>)+ -- | Combine events, return 'NoEvent' if any value in the sequence is+ -- 'NoEvent'.+ (Event x) >>= k = k x+ NoEvent >>= _ = NoEvent - -- | See 'pure'.- return = pure- -- | Fail with 'NoEvent'.- fail _ = NoEvent+ (>>) = (*>) + -- | See 'pure'.+ return = pure --- | Alternative instance-instance Alternative Event where- -- | An empty alternative carries no event, so it is ignored.- empty = NoEvent- -- | Merge favouring the left event ('NoEvent' only if both are- -- 'NoEvent').- NoEvent <|> r = r- l <|> _ = l+#if !(MIN_VERSION_base(4,13,0))+ -- | Fail with 'NoEvent'.+ fail = Fail.fail+#endif +instance Fail.MonadFail Event where+ -- | Fail with 'NoEvent'.+ fail _ = NoEvent --- | Forceable instance-instance Forceable a => Forceable (Event a) where- -- | Force an event by evaluating its argument.- force ea@NoEvent = ea- force ea@(Event a) = force a `seq` ea+-- | Alternative instance.+instance Alternative Event where+ -- | An empty alternative carries no event, so it is ignored.+ empty = NoEvent+ -- | Merge favouring the left event ('NoEvent' only if both are 'NoEvent').+ NoEvent <|> r = r+ l <|> _ = l --- | NFData instance+-- | NFData instance. instance NFData a => NFData (Event a) where- -- | Evaluate value carried by event.- 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.---- | Convert a maybe value into a event ('Event' is isomorphic to 'Maybe').-maybeToEvent :: Maybe a -> Event a-maybeToEvent Nothing = NoEvent-maybeToEvent (Just a) = Event a-+ -- | Evaluate value carried by event.+ rnf NoEvent = ()+ rnf (Event a) = rnf a `seq` () ---------------------------------------------------------------------------------- Utility functions similar to those available for Maybe-------------------------------------------------------------------------------+-- * Utility functions similar to those available for Maybe -- | An event-based version of the maybe function. event :: a -> (b -> a) -> Event b -> a@@ -233,7 +178,7 @@ -- | 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."+fromEvent NoEvent = usrErr "Yampa" "fromEvent" "Not an event." -- | Tests whether the input represents an actual event. isEvent :: Event a -> Bool@@ -244,23 +189,18 @@ isNoEvent :: Event a -> Bool isNoEvent = not . isEvent ----------------------------------------------------------------------------------- Event tagging-------------------------------------------------------------------------------+-- * Event tagging -- | Tags an (occurring) event with a value ("replacing" the old value). ----- Applicative-based definition:--- tag = ($>)+-- Applicative-based definition: tag = ($>) 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.+-- | Tags an (occurring) event with a value ("replacing" the old value). Same as+-- 'tag' with the arguments swapped. ----- Applicative-based definition:--- tagWith = (<$)+-- Applicative-based definition: tagWith = (<$) tagWith :: b -> Event a -> Event b tagWith = flip tag @@ -268,33 +208,19 @@ 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.+-- * Event merging (disjunction) and joining (conjunction) -- | Left-biased event merge (always prefer left event, if present). lMerge :: Event a -> Event a -> Event a lMerge = (<|>) - -- | Right-biased event merge (always prefer right event, if present). rMerge :: Event a -> Event a -> Event a rMerge = flip (<|>) - -- | Unbiased event merge: simultaneous occurrence is an error. merge :: Event a -> Event a -> Event a-merge = mergeBy (usrErr "AFRP" "merge" "Simultaneous event occurrence.")-+merge = mergeBy (usrErr "Yampa" "merge" "Simultaneous event occurrence.") -- | Event merge parameterized by a conflict resolution function. --@@ -306,10 +232,10 @@ 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'+-- | 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'. -- -- Applicative-based definition: -- mapMerge lf rf lrf le re = (f <$> le <*> re) <|> (lf <$> le) <|> (rf <$> re)@@ -332,49 +258,46 @@ -- -- Traverable-based definition: -- catEvents :: Foldable t => t (Event a) -> Event (t a)--- carEvents e = if (null e) then NoEvent else (sequenceA e)+-- catEvents e = if (null e) then NoEvent else (sequenceA e) catEvents :: [Event a] -> Event [a] catEvents eas = case [ a | Event a <- eas ] of- [] -> NoEvent- as -> Event as+ [] -> NoEvent+ as -> Event as --- | Join (conjunction) of two events. Only produces an event--- if both events exist.+-- | Join (conjunction) of two events. Only produces an event if both events+-- exist. -- -- Applicative-based definition: -- joinE = liftA2 (,)-joinE :: Event a -> Event b -> Event (a,b)-joinE NoEvent _ = NoEvent-joinE _ NoEvent = NoEvent-joinE (Event l) (Event r) = Event (l,r)-+joinE :: Event a -> Event b -> Event (a, b)+joinE (Event l) (Event r) = Event (l, r)+joinE _ _ = NoEvent -- | 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)-+splitE :: Event (a, b) -> (Event a, Event b)+splitE NoEvent = (NoEvent, NoEvent)+splitE (Event (a, b)) = (Event a, Event b) ---------------------------------------------------------------------------------- Event filtering-------------------------------------------------------------------------------+-- * Event filtering -- | Filter out events that don't satisfy some predicate. filterE :: (a -> Bool) -> Event a -> Event a filterE p e@(Event a) = if p a then e else NoEvent filterE _ NoEvent = NoEvent - -- | Combined event mapping and filtering. Note: since 'Event' is a 'Functor', -- see 'fmap' for a simpler version of this function with no filtering. mapFilterE :: (a -> Maybe b) -> Event a -> Event b-mapFilterE _ NoEvent = NoEvent-mapFilterE f (Event a) = case f a of- Nothing -> NoEvent- Just b -> Event b-+mapFilterE f e = e >>= (maybeToEvent . f) --- | Enable/disable event occurences based on an external condition.+-- | Enable/disable event occurrences based on an external condition. gate :: Event a -> Bool -> Event a _ `gate` False = NoEvent e `gate` True = e++-- * Utilities for easy event construction++-- | Convert a maybe value into a event ('Event' is isomorphic to 'Maybe').+maybeToEvent :: Maybe a -> Event a+maybeToEvent Nothing = NoEvent+maybeToEvent (Just a) = Event a
src/FRP/Yampa/EventS.hs view
@@ -1,149 +1,75 @@-{-# 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)+-- Module : FRP.Yampa.EventS+-- Copyright : (c) Ivan Perez, 2014-2022+-- (c) George Giorgidze, 2007-2012+-- (c) Henrik Nilsson, 2005-2006+-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004+-- License : BSD-style (see the LICENSE file in the distribution) ----- Maintainer : ivan.perez@keera.co.uk--- Stability : provisional--- Portability : non-portable (GHC extensions)+-- Maintainer : ivan.perez@keera.co.uk+-- Stability : provisional+-- Portability : non-portable (GHC extensions) --+-- Event Signal Functions and SF combinators. ----------------------------------------------------------------------------------------------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)--+-- Events represent values that only exist instantaneously, at discrete points+-- in time. Examples include mouse clicks, zero-crosses of monotonic continuous+-- signals, and square waves.+--+-- For signals that carry events, there should be a limit in the number of+-- events we can observe in a time period, no matter how much we increase the+-- sampling frequency.+module FRP.Yampa.EventS+ (+ -- * Basic event sources+ never+ , now+ , after+ , repeatedly+ , afterEach+ , afterEachCat+ , delayEvent+ , delayEventCat+ , edge+ , iEdge+ , edgeTag+ , edgeJust+ , edgeBy -) where+ -- * Stateful event suppression+ , notYet+ , once+ , takeEvents+ , dropEvents -import Control.Arrow+ -- * Hybrid SF combinators+ , snap+ , snapAfter+ , sample+ , sampleWindow -import FRP.Yampa.InternalCore (SF(..), sfConst, Time, SF'(..))+ -- * Repetition and switching+ , recur+ , andThen+ )+ where -import FRP.Yampa.Basic-import FRP.Yampa.Diagnostics-import FRP.Yampa.Event-import FRP.Yampa.Miscellany-import FRP.Yampa.Scan-import FRP.Yampa.Switches+-- External imports+import Control.Arrow (arr, (&&&), (>>>), (>>^)) +-- Internal imports+import FRP.Yampa.Arrow (dup)+import FRP.Yampa.Basic (identity, initially, (-->), (>--))+import FRP.Yampa.Diagnostics (usrErr)+import FRP.Yampa.Event (Event (..), maybeToEvent, tag)+import FRP.Yampa.Hybrid (accumBy)+import FRP.Yampa.InternalCore (SF (..), SF' (..), Time, sfConst)+import FRP.Yampa.Scan (sscanPrim)+import FRP.Yampa.Switches (dSwitch, switch) 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-------------------------------------------------------------------------------+-- * Basic event sources -- | Event source that never occurs. {-# ANN never "HLint: ignore Use const" #-}@@ -153,417 +79,261 @@ 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.+-- | 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)]+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.-+--+-- Note: If the interval is too short w.r.t. the sampling intervals, the result+-- will be that events occur at every sample. However, no more than one event+-- results from any sampling interval, thus avoiding an "event backlog" should+-- sampling become more frequent at some later point in time. repeatedly :: Time -> b -> SF a (Event b)-repeatedly q x | q > 0 = afterEach qxs- | otherwise = usrErr "AFRP" "repeatedly" "Non-positive period."- where- qxs = (q,x):qxs----- Event source with consecutive occurrences at the given intervals.--- Should more than one event be scheduled to occur in any sampling interval,--- only the first will in fact occur to avoid an event backlog.--- Question: Should positive periods except for the first one be required?--- Note that periods of length 0 will always be skipped except for the first.--- Right now, periods of length 0 is allowed on the grounds that no attempt--- is made to forbid simultaneous events elsewhere.-{--afterEach :: [(Time,b)] -> SF a (Event b)-afterEach [] = never-afterEach ((q,x):qxs)- | q < 0 = usrErr "AFRP" "afterEach" "Negative period."- | otherwise = SF {sfTF = tf0}- where- tf0 _ = if q <= 0 then- (scheduleNextEvent 0.0 qxs, Event x)- else- (awaitNextEvent (-q) x qxs, NoEvent)-- scheduleNextEvent t [] = sfNever- scheduleNextEvent t ((q,x):qxs)- | q < 0 = usrErr "AFRP" "afterEach" "Negative period."- | t' >= 0 = scheduleNextEvent t' qxs- | otherwise = awaitNextEvent t' x qxs- where- t' = t - q- awaitNextEvent t x qxs = 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.+repeatedly q x | q > 0 = afterEach qxs+ | otherwise = usrErr "Yampa" "repeatedly" "Non-positive period."+ where+ qxs = (q, x) : qxs --- After all, after, repeatedly etc. are defined in terms of afterEach.-afterEach :: [(Time,b)] -> SF a (Event b)+-- | 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.+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])+-- | 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.+afterEachCat :: [(Time, b)] -> SF a (Event [b]) afterEachCat [] = never-afterEachCat ((q,x):qxs)- | q < 0 = usrErr "AFRP" "afterEachCat" "Negative period."+afterEachCat ((q, x) : qxs)+ | q < 0 = usrErr "Yampa" "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+ where+ tf0 _ = if q <= 0+ then emitEventsScheduleNext 0.0 [x] qxs+ else (awaitNextEvent (-q) x qxs, NoEvent) --- | Delay for events. (Consider it a triggered after, hence /basic/.)+ emitEventsScheduleNext _ xs [] = (sfNever, Event (reverse xs))+ emitEventsScheduleNext t xs ((q, x) : qxs)+ | q < 0 = usrErr "Yampa" "afterEachCat" "Negative period."+ | t' >= 0 = emitEventsScheduleNext t' (x:xs) qxs+ | otherwise = (awaitNextEvent t' x qxs, Event (reverse xs))+ where+ t' = t - q --- 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.+ awaitNextEvent t x qxs = SF' tf -- False+ where+ tf dt _ | t' >= 0 = emitEventsScheduleNext t' [x] qxs+ | otherwise = (awaitNextEvent t' x qxs, NoEvent)+ where+ t' = t + dt +-- | Delay for events. (Consider it a triggered after, hence /basic/.) delayEvent :: Time -> SF (Event a) (Event a)-delayEvent q | q < 0 = usrErr "AFRP" "delayEvent" "Negative delay."+delayEvent q | q < 0 = usrErr "Yampa" "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."+delayEventCat q | q < 0 = usrErr "Yampa" "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)+ where+ tf0 e = ( case e of+ NoEvent -> noPendingEvent+ Event x -> pendingEvents (-q) [] [] (-q) x+ , NoEvent+ ) - -- t_next is the present time w.r.t. the *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)+ noPendingEvent = SF' tf -- True+ where+ tf _ e = ( case e of+ NoEvent -> noPendingEvent+ Event x -> pendingEvents (-q) [] [] (-q) x+ , NoEvent+ ) + -- tNext is the present time w.r.t. the next scheduled event.+ -- tLast 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 tLast rqxs qxs tNext x = SF' tf -- True+ where+ tf dt e+ | tNext' >= 0+ = emitEventsScheduleNext e tLast' rqxs qxs tNext' [x]+ | otherwise+ = (pendingEvents tLast'' rqxs' qxs tNext' x, NoEvent)+ where+ tNext' = tNext + dt+ tLast' = tLast + dt+ (tLast'', rqxs') =+ case e of+ NoEvent -> (tLast', rqxs)+ Event x' -> (-q, (tLast' + q, x') : rqxs) --- | 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.+ -- tNext 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, tNext - 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 tLast rqxs [] tNext rxs =+ emitEventsScheduleNext e tLast [] (reverse rqxs) tNext rxs+ emitEventsScheduleNext e tLast rqxs ((q', x') : qxs') tNext rxs+ | q' > tNext = ( case e of+ NoEvent ->+ pendingEvents tLast+ rqxs+ qxs'+ (tNext - q')+ x'+ Event x'' ->+ pendingEvents (-q)+ ((tLast + q, x'') : rqxs)+ qxs'+ (tNext - q')+ x'+ , Event (reverse rxs)+ )+ | otherwise = emitEventsScheduleNext e+ tLast+ rqxs+ qxs'+ (tNext - q')+ (x' : rxs) --- 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.+-- | A rising edge detector. Useful for things like detecting key presses. It is+-- initialised as /up/, meaning that events occurring at time 0 will not be+-- detected. 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).+-- | 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 occurring 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+ 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?+-- | Edge detector particularized for detecting transitions on a 'Maybe' signal+-- from 'Nothing' to 'Just'. edgeJust :: SF (Maybe a) (Event a) edgeJust = edgeBy isJustEdge (Just undefined)- where- isJustEdge Nothing Nothing = Nothing- isJustEdge Nothing ma@(Just _) = ma- isJustEdge (Just _) (Just _) = Nothing- isJustEdge (Just _) Nothing = Nothing-+ where+ isJustEdge Nothing ma@(Just _) = ma+ isJustEdge _ _ = 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.+-- state, i.e., the previous input sample. The first argument to the edge+-- detection function is the previous sample, the second the current one. edgeBy :: (a -> a -> Maybe b) -> a -> SF a (Event b)-edgeBy isEdge a_init = SF {sfTF = tf0}- where- tf0 a0 = (ebAux a0, maybeToEvent (isEdge a_init a0))-- ebAux a_prev = SF' tf -- True- where- tf _ a = (ebAux a, maybeToEvent (isEdge a_prev a))+edgeBy isEdge aInit = SF {sfTF = tf0}+ where+ tf0 a0 = (ebAux a0, maybeToEvent (isEdge aInit a0)) + ebAux aPrev = SF' tf -- True+ where+ tf _ a = (ebAux a, maybeToEvent (isEdge aPrev a)) ---------------------------------------------------------------------------------- Stateful event suppression-------------------------------------------------------------------------------+-- * Stateful event suppression -- | Suppression of initial (at local time 0) event. notYet :: SF (Event a) (Event a) notYet = initially NoEvent - -- | Suppress all but the first event. once :: SF (Event a) (Event a) once = takeEvents 1 - -- | Suppress all but the first n events. takeEvents :: Int -> SF (Event a) (Event a) takeEvents n | n <= 0 = never takeEvents n = dSwitch (arr dup) (const (NoEvent >-- takeEvents (n - 1))) --{---- 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)))+dropEvents n | n <= 0 = identity+dropEvents n =+ -- Here dSwitch or switch does not really matter.+ 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+-- ** Hybrid continuous-to-discrete SF combinators. +-- | Event source with a single occurrence at time 0. The value of the event is+-- obtained by sampling the input at that time.+snap :: SF a (Event a)+snap =+ -- switch ensures that the entire signal function will become just+ -- "constant" once the sample has been taken.+ switch (never &&& (identity &&& now () >>^ \(a, e) -> e `tag` a)) now --- 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+-- | Event source with a single occurrence at or as soon after (local) time+-- @tEv@ as possible. The value of the event is obtained by sampling the input a -- that time. snapAfter :: Time -> SF a (Event a)-snapAfter t_ev = switch (never- &&& (identity- &&& after t_ev () >>^ \(a, e) -> e `tag` a))- now-+snapAfter tEv =+ switch (never &&& (identity &&& after tEv () >>^ \(a, e) -> e `tag` a)) now --- Sample a signal at regular intervals.+-- | Sample a signal at regular intervals. sample :: Time -> SF a (Event a)-sample p_ev = identity &&& repeatedly p_ev () >>^ \(a, e) -> e `tag` a+sample pEv = identity &&& repeatedly pEv () >>^ \(a, e) -> e `tag` a +-- | 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 --- Makes an event source recurring by restarting it as soon as it has an+-- * Repetition and switching++-- | 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))+recur sfe = switch (never &&& sfe) $ \b -> Event b --> recur (NoEvent --> sfe) +-- | Apply the first SF until it produces an event, and, afterwards, switch to+-- the second SF. This is just a convenience function, used to write what+-- sometimes is more understandable switch-based code. andThen :: SF a (Event b) -> SF a (Event b) -> SF a (Event b) sfe1 `andThen` sfe2 = dSwitch (sfe1 >>^ dup) (const sfe2)--{--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:
− src/FRP/Yampa/Forceable.hs
@@ -1,77 +0,0 @@--------------------------------------------------------------------------------------------- |--- Module : FRP.Yampa.Forceable--- Copyright : (c) Zhanyong Wan, Yale University, 2003--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : nilsson@cs.yale.edu--- Stability : provisional--- Portability : portable------ Hyperstrict evaluation.--------------------------------------------------------------------------------------------module FRP.Yampa.Forceable- {-# DEPRECATED "Use DeepSeq instead" #-}- where--class Forceable a where- force :: a -> a---instance Forceable Int where- force = id---instance Forceable Integer where- force = id---instance Forceable Double where- force = id---instance Forceable Float where- force = id---instance Forceable Bool where- force = id---instance Forceable () where- force = id---instance Forceable Char where- force = id---instance (Forceable a, Forceable b) => Forceable (a, b) where- force p@(a, b) = force a `seq` force b `seq` p---instance (Forceable a, Forceable b, Forceable c) => Forceable (a, b, c) where- force p@(a, b, c) = force a `seq` force b `seq` force c `seq` p---instance (Forceable a, Forceable b, Forceable c, Forceable d) =>- Forceable (a, b, c, d) where- force p@(a, b, c, d) =- force a `seq` force b `seq` force c `seq` force d `seq` p---instance (Forceable a, Forceable b, Forceable c, Forceable d, Forceable e) =>- Forceable (a, b, c, d, e) where- force p@(a, b, c, d, e) =- force a `seq` force b `seq` force c `seq` force d `seq` force e `seq` p---instance (Forceable a) => Forceable [a] where- force nil@[] = nil- force xs@(x:xs') = force x `seq` force xs' `seq` xs---instance (Forceable a) => Forceable (Maybe a) where- force mx@Nothing = mx- force mx@(Just x) = force x `seq` mx
− src/FRP/Yampa/Geometry.hs
@@ -1,28 +0,0 @@--------------------------------------------------------------------------------------------- |--- Module : FRP.Yampa.Geometry--- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : nilsson@cs.yale.edu--- Stability : provisional--- Portability : non-portable (GHC extensions)------ Basic geometrical abstractions.--------------------------------------------------------------------------------------------module FRP.Yampa.Geometry (- module FRP.Yampa.VectorSpace,- module FRP.Yampa.AffineSpace,- module FRP.Yampa.Vector2,- module FRP.Yampa.Vector3,- module FRP.Yampa.Point2,- module FRP.Yampa.Point3-) where--import FRP.Yampa.VectorSpace-import FRP.Yampa.AffineSpace-import FRP.Yampa.Vector2-import FRP.Yampa.Vector3-import FRP.Yampa.Point2-import FRP.Yampa.Point3
src/FRP/Yampa/Hybrid.hs view
@@ -1,235 +1,151 @@------------------------------------------------------------------------------------------ -- |--- Module : FRP.Yampa.Hybrid--- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003--- License : BSD-style (see the LICENSE file in the distribution)+-- Module : FRP.Yampa.Hybrid+-- Copyright : (c) Ivan Perez, 2014-2022+-- (c) George Giorgidze, 2007-2012+-- (c) Henrik Nilsson, 2005-2006+-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004+-- License : BSD-style (see the LICENSE file in the distribution) ----- Maintainer : ivan.perez@keera.co.uk--- Stability : provisional--- Portability : non-portable (GHC extensions)+-- 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)+-- Discrete to continuous-time signal functions.+module FRP.Yampa.Hybrid+ (+ -- * Wave-form generation+ hold+ , dHold+ , trackAndHold+ , dTrackAndHold -) where+ -- * Accumulators+ , accum+ , accumHold+ , dAccumHold+ , accumBy+ , accumHoldBy+ , dAccumHoldBy+ , accumFilter+ )+ where -import Control.Arrow+-- External imports+import Control.Arrow (arr, (>>>)) +-- Internal imports+import FRP.Yampa.Delays (iPre)+import FRP.Yampa.Event (Event (..)) import FRP.Yampa.InternalCore (SF, epPrim) -import FRP.Yampa.Delays-import FRP.Yampa.Event----------------------------------------------------------------------------------- Wave-form generation-------------------------------------------------------------------------------+-- * Wave-form generation -- | Zero-order hold.+--+-- Converts a discrete-time signal into a continuous-time signal, by holding the+-- last value until it changes in the input signal. The given parameter may be+-- used for time zero, and until the first event occurs in the input signal, so+-- hold is always well-initialized.+--+-- >>> embed (hold 1) (deltaEncode 0.1 [NoEvent, NoEvent, Event 2, NoEvent, Event 3, NoEvent])+-- [1,1,2,2,3,3] 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.+hold aInit = epPrim f () aInit+ where+ f _ a = ((), a, a) --- | Zero-order hold with delay.+-- | Zero-order hold with a delay. ----- Identity: dHold a0 = hold a0 >>> iPre a0).+-- Converts a discrete-time signal into a continuous-time signal, by holding the+-- last value until it changes in the input signal. The given parameter is used+-- for time zero (until the first event occurs in the input signal), so 'dHold'+-- shifts the discrete input by an infinitesimal delay.+--+-- >>> embed (dHold 1) (deltaEncode 0.1 [NoEvent, NoEvent, Event 2, NoEvent, Event 3, NoEvent])+-- [1,1,1,2,2,3] 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.+-- | Tracks input signal when available, holding the last value when the input+-- is 'Nothing'. ----- !!! 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.+-- This behaves similarly to 'hold', but there is a conceptual difference, as it+-- takes a signal of input @Maybe a@ (for some @a@) and not @Event@.+--+-- >>> embed (trackAndHold 1) (deltaEncode 0.1 [Nothing, Nothing, Just 2, Nothing, Just 3, Nothing])+-- [1,1,2,2,3,3] trackAndHold :: a -> SF (Maybe a) a-trackAndHold a_init = arr (maybe NoEvent Event) >>> hold a_init+trackAndHold aInit = arr (maybe NoEvent Event) >>> hold aInit +-- | Tracks input signal when available, holding the last value when the input+-- is 'Nothing', with a delay.+--+-- This behaves similarly to 'hold', but there is a conceptual difference, as it+-- takes a signal of input @Maybe a@ (for some @a@) and not @Event@.+--+-- >>> embed (dTrackAndHold 1) (deltaEncode 0.1 [Nothing, Nothing, Just 2, Nothing, Just 3, Nothing])+-- [1,1,1,2,2,3] dTrackAndHold :: a -> SF (Maybe a) a-dTrackAndHold a_init = trackAndHold a_init >>> iPre a_init+dTrackAndHold aInit = trackAndHold aInit >>> iPre aInit ---------------------------------------------------------------------------------- Accumulators-------------------------------------------------------------------------------+-- * 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'.---+-- | 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-+accum aInit = epPrim f aInit 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).+-- | 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+accumHold aInit = epPrim f aInit aInit+ 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--}-+dAccumHold aInit = accumHold aInit >>> iPre aInit -- | 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+accumBy g bInit = epPrim f bInit 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!+accumHoldBy g bInit = epPrim f bInit bInit+ where+ f b a = (b', b', b')+ where+ b' = g b a --- | Zero-order hold accumulator parameterized by the accumulation function--- with delayed initialization (initial output sample is always the--- given accumulator).+-- | 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)--}+dAccumHoldBy f aInit = accumHoldBy f aInit >>> iPre aInit -- | 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.+-- 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:+accumFilter g cInit = epPrim f cInit NoEvent+ where+ f c a = case g c a of+ (c', Nothing) -> (c', NoEvent, NoEvent)+ (c', Just b) -> (c', Event b, NoEvent)
src/FRP/Yampa/Integration.hs view
@@ -1,83 +1,112 @@------------------------------------------------------------------------------------------ -- |--- Module : FRP.Yampa.Integration--- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003--- License : BSD-style (see the LICENSE file in the distribution)+-- Module : FRP.Yampa.Integration+-- Copyright : (c) Ivan Perez, 2014-2022+-- (c) George Giorgidze, 2007-2012+-- (c) Henrik Nilsson, 2005-2006+-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004+-- License : BSD-style (see the LICENSE file in the distribution) ----- Maintainer : ivan.perez@keera.co.uk--- Stability : provisional--- Portability : non-portable (GHC extensions)+-- Maintainer : ivan.perez@keera.co.uk+-- Stability : provisional+-- Portability : non-portable (GHC extensions) ----------------------------------------------------------------------------------------------module FRP.Yampa.Integration (-- -- * Integration- integral, -- :: VectorSpace a s => SF a a- imIntegral, -- :: VectorSpace a s => a -> SF a a- impulseIntegral, -- :: VectorSpace a k => SF (a, Event a) a- count, -- :: Integral b => SF (Event a) (Event b)-- -- * Differentiation- derivative, -- :: VectorSpace a s => SF a a -- Crude!+-- Integration and derivation of input signals.+--+-- In continuous time, these primitives define SFs that integrate/derive the+-- input signal. Since this is subject to the sampling resolution, simple+-- versions are implemented (like the rectangle rule for the integral).+--+-- In discrete time, all we do is count the number of events.+--+-- The combinator 'iterFrom' gives enough flexibility to program your own+-- leak-free integration and derivation SFs.+--+-- Many primitives and combinators in this module require instances of+-- simple-affine-spaces's 'VectorSpace'. Yampa does not enforce the use of a+-- particular vector space implementation, meaning you could use 'integral' for+-- example with other vector types like V2, V1, etc. from the library linear.+-- For an example, see+-- <https://gist.github.com/walseb/1e0a0ca98aaa9469ab5da04e24f482c2 this gist>.+module FRP.Yampa.Integration+ (+ -- * Integration+ integral+ , imIntegral+ , trapezoidIntegral+ , impulseIntegral+ , count - -- Temporarily hidden, but will eventually be made public.- iterFrom -- :: (a -> a -> DTime -> b -> b) -> b -> SF a b+ -- * Differentiation+ , derivative+ , iterFrom+ )+ where -) where+-- External imports+import Control.Arrow ((***), (>>^))+import Data.VectorSpace (VectorSpace, zeroVector, (*^), (^+^), (^-^), (^/)) -import Control.Arrow-import FRP.Yampa.Event-import FRP.Yampa.Hybrid-import FRP.Yampa.InternalCore (SF(..), SF'(..), DTime)-import FRP.Yampa.VectorSpace+-- Internal imports+import FRP.Yampa.Event (Event)+import FRP.Yampa.Hybrid (accumBy, accumHoldBy)+import FRP.Yampa.InternalCore (DTime, SF (..), SF' (..)) ---------------------------------------------------------------------------------- Integration and differentiation-------------------------------------------------------------------------------+-- * Integration -- | Integration using the rectangle rule. {-# INLINE integral #-}-integral :: VectorSpace a s => SF a a+integral :: (Fractional s, VectorSpace a s) => SF a a integral = SF {sfTF = tf0}- where- tf0 a0 = (integralAux igrl0 a0, igrl0)-- igrl0 = zeroVector-- integralAux igrl a_prev = SF' tf -- True- where- tf dt a = (integralAux igrl' a, igrl')- where- igrl' = igrl ^+^ realToFrac dt *^ a_prev-+ where+ tf0 a0 = (integralAux igrl0 a0, igrl0) --- | \"Immediate\" integration (using the function's value at the current time)-imIntegral :: VectorSpace a s => a -> SF a a-imIntegral = ((\ _ a' dt v -> v ^+^ realToFrac dt *^ a') `iterFrom`)+ igrl0 = zeroVector -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)+ integralAux igrl aPrev = SF' tf -- True+ where+ tf dt a = (integralAux igrl' a, igrl')+ where+ igrl' = igrl ^+^ realToFrac dt *^ aPrev --- | A very crude version of a derivative. It simply divides the--- value difference by the time difference. Use at your own risk.-derivative :: VectorSpace a s => SF a a-derivative = SF {sfTF = tf0}- where- tf0 a0 = (derivativeAux a0, zeroVector)+-- | \"Immediate\" integration (using the function's value at the current time).+imIntegral :: (Fractional s, VectorSpace a s) => a -> SF a a+imIntegral = ((\_ a' dt v -> v ^+^ realToFrac dt *^ a') `iterFrom`) - derivativeAux a_prev = SF' tf -- True- where- tf dt a = (derivativeAux a, (a ^-^ a_prev) ^/ realToFrac dt)+-- | Trapezoid integral (using the average between the value at the last time+-- and the value at the current time).+trapezoidIntegral :: (Fractional s, VectorSpace a s) => SF a a+trapezoidIntegral =+ iterFrom (\a a' dt v -> v ^+^ (realToFrac dt / 2) *^ (a ^+^ a')) zeroVector -impulseIntegral :: VectorSpace a k => SF (a, Event a) a+-- | Integrate the first input signal and add the /discrete/ accumulation (sum)+-- of the second, discrete, input signal.+impulseIntegral :: (Fractional k, VectorSpace a k) => SF (a, Event a) a impulseIntegral = (integral *** accumHoldBy (^+^) zeroVector) >>^ uncurry (^+^) +-- | Count the occurrences of input events.+--+-- >>> embed count (deltaEncode 1 [Event 'a', NoEvent, Event 'b'])+-- [Event 1,NoEvent,Event 2] count :: Integral b => SF (Event a) (Event b) count = accumBy (\n _ -> n + 1) 0 +-- * Differentiation --- Vim modeline--- vim:set tabstop=8 expandtab:+-- | A very crude version of a derivative. It simply divides the value+-- difference by the time difference. Use at your own risk.+derivative :: (Fractional s, VectorSpace a s) => SF a a+derivative = SF {sfTF = tf0}+ where+ tf0 a0 = (derivativeAux a0, zeroVector)++ derivativeAux aPrev = SF' tf -- True+ where+ tf dt a = (derivativeAux a, (a ^-^ aPrev) ^/ realToFrac dt)++-- | Integrate using an auxiliary function that takes the current and the last+-- input, the time between those samples, and the last output, and returns a new+-- output.+iterFrom :: (a -> a -> DTime -> b -> b) -> b -> SF a b+f `iterFrom` b = SF (iterAux b)+ where+ iterAux b a = (SF' (\dt a' -> iterAux (f a a' dt b) a'), b)
src/FRP/Yampa/InternalCore.hs view
@@ -1,1536 +1,942 @@-{-# 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:------ <www.haskell.org/haskellwiki/Yampa>------ 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 :: <tfun> -> 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.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 (\a -> (a, a))-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 ArrowChoice SF where- left sf = SF $ \a ->- -- NOTE: there might be a problem with choice here.- -- Do the delta times accumulate for the unused branch?- -- Recommendation by Olivier Charles: take a look- -- at Settable Signals paper, it discusses which- -- option would be best.- case a of- Left x -> let (sf', b') = sfTF sf x- in (futureArrowLeft sf', Left b')- Right x -> let sf' = SF' $ \_ -> sfTF sf- in (futureArrowLeft sf', Right x)- where futureArrowLeft fSF = SF' $ \dt a ->- case a of- Left x -> let (sf', b') = sfTF' fSF dt x- in (futureArrowLeft sf', Left b')- Right x -> (futureArrowLeft fSF, Right x)---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<X><Y> where <X> and <Y> 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 <fixed point comp>-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<X><Y> where <X> and <Y> 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<X><Y> where <X> and <Y> is one of:- -- X - arbitrary signal function- -- A - arbitrary pure arrow- -- I - identity arrow- -- C - constant arrow-- pfoXX :: SF' a b -> SF' a c -> SF' a (b ,c)- pfoXX (SFArr _ fd1) (SFArr _ fd2) = sfArr(fdFanOut fd1 fd2)- pfoXX (SFArr _ FDI) sf2 = pfoIX sf2- pfoXX (SFArr _ (FDC b)) sf2 = pfoCX b sf2- pfoXX (SFArr _ fd1) sf2 = pfoAX (fdFun fd1) sf2- pfoXX sf1 (SFArr _ FDI) = pfoXI sf1- pfoXX sf1 (SFArr _ (FDC c)) = pfoXC sf1 c- pfoXX sf1 (SFArr _ fd2) = pfoXA sf1 (fdFun fd2)--- !!! 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:+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+-- |+-- Module : FRP.Yampa+-- Copyright : (c) Ivan Perez, 2014-2022+-- (c) George Giorgidze, 2007-2012+-- (c) Henrik Nilsson, 2005-2006+-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004+-- 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:+--+-- <www.haskell.org/haskellwiki/Yampa>+--+-- 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).+module FRP.Yampa.InternalCore+ ( module Control.Arrow++ -- * Basic definitions+ -- ** Time+ , Time+ , DTime++ -- ** Signal Functions+ , SF(..)++ -- ** Future Signal Function+ , SF'(..)+ , Transition+ , sfTF'+ , sfId+ , sfConst+ , sfArrG++ -- ** Function descriptions+ , FunDesc(..)+ , fdFun++ -- ** Lifting+ , arrPrim+ , arrEPrim+ , epPrim++ -- *** Scanning+ , sfSScan+ )+ where++-- External imports+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative (Applicative(..))+#endif++import Control.Arrow (Arrow (..), ArrowChoice (..), ArrowLoop (..), (>>>))++#if __GLASGOW_HASKELL__ >= 610+import qualified Control.Category (Category(..))+#endif++-- Internal imports+import FRP.Yampa.Diagnostics (usrErr)+import FRP.Yampa.Event (Event (..))++-- * Basic type definitions with associated utilities++-- | Time is used both for time intervals (duration), and time w.r.t. some+-- agreed reference point in time.++-- 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]++-- | 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}++-- | Signal function in "running" state.+--+-- It can also be seen as a Future Signal Function, meaning, an SF that, given a+-- time delta or a time in the future, it will be an SF.+data SF' a b where+ SFArr :: !(DTime -> a -> Transition a b) -> !(FunDesc a b) -> SF' a b++ -- The b is intentionally unstrict as the initial output sometimes is+ -- undefined (e.g. when defining pre). In any case, it isn't necessarily used+ -- and should thus not be forced.+ SFSScan :: !(DTime -> a -> Transition a b)+ -> !(c -> a -> Maybe (c, b))+ -> !c+ -> b+ -> SF' a b++ SFEP :: !(DTime -> Event a -> Transition (Event a) b)+ -> !(c -> a -> (c, b, b))+ -> !c+ -> b+ -> SF' (Event a) b++ SFCpAXA :: !(DTime -> a -> Transition a d)+ -> !(FunDesc a b)+ -> !(SF' b c)+ -> !(FunDesc c d)+ -> SF' a d++ SF' :: !(DTime -> a -> Transition a b)+ -> SF' a b++-- | A transition is a pair of the next state (in the form of a future signal+-- function) and the output at the present time step.+type Transition a b = (SF' a b, b)++-- | Obtain the function that defines a running SF.+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++-- | Constructor for a lifted structured function.+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++-- | SF constructor for the identity function.+sfId :: SF' a a+sfId = sf+ where+ sf = SFArr (\_ a -> (sf, a)) FDI++-- | SF constructor for the constant function.+sfConst :: b -> SF' a b+sfConst b = sf+ where+ sf = SFArr (\_ _ -> (sf, b)) (FDC b)++-- 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)++-- | SF constructor for a general function.+sfArrG :: (a -> b) -> SF' a b+sfArrG f = sf+ where+ sf = SFArr (\_ a -> (sf, f a)) (FDG f)++-- ** Function descriptions++-- | Structured function definition.+--+-- This type represents functions with a bit more structure, providing specific+-- constructors for the identity, constant and event-based functions, helping+-- optimise arrow combinators for special cases.+data FunDesc a b where+ FDI :: FunDesc a a -- Identity function+ FDC :: b -> FunDesc a b -- Constant function+ FDE :: (Event a -> b) -> b -> FunDesc (Event a) b -- Event-processing fun+ FDG :: (a -> b) -> FunDesc a b -- General function++-- | Turns a function into a structured function.+fdFun :: FunDesc a b -> (a -> b)+fdFun FDI = id+fdFun (FDC b) = const b+fdFun (FDE f _) = f+fdFun (FDG f) = f++-- | Composition for structured functions.+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+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)++-- | Parallel application of structured functions.+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))++-- | Parallel application with broadcasting for structured functions.+fdFanOut :: FunDesc a b -> FunDesc a c -> FunDesc a (b, c)+fdFanOut FDI FDI = FDG (\a -> (a, a))+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+ "Yampa"+ "vfyNoEv"+ "Assertion failed: Functions on events must not map NoEvent to Event."++-- * Arrow instance and implementation++#if __GLASGOW_HASKELL__ >= 610+-- | Composition and identity for SFs.+instance Control.Category.Category SF where+ (.) = flip compPrim+ id = SF $ \x -> (sfId, x)+#endif++-- | Choice of which SF to run based on the value of a signal.+instance ArrowChoice SF where+ -- (+++) :: forall b c b' c'+ -- . SF b c -> SF d e -> SF (Either b d) (Either c e)+ sfL +++ sfR = SF $ \a ->+ case a of+ Left b -> let (sf', c) = sfTF sfL b+ in (chooseL sf' sfR, Left c)+ Right d -> let (sf', e) = sfTF sfR d+ in (chooseR sfL sf', Right e)++ where++ -- (+++) for an initialized SF and an SF+ --+ -- chooseL :: SF' b c -> SF d e -> SF' (Either b d) (Either c e)+ chooseL sfCL sfR = SF' $ \dt a ->+ case a of+ Left b -> let (sf', c) = sfTF' sfCL dt b+ in (chooseL sf' sfR, Left c)+ Right d -> let (sf', e) = sfTF sfR d+ in (choose sfCL sf', Right e)++ -- (+++) for an SF and an initialized SF+ --+ -- chooseR :: SF b c -> SF' d e -> SF' (Either b d) (Either c e)+ chooseR sfL sfCR = SF' $ \dt a ->+ case a of+ Left b -> let (sf', c) = sfTF sfL b+ in (choose sf' sfCR, Left c)+ Right d -> let (sf', e) = sfTF' sfCR dt d+ in (chooseR sfL sf', Right e)++ -- (+++) for initialized SFs+ --+ -- choose :: SF' b c -> SF' d e -> SF' (Either b d) (Either c e)+ choose sfCL sfCR = SF' $ \dt a ->+ case a of+ Left b -> let (sf', c) = sfTF' sfCL dt b+ in (choose sf' sfCR, Left c)+ Right d -> let (sf', e) = sfTF' sfCR dt d+ in (choose sfCL sf', Right e)++-- | Signal Functions as Arrows. See "The Yampa Arcade", by Courtney, Nilsson+-- and Peterson.+instance Arrow SF where+ arr = arrPrim+ first = firstPrim+ second = secondPrim+ (***) = parSplitPrim+ (&&&) = parFanOutPrim++#if __GLASGOW_HASKELL__ >= 610+#else+ (>>>) = compPrim+#endif++-- | Functor instance for applied SFs.+instance Functor (SF a) where+ fmap f = (>>> arr f)++-- | Applicative Functor instance (allows classic-frp style signals and+-- composition using applicative style).+instance Applicative (SF a) where+ pure x = arr (const x)+ f <*> x = (f &&& x) >>> arr (uncurry ($))++-- * 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)}++-- | Versatile zero-order hold SF' with folding.+--+-- This function returns an SF that, if there is an input, runs it through the+-- given function and returns part of its output and, if not, returns the last+-- known output.+--+-- The auxiliary function returns the value of the current output and the future+-- held output, thus making it possible to have to distinct outputs for the+-- present and the future.+epPrim :: (c -> a -> (c, b, b)) -> c -> b -> SF (Event a) b+epPrim f c bne = SF {sfTF = tf0}+ where+ tf0 NoEvent = (sfEP f c bne, bne)+ tf0 (Event a) = (sfEP f c' bne', b)+ where+ (c', b, bne') = f c a++-- | Constructor for a zero-order hold SF' with folding.+--+-- This function returns a running SF that, if there is an input, runs it+-- through the given function and returns part of its output and, if not,+-- returns the last known output.+--+-- The auxiliary function returns the value of the current output and the future+-- held output, thus making it possible to have to distinct outputs for the+-- present and the future.+sfEP :: (c -> a -> (c, b, b)) -> c -> b -> SF' (Event a) b+sfEP f c bne = sf+ where+ sf = SFEP (\_ ea -> case ea of+ NoEvent -> (sf, bne)+ Event a -> let (c', b, bne') = f c a+ in (sfEP f c' bne', b))+ f+ c+ bne++-- * Composition.++-- | SF 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)+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<X><Y> where <X> and <Y> 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+cpXX (SFSScan _ f1 s1 b) (SFSScan _ f2 s2 c) =+ sfSScan f (s1, b, s2, c) c+ where+ f (s1, b, s2, c) a =+ case f2 s2 b' of+ Nothing | u -> Nothing+ | otherwise -> Just ((s1', b', s2, c), c)+ Just (s2', c') -> Just ((s1', b', s2', c'), c')+ where+ (u, s1', b') = case f1 s1 a of+ Nothing -> (True, s1, b)+ Just (s1', b') -> (False, s1', b')+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)++cpXX (SFEP _ f1 s1 bne) (SFSScan _ f2 s2 c) =+ sfSScan f (s1, bne, s2, c) c+ where+ f (s1, bne, s2, c) ea =+ case f2 s2 b' of+ Nothing | u -> Nothing+ | otherwise -> Just (seq s1' (s1', bne', s2, c), c)+ Just (s2', c') -> Just (seq s1' (s1', bne', s2', c'), c')+ where+ (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')+cpXX (SFEP _ f1 s1 bne) (SFEP _ f2 s2 cne) =+ sfEP f (s1, s2, cne) (vfyNoEv bne cne)+ where+ -- The function "f" is invoked whenever an event is to be processed. It then+ -- computes the output, the new state, and the new NoEvent output. However,+ -- when sequencing event processors, the ones in the latter part of the+ -- chain may not get invoked since previous ones may decide not to "fire".+ -- But a "new" NoEvent output still has to be produced, i.e. the old one+ -- retained. Since it cannot be computed by invoking the last+ -- event-processing function in the chain, it has to be remembered. Since+ -- the composite event-processing function remains constant/unchanged, the+ -- NoEvent output has to be part of the state. An alternative would be to+ -- make the event-processing function take an extra argument. But that is+ -- likely to make the simple case more expensive. See note at sfEP.+ f (s1, s2, cne) a =+ case f1 s1 a of+ (s1', NoEvent, NoEvent) -> ((s1', s2, cne), cne, cne)+ (s1', Event b, NoEvent) ->+ let (s2', c, cne') = f2 s2 b in ((s1', s2', cne'), c, cne')+ _ -> usrErr "Yampa" "cpXX" $+ "Assertion failed: Functions on events must not map "+ ++ "NoEvent to Event."+cpXX sf1@(SFEP{}) (SFCpAXA _ (FDE f21 f21ne) sf22 fd23) =+ cpXX (cpXE sf1 f21 f21ne) (cpXA sf22 fd23)+cpXX sf1@(SFEP{}) (SFCpAXA _ (FDG f21) sf22 fd23) =+ cpXX (cpXG sf1 f21) (cpXA sf22 fd23)+cpXX (SFCpAXA _ fd11 sf12 (FDE f13 f13ne)) sf2@(SFEP{}) =+ cpXX (cpAX fd11 sf12) (cpEX f13 f13ne sf2)+cpXX (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+cpXX sf1 sf2 = SF' tf -- False+ where+ tf dt a = (cpXX sf1' sf2', c)+ where+ (sf1', b) = (sfTF' sf1) dt a+ (sf2', c) = (sfTF' sf2) dt b++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++ where+ tf dt a = (cpAXAAux fd1 f1 fd3 f3 sf2', f3 c)+ where+ (sf2', c) = (sfTF' sf2) dt (f1 a)++cpAX :: FunDesc a b -> SF' b c -> SF' a c+cpAX FDI sf2 = sf2+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++-- 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)+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+ where+ tf dt _ = (cpCX b sf2', c)+ where+ (sf2', c) = (sfTF' sf2) dt b++cpCXA :: b -> SF' b c -> FunDesc c d -> SF' a d+cpCXA b sf2 FDI = cpCX b sf2+cpCXA _ _ (FDC c) = sfConst c+cpCXA b sf2 fd3 = cpCXAAux (FDC b) b fd3 (fdFun fd3) sf2+ where+ -- Really: SF' b c -> SF' a d+ cpCXAAux :: FunDesc a b+ -> b+ -> FunDesc c d+ -> (c -> d)+ -> SF' b c+ -> SF' a d+ cpCXAAux _ b _ f3 (SFArr _ fd2) = sfConst (f3 ((fdFun fd2) b))+ cpCXAAux _ b _ f3 (SFSScan _ f s c) = sfSScan f' s (f3 c)+ where+ f' s _ = case f s b of+ Nothing -> Nothing+ Just (s', c') -> Just (s', f3 c')+ cpCXAAux _ b _ f3 (SFEP _ _ _ cne) = sfConst (f3 (vfyNoEv b cne))+ cpCXAAux _ b fd3 _ (SFCpAXA _ fd21 sf22 fd23) =+ cpCXA ((fdFun fd21) b) sf22 (fdComp fd23 fd3)+ cpCXAAux fd1 b fd3 f3 sf2 = SFCpAXA tf fd1 sf2 fd3+ where+ tf dt _ = (cpCXAAux fd1 b fd3 f3 sf2', f3 c)+ where+ (sf2', c) = (sfTF' sf2) dt b++cpGX :: (a -> b) -> SF' b c -> SF' a c+cpGX f1 sf2 = cpGXAux (FDG f1) f1 sf2+ where+ cpGXAux :: FunDesc a b -> (a -> b) -> SF' b c -> SF' a c+ cpGXAux fd1 _ (SFArr _ fd2) = sfArr (fdComp fd1 fd2)+ -- We actually do know that (fdComp (FDG f1) fd21) is going to result in an+ -- FDG. So we *could* call a cpGXA here. But the price is "inlining" of part+ -- of fdComp.+ cpGXAux _ f1 (SFSScan _ f s c) = sfSScan (\s a -> f s (f1 a)) s c+ -- We really shouldn't see an EP here, as that would mean an arrow+ -- INTRODUCING events ...+ cpGXAux fd1 _ (SFCpAXA _ fd21 sf22 fd23) =+ cpAXA (fdComp fd1 fd21) sf22 fd23+ cpGXAux fd1 f1 sf2 = SFCpAXA tf fd1 sf2 FDI+ where+ tf dt a = (cpGXAux fd1 f1 sf2', c)+ where+ (sf2', c) = (sfTF' sf2) dt (f1 a)++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 = (s', f2 b, f2 bne')+ where+ (s', b, bne') = f1 s a++ cpXGAux fd2 _ (SFCpAXA _ fd11 sf12 fd22) =+ cpAXA fd11 sf12 (fdComp fd22 fd2)++ cpXGAux fd2 f2 sf1 = SFCpAXA tf FDI sf1 fd2+ where+ tf dt a = (cpXGAux fd2 f2 sf1', f2 b)+ where+ (sf1', b) = (sfTF' sf1) dt a++cpEX :: (Event a -> b) -> b -> SF' b c -> SF' (Event a) c+cpEX f1 f1ne sf2 = cpEXAux (FDE f1 f1ne) f1 f1ne sf2+ where+ cpEXAux :: FunDesc (Event a) b+ -> (Event a -> b)+ -> b+ -> SF' b c+ -> SF' (Event a) c+ cpEXAux fd1 _ _ (SFArr _ fd2) = sfArr (fdComp fd1 fd2)+ cpEXAux _ f1 _ (SFSScan _ f s c) = sfSScan (\s a -> f s (f1 a)) s c+ -- We must not capture cne in the f closure since cne can change! See cpXX+ -- the SFEP/SFEP case for a similar situation. However, FDE represent a+ -- state-less signal function, so *its* NoEvent value never changes. Hence+ -- we only need to verify that it is NoEvent once.+ cpEXAux _ f1 f1ne (SFEP _ f2 s cne) =+ sfEP f (s, cne) (vfyNoEv f1ne cne)+ where+ f scne@(s, cne) a =+ case f1 (Event a) of+ NoEvent -> (scne, cne, cne)+ Event b -> ((s', cne'), c, cne')+ where+ (s', c, cne') = f2 s b++ cpEXAux fd1 _ _ (SFCpAXA _ fd21 sf22 fd23) =+ cpAXA (fdComp fd1 fd21) sf22 fd23+ -- The rationale for the following is that the case analysis is typically+ -- not going to be more expensive than applying the function and possibly a+ -- bit cheaper. Thus if events are sparse, we might win, and if not, we+ -- don't loose to much.+ cpEXAux fd1 f1 f1ne sf2 = SFCpAXA tf fd1 sf2 FDI+ where+ tf dt ea = (cpEXAux fd1 f1 f1ne sf2', c)+ where+ (sf2', c) =+ case ea of+ NoEvent -> (sfTF' sf2) dt f1ne+ _ -> (sfTF' sf2) dt (f1 ea)++cpXE :: SF' a (Event b) -> (Event b -> c) -> c -> SF' a c+cpXE sf1 f2 f2ne = cpXEAux (FDE f2 f2ne) f2 f2ne sf1+ where+ cpXEAux :: FunDesc (Event b) c+ -> (Event b -> c)+ -> c+ -> SF' a (Event b)+ -> SF' a c+ cpXEAux fd2 _ _ (SFArr _ fd1) = sfArr (fdComp fd1 fd2)+ cpXEAux _ f2 f2ne (SFSScan _ f s eb) = sfSScan f' s (f2 eb)+ where+ f' s a = case f s a of+ Nothing -> Nothing+ Just (s', NoEvent) -> Just (s', f2ne)+ Just (s', eb') -> Just (s', f2 eb')+ cpXEAux _ f2 f2ne (SFEP _ f1 s ebne) =+ sfEP f s (vfyNoEv ebne f2ne)+ where+ f s a =+ case f1 s a of+ (s', NoEvent, NoEvent) -> (s', f2ne, f2ne)+ (s', eb, NoEvent) -> (s', f2 eb, f2ne)+ _ -> usrErr "Yampa" "cpXEAux" $+ "Assertion failed: Functions on events must not "+ ++ "map NoEvent to Event."+ cpXEAux fd2 _ _ (SFCpAXA _ fd11 sf12 fd13) =+ cpAXA fd11 sf12 (fdComp fd13 fd2)+ cpXEAux fd2 f2 f2ne sf1 = SFCpAXA tf FDI sf1 fd2+ where+ tf dt a = ( cpXEAux fd2 f2 f2ne sf1'+ , case eb of NoEvent -> f2ne; _ -> f2 eb+ )+ where+ (sf1', eb) = (sfTF' sf1) dt a++-- * Widening.++-- | 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++fpAux :: SF' a b -> SF' (a, c) (b, c)+fpAux (SFArr _ FDI) = sfId -- New+fpAux (SFArr _ (FDC b)) = sfArrG (\(~(_, c)) -> (b, c))+fpAux (SFArr _ fd1) = sfArrG (\(~(a, c)) -> ((fdFun fd1) a, c))+fpAux sf1 = SF' tf+ where+ tf dt ~(a, c) = (fpAux sf1', (b, c))+ where+ (sf1', b) = (sfTF' sf1) dt a++-- Mirror image of first.+secondPrim :: SF a b -> SF (c, a) (c, b)+secondPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}+ where+ tf0 ~(c0, a0) = (spAux sf1, (c0, b0))+ where+ (sf1, b0) = tf10 a0++spAux :: SF' a b -> SF' (c, a) (c, b)+spAux (SFArr _ FDI) = sfId -- New+spAux (SFArr _ (FDC b)) = sfArrG (\(~(c, _)) -> (c, b))+spAux (SFArr _ fd1) = sfArrG (\(~(c, a)) -> (c, (fdFun fd1) a))+spAux sf1 = SF' tf+ where+ tf dt ~(c, a) = (spAux sf1', (c, b))+ where+ (sf1', b) = (sfTF' sf1) dt a++-- * 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<X><Y> where <X> and <Y> 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)+ psXX sf1 sf2 = SF' tf+ where+ tf dt ~(a, c) = (psXX sf1' sf2', (b, d))+ where+ (sf1', b) = (sfTF' sf1) dt a+ (sf2', d) = (sfTF' sf2) dt c++ psCX :: b -> SF' c d -> SF' (a, c) (b, d)+ psCX b (SFArr _ fd2) = sfArr (fdPar (FDC b) fd2)+ psCX b sf2 = SF' tf+ where+ tf dt ~(_, c) = (psCX b sf2', (b, d))+ where+ (sf2', d) = (sfTF' sf2) dt c++ psXC :: SF' a b -> d -> SF' (a, c) (b, d)+ psXC (SFArr _ fd1) d = sfArr (fdPar fd1 (FDC d))+ psXC sf1 d = SF' tf+ where+ tf dt ~(a, _) = (psXC sf1' d, (b, d))+ where+ (sf1', b) = (sfTF' sf1) dt a++ psAX :: (a -> b) -> SF' c d -> SF' (a, c) (b, d)+ psAX f1 (SFArr _ fd2) = sfArr (fdPar (FDG f1) fd2)+ psAX f1 sf2 = SF' tf+ where+ tf dt ~(a, c) = (psAX f1 sf2', (f1 a, d))+ where+ (sf2', d) = (sfTF' sf2) dt c++ psXA :: SF' a b -> (c -> d) -> SF' (a, c) (b, d)+ psXA (SFArr _ fd1) f2 = sfArr (fdPar fd1 (FDG f2))+ psXA sf1 f2 = SF' tf+ where+ tf dt ~(a, c) = (psXA sf1' f2, (b, f2 c))+ where+ (sf1', b) = (sfTF' sf1) dt a++parFanOutPrim :: SF a b -> SF a c -> SF a (b, c)+parFanOutPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}+ where+ tf0 a0 = (pfoXX sf1 sf2, (b0, c0))+ where+ (sf1, b0) = tf10 a0+ (sf2, c0) = tf20 a0++ -- Naming convention: pfo<X><Y> where <X> and <Y> is one of:+ -- X - arbitrary signal function+ -- A - arbitrary pure arrow+ -- I - identity arrow+ -- C - constant arrow++ pfoXX :: SF' a b -> SF' a c -> SF' a (b, c)+ pfoXX (SFArr _ fd1) (SFArr _ fd2) = sfArr(fdFanOut fd1 fd2)+ pfoXX (SFArr _ FDI) sf2 = pfoIX sf2+ pfoXX (SFArr _ (FDC b)) sf2 = pfoCX b sf2+ pfoXX (SFArr _ fd1) sf2 = pfoAX (fdFun fd1) sf2+ pfoXX sf1 (SFArr _ FDI) = pfoXI sf1+ pfoXX sf1 (SFArr _ (FDC c)) = pfoXC sf1 c+ pfoXX sf1 (SFArr _ fd2) = pfoXA sf1 (fdFun fd2)+ pfoXX sf1 sf2 = SF' tf+ where+ tf dt a = (pfoXX sf1' sf2', (b, c))+ where+ (sf1', b) = (sfTF' sf1) dt a+ (sf2', c) = (sfTF' sf2) dt a++ pfoIX :: SF' a c -> SF' a (a, c)+ pfoIX (SFArr _ fd2) = sfArr (fdFanOut FDI fd2)+ pfoIX sf2 = SF' tf+ where+ tf dt a = (pfoIX sf2', (a, c))+ where+ (sf2', c) = (sfTF' sf2) dt a++ pfoXI :: SF' a b -> SF' a (b, a)+ pfoXI (SFArr _ fd1) = sfArr (fdFanOut fd1 FDI)+ pfoXI sf1 = SF' tf+ where+ tf dt a = (pfoXI sf1', (b, a))+ where+ (sf1', b) = (sfTF' sf1) dt a++ pfoCX :: b -> SF' a c -> SF' a (b, c)+ pfoCX b (SFArr _ fd2) = sfArr (fdFanOut (FDC b) fd2)+ pfoCX b sf2 = SF' tf+ where+ tf dt a = (pfoCX b sf2', (b, c))+ where+ (sf2', c) = (sfTF' sf2) dt a++ pfoXC :: SF' a b -> c -> SF' a (b, c)+ pfoXC (SFArr _ fd1) c = sfArr (fdFanOut fd1 (FDC c))+ pfoXC sf1 c = SF' tf+ where+ tf dt a = (pfoXC sf1' c, (b, c))+ where+ (sf1', b) = (sfTF' sf1) dt a++ pfoAX :: (a -> b) -> SF' a c -> SF' a (b, c)+ pfoAX f1 (SFArr _ fd2) = sfArr (fdFanOut (FDG f1) fd2)+ pfoAX f1 sf2 = SF' tf+ where+ tf dt a = (pfoAX f1 sf2', (f1 a, c))+ where+ (sf2', c) = (sfTF' sf2) dt a++ pfoXA :: SF' a b -> (a -> c) -> SF' a (b, c)+ pfoXA (SFArr _ fd1) f2 = sfArr (fdFanOut fd1 (FDG f2))+ pfoXA sf1 f2 = SF' tf+ where+ tf dt a = (pfoXA sf1' f2, (b, f2 a))+ where+ (sf1', b) = (sfTF' sf1) dt a++-- * ArrowLoop instance and implementation++-- | Creates a feedback loop without delay.+instance ArrowLoop SF where+ loop = loopPrim++loopPrim :: SF (a, c) (b, c) -> SF a b+loopPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}+ where+ tf0 a0 = (loopAux sf1, b0)+ where+ (sf1, (b0, c0)) = tf10 (a0, c0)++ loopAux :: SF' (a, c) (b, c) -> SF' a b+ loopAux (SFArr _ FDI) = sfId+ loopAux (SFArr _ (FDC (b, _))) = sfConst b+ loopAux (SFArr _ fd1) =+ sfArrG (\a -> let (b, c) = (fdFun fd1) (a, c) in b)+ loopAux sf1 = SF' tf+ where+ tf dt a = (loopAux sf1', b)+ where+ (sf1', (b, c)) = (sfTF' sf1) dt (a, c)++-- * Scanning++-- | Constructor for a zero-order hold with folding.+--+-- This function returns a running SF that takes an input, runs it through a+-- function and, if there is an output, returns it, otherwise, returns the+-- previous value. Additionally, an accumulator or folded value is kept+-- internally.+sfSScan :: (c -> a -> Maybe (c, b)) -> c -> b -> SF' a b+sfSScan f c b = sf+ where+ sf = SFSScan tf f c b+ tf _ a = case f c a of+ Nothing -> (sf, b)+ Just (c', b') -> (sfSScan f c' b', b')
− src/FRP/Yampa/Internals.hs
@@ -1,25 +0,0 @@--------------------------------------------------------------------------------------------- |--- 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
src/FRP/Yampa/Loop.hs view
@@ -1,44 +1,41 @@-{-# 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)+-- Module : FRP.Yampa.Loop+-- Copyright : (c) Ivan Perez, 2014-2022+-- (c) George Giorgidze, 2007-2012+-- (c) Henrik Nilsson, 2005-2006+-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004+-- License : BSD-style (see the LICENSE file in the distribution) ----- Maintainer : ivan.perez@keera.co.uk--- Stability : provisional+-- Maintainer : ivan.perez@keera.co.uk+-- Stability : provisional ----- Portability : non-portable -GHC extensions-+-- Portability : non-portable -GHC extensions- ----- Well-initialised loops--------------------------------------------------------------------------------------------module FRP.Yampa.Loop (- -- * Loops with guaranteed well-defined feedback- loopPre, -- :: c -> SF (a,c) (b,c) -> SF a b- loopIntegral, -- :: VectorSpace c s => SF (a,c) (b,c) -> SF a b-) where-+-- Well-initialised loops.+module FRP.Yampa.Loop+ (+ -- * Loops with guaranteed well-defined feedback+ loopPre+ , loopIntegral+ )+ where -import Control.Arrow+-- External imports+import Control.Arrow (loop, second, (>>>))+import Data.VectorSpace (VectorSpace) +-- Internal imports+import FRP.Yampa.Delays (iPre)+import FRP.Yampa.Integration (integral) import FRP.Yampa.InternalCore (SF) -import FRP.Yampa.Integration-import FRP.Yampa.Delays-import FRP.Yampa.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)+loopPre :: c -> SF (a, c) (b, c) -> SF a b+loopPre cInit sf = loop (second (iPre cInit) >>> 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 => SF (a,c) (b,c) -> SF a b+-- | 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 :: (Fractional s, VectorSpace c s) => SF (a, c) (b, c) -> SF a b loopIntegral sf = loop (second integral >>> sf)---- Vim modeline--- vim:set tabstop=8 expandtab:
− src/FRP/Yampa/MergeableRecord.hs
@@ -1,86 +0,0 @@--------------------------------------------------------------------------------------------- |--- 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<N> = setL1 vN ~+~ foo<N-1>--- let fooFinal = mrFinalize foo<N>--- @--------------------------------------------------------------------------------------------module FRP.Yampa.MergeableRecord (- MergeableRecord(..),- MR, -- Abstract- mrMake,- (~+~),- mrMerge,- mrFinalize-) where--class MergeableRecord a where- mrDefault :: a----- Type constructor for mergeable records.-newtype MR a = MR (a -> a)----- Construction of a mergeable record.-mrMake :: MergeableRecord a => (a -> a) -> MR a-mrMake f = (MR f)----- Merge two mergeable records. Left "overrides" in case of conflict.-(~+~) :: MergeableRecord a => MR a -> MR a -> MR a-(MR f1) ~+~ (MR f2) = MR (f1 . f2)--mrMerge :: MergeableRecord a => MR a -> MR a -> MR a-mrMerge = (~+~)----- Finalization: turn a mergeable record into a record.-mrFinalize :: MergeableRecord a => MR a -> a-mrFinalize (MR f) = f mrDefault
− src/FRP/Yampa/Miscellany.hs
@@ -1,195 +0,0 @@--------------------------------------------------------------------------------------------- |--- 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 ($)
− src/FRP/Yampa/Point2.hs
@@ -1,66 +0,0 @@-{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, FlexibleInstances, StandaloneDeriving #-}--------------------------------------------------------------------------------------------- |--- Module : FRP.Yampa.Point2--- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : nilsson@cs.yale.edu--- Stability : provisional--- Portability : non-portable (GHC extensions)------ 2D point abstraction (R^2).-----------------------------------------------------------------------------------------------module FRP.Yampa.Point2 (- -- module AFRPVectorSpace,- -- module AFRPAffineSpace,- -- module AFRPVector2,- Point2(..), -- Non-abstract, instance of AffineSpace- point2X, -- :: RealFloat a => Point2 a -> a- point2Y -- :: RealFloat a => Point2 a -> a-) where--import FRP.Yampa.VectorSpace ()-import FRP.Yampa.AffineSpace-import FRP.Yampa.Vector2-import FRP.Yampa.Forceable----------------------------------------------------------------------------------- 2D point, constructors and selectors.---------------------------------------------------------------------------------data Point2 a = RealFloat a => Point2 !a !a--deriving instance Eq a => Eq (Point2 a)--deriving instance Show a => Show (Point2 a)--point2X :: RealFloat a => Point2 a -> a-point2X (Point2 x _) = x--point2Y :: RealFloat a => Point2 a -> a-point2Y (Point2 _ y) = y------------------------------------------------------------------------------------ Affine space instance---------------------------------------------------------------------------------instance RealFloat a => AffineSpace (Point2 a) (Vector2 a) a where- origin = Point2 0 0-- (Point2 x y) .+^ v = Point2 (x + vector2X v) (y + vector2Y v)-- (Point2 x y) .-^ v = Point2 (x - vector2X v) (y - vector2Y v)-- (Point2 x1 y1) .-. (Point2 x2 y2) = vector2 (x1 - x2) (y1 - y2)------------------------------------------------------------------------------------ Forceable instance---------------------------------------------------------------------------------instance RealFloat a => Forceable (Point2 a) where- force = id
− src/FRP/Yampa/Point3.hs
@@ -1,73 +0,0 @@-{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, FlexibleInstances, StandaloneDeriving #-}--------------------------------------------------------------------------------------------- |--- Module : FRP.Yampa.Point3--- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : nilsson@cs.yale.edu--- Stability : provisional--- Portability : non-portable (GHC extensions)------ 3D point abstraction (R^3).-----------------------------------------------------------------------------------------------module FRP.Yampa.Point3 (- -- module AFRPVectorSpace,- -- module AFRPAffineSpace,- -- module AFRPVector3,- Point3(..), -- Non-abstract, instance of AffineSpace- point3X, -- :: RealFloat a => Point3 a -> a- point3Y, -- :: RealFloat a => Point3 a -> a- point3Z -- :: RealFloat a => Point3 a -> a-) where--import FRP.Yampa.VectorSpace ()-import FRP.Yampa.AffineSpace-import FRP.Yampa.Vector3-import FRP.Yampa.Forceable----------------------------------------------------------------------------------- 3D point, constructors and selectors.---------------------------------------------------------------------------------data Point3 a = RealFloat a => Point3 !a !a !a--deriving instance Eq a => Eq (Point3 a)--deriving instance Show a => Show (Point3 a)--point3X :: RealFloat a => Point3 a -> a-point3X (Point3 x _ _) = x--point3Y :: RealFloat a => Point3 a -> a-point3Y (Point3 _ y _) = y--point3Z :: RealFloat a => Point3 a -> a-point3Z (Point3 _ _ z) = z------------------------------------------------------------------------------------ Affine space instance---------------------------------------------------------------------------------instance RealFloat a => AffineSpace (Point3 a) (Vector3 a) a where- origin = Point3 0 0 0-- (Point3 x y z) .+^ v =- Point3 (x + vector3X v) (y + vector3Y v) (z + vector3Z v)-- (Point3 x y z) .-^ v =- Point3 (x - vector3X v) (y - vector3Y v) (z - vector3Z v)-- (Point3 x1 y1 z1) .-. (Point3 x2 y2 z2) =- vector3 (x1 - x2) (y1 - y2) (z1 - z2)------------------------------------------------------------------------------------ Forceable instance---------------------------------------------------------------------------------instance RealFloat a => Forceable (Point3 a) where- force = id
src/FRP/Yampa/Random.hs view
@@ -1,106 +1,85 @@-{-# 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)+-- Module : FRP.Yampa.Random+-- Copyright : (c) Ivan Perez, 2014-2022+-- (c) George Giorgidze, 2007-2012+-- (c) Henrik Nilsson, 2005-2006+-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004+-- License : BSD-style (see the LICENSE file in the distribution) ----- Maintainer : ivan.perez@keera.co.uk--- Stability : provisional--- Portability : non-portable (GHC extensions)+-- 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)+-- Signals and signal functions with noise and randomness.+--+-- The Random number generators are re-exported from "System.Random".+module FRP.Yampa.Random+ (+ -- * Random number generators+ RandomGen(..)+ , Random(..) -) where+ -- * Noise, random signals, and stochastic event sources+ , noise+ , noiseR+ , occasionally+ )+ where -import System.Random (RandomGen(..), Random(..))+-- External imports+import System.Random (Random (..), RandomGen (..)) -import FRP.Yampa.InternalCore (SF(..), SF'(..), Time)-import FRP.Yampa.Diagnostics-import FRP.Yampa.Event+-- Internal imports+import FRP.Yampa.Diagnostics (intErr, usrErr)+import FRP.Yampa.Event (Event (..))+import FRP.Yampa.InternalCore (SF (..), SF' (..), Time) ---------------------------------------------------------------------------------- Noise (i.e. random signal generators) and stochastic processes-------------------------------------------------------------------------------+-- * Noise (i.e. random signal generators) and stochastic processes --- | Noise (random signal) with default range for type in question;--- based on "randoms".+-- | Noise (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 :: (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.-+-- | Turn an infinite list of elements into an SF producing those elements. The+-- SF ignores its input. streamToSF :: [b] -> SF a b-streamToSF [] = intErr "AFRP" "streamToSF" "Empty list!"+streamToSF [] = intErr "Yampa" "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)---}+ where+ tf0 _ = (stsfAux bs, b) + stsfAux [] = intErr "Yampa" "streamToSF" "Empty list!"+ -- Invarying since stsfAux [] is an error.+ stsfAux (b:bs) = SF' tf -- True+ where+ tf _ _ = (stsfAux bs, b) --- | Stochastic event source with events occurring on average once every t_avg+-- | Stochastic event source with events occurring on average once every tAvg -- 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".+-- interval in the case of relatively sparse sampling, thus avoiding an "event+-- backlog" should sampling become more frequent at some later point in time. 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.+occasionally g tAvg x | tAvg > 0 = SF {sfTF = tf0}+ | otherwise = usrErr "Yampa" "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 [] = 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:+ where+ tf dt _ = (occAux rs, if r < p then Event x else NoEvent)+ where+ p = 1 - exp (- (dt / tAvg)) -- Probability for at least one event.
src/FRP/Yampa/Scan.hs view
@@ -1,42 +1,51 @@-{-# 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)+-- Module : FRP.Yampa.Scan+-- Copyright : (c) Ivan Perez, 2014-2022+-- (c) George Giorgidze, 2007-2012+-- (c) Henrik Nilsson, 2005-2006+-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004+-- 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+-- Maintainer : ivan.perez@keera.co.uk+-- Stability : provisional+-- Portability : non-portable (GHC extensions)+--+-- Simple, stateful signal processing.+--+-- Scanning implements elementary, step-based accumulating over signal functions+-- by means of an auxiliary function applied to each input and to an+-- accumulator. For comparison with other FRP libraries and with stream+-- processing abstractions, think of fold.+module FRP.Yampa.Scan+ ( sscan+ , sscanPrim+ )+ where +-- Internal imports 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.+-- ** Simple, stateful signal processing +-- | Applies a function point-wise, using the last output as next input. This+-- creates a well-formed loop based on a pure, auxiliary function. sscan :: (b -> a -> b) -> b -> SF a b-sscan f b_init = sscanPrim f' b_init b_init- where- f' b a = let b' = f b a in Just (b', b')+sscan f bInit = sscanPrim f' bInit bInit+ where+ f' b a = Just (b', b')+ where+ b' = f b a +-- | Generic version of 'sscan', in which the auxiliary function produces an+-- internal accumulator and an "held" output.+--+-- Applies a function point-wise, using the last known 'Just' output to form the+-- output, and next input accumulator. If the output is 'Nothing', the last+-- known accumulators are used. This creates a well-formed loop based on a pure,+-- auxiliary function. sscanPrim :: (c -> a -> Maybe (c, b)) -> c -> b -> SF a b-sscanPrim f c_init b_init = SF {sfTF = tf0}- where- tf0 a0 = case f c_init a0 of- Nothing -> (sfSScan f c_init b_init, b_init)- Just (c', b') -> (sfSScan f c' b', b')---- Vim modeline--- vim:set tabstop=8 expandtab:+sscanPrim f cInit bInit = SF {sfTF = tf0}+ where+ tf0 a0 = case f cInit a0 of+ Nothing -> (sfSScan f cInit bInit, bInit)+ Just (c', b') -> (sfSScan f c' b', b')
src/FRP/Yampa/Simulation.hs view
@@ -1,87 +1,76 @@-{-# 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)+-- Module : FRP.Yampa.Simulation+-- Copyright : (c) Ivan Perez, 2014-2022+-- (c) George Giorgidze, 2007-2012+-- (c) Henrik Nilsson, 2005-2006+-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004+-- License : BSD-style (see the LICENSE file in the distribution) ----- Maintainer : ivan.perez@keera.co.uk--- Stability : provisional--- Portability : non-portable (GHC extensions)+-- 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+-- Execution/simulation of signal functions.+--+-- SFs can be executed in two ways: by running them, feeding input samples one+-- by one, obtained from a monadic environment (presumably, @IO@), or by passing+-- an input stream and calculating an output stream. The former is called+-- /reactimation/, and the latter is called /embedding/.+--+-- * Running:+-- Normally, to run an SF, you would use 'reactimate', providing input samples,+-- and consuming the output samples in the 'IO' monad. This function takes over+-- the program, implementing a "main loop". If you want more control over the+-- evaluation loop (for instance, if you are using Yampa in combination with a+-- backend that also implements some main loop), you may want to use the+-- lower-level API for reactimation ('ReactHandle', 'reactInit', 'react').+--+-- * Embedding:+-- You can use 'embed' for testing, to evaluate SFs in a terminal, and to embed+-- an SF inside a larger system. The helper functions 'deltaEncode' and+-- 'deltaEncodeBy' facilitate producing input /signals/ from plain lists of+-- input samples.+--+-- This module also includes debugging aids needed to execute signal functions+-- step by step, which are used by Yampa's testing facilities.+module FRP.Yampa.Simulation+ (+ -- * Reactimation+ reactimate --- ** 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)])+ -- ** Low-level reactimation interface+ , ReactHandle+ , reactInit+ , react -) where+ -- * Embedding+ , embed+ , embedSynch+ , deltaEncode+ , deltaEncodeBy -import Control.Monad (unless)-import Data.IORef-import Data.Maybe (fromMaybe)+ -- * Debugging / Step by step simulation -import FRP.Yampa.InternalCore (SF(..), SF'(..), sfTF', DTime)+ , FutureSF+ , evalAtZero+ , evalAt+ , evalFuture+ )+ where -import FRP.Yampa.Diagnostics+-- External imports+import Control.Monad (unless)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Maybe (fromMaybe) ---------------------------------------------------------------------------------- Reactimation-------------------------------------------------------------------------------+-- Internal imports+import FRP.Yampa.Diagnostics (intErr, usrErr)+import FRP.Yampa.InternalCore (DTime, SF (..), SF' (..), sfTF') --- 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.+-- * Reactimation --- | Convenience function to run a signal function indefinitely, using--- a IO actions to obtain new input and process the output.+-- | 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.@@ -91,212 +80,200 @@ -- 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+-- 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.+-- 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'.-+-- 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 :: Monad m- => m a -- ^ Initialization action- -> (Bool -> m (DTime, Maybe a)) -- ^ Input sensing action- -> (Bool -> b -> m Bool) -- ^ Actuaction (output processing) action- -> SF a b -- ^ Signal function+ => m a -- ^ Initialization action+ -> (Bool -> m (DTime, Maybe a)) -- ^ Input sensing action+ -> (Bool -> b -> m Bool) -- ^ Actuation (output processing)+ -- action+ -> SF a b -- ^ Signal function -> m ()-reactimate init sense actuate (SF {sfTF = tf0}) =- do- a0 <- init- let (sf, b0) = tf0 a0- loop sf a0 b0- where- loop sf a b = do- done <- actuate True b- unless (a `seq` b `seq` done) $ do- (dt, ma') <- sense False- let a' = fromMaybe a ma'- (sf', b') = (sfTF' sf) dt a'- loop sf' a' b'-+reactimate init sense actuate (SF {sfTF = tf0}) = do+ a0 <- init+ let (sf, b0) = tf0 a0+ loop sf a0 b0+ where+ loop sf a b = do+ done <- actuate True b+ unless (a `seq` b `seq` done) $ do+ (dt, ma') <- sense False+ let a' = fromMaybe a ma'+ (sf', b') = (sfTF' sf) dt a'+ loop sf' a' b' --- An API for animating a signal function when some other library--- needs to own the top-level control flow:+-- An API for animating a signal function when some other library needs to own+-- the top-level control flow: -- reactimate's state, maintained across samples:-data ReactState a b = ReactState {- rsActuate :: ReactHandle a b -> Bool -> b -> IO Bool,- rsSF :: SF' a b,- rsA :: a,- rsB :: b+data ReactState a b = ReactState+ { rsActuate :: ReactHandle a b -> Bool -> b -> IO Bool+ , rsSF :: SF' a b+ , rsA :: a+ , rsB :: b } -- | A reference to reactimate's state, maintained across samples.-type ReactHandle a b = IORef (ReactState a b)+newtype ReactHandle a b = ReactHandle+ { reactHandle :: 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+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+ }+ )+ let r = ReactHandle r'+ _ <- actuate r True b0+ return r -- | Process a single input sample. react :: ReactHandle a b- -> (DTime,Maybe a)+ -> (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-+react rh (dt, ma') = do+ rs <- readIORef (reactHandle rh)+ let ReactState {rsActuate = actuate, rsSF = sf, rsA = a, rsB = _b } = rs ---------------------------------------------------------------------------------- Embedding-------------------------------------------------------------------------------+ let a' = fromMaybe a ma'+ (sf', b') = (sfTF' sf) dt a'+ writeIORef (reactHandle rh) (rs {rsSF = sf', rsA = a', rsB = b'})+ done <- actuate rh True b'+ return done --- 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.+-- * Embedding --- | 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.+-- | 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+ where+ (sf, b0) = (sfTF sf0) a0 + loop _ _ [] = []+ loop aPrev sf ((dt, ma) : dtas) =+ b : (a `seq` b `seq` loop a sf' dtas)+ where+ a = fromMaybe aPrev 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!-+-- input and time stream at a given (but variable) ratio >= 0 to the outer time+-- flow. When the ratio is 0, the embedded signal function is paused. embedSynch :: SF a b -> (a, [(DTime, Maybe a)]) -> SF Double b embedSynch sf0 (a0, dtas) = SF {sfTF = tf0}- where- tts = scanl (\t (dt, _) -> t + dt) 0 dtas- bbs@(b:_) = embed sf0 (a0, dtas)+ where+ tts = scanl (\t (dt, _) -> t + dt) 0 dtas+ bbs@(b:_) = embed sf0 (a0, dtas) - tf0 _ = (esAux 0 (zip tts bbs), b)+ 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)+ esAux _ [] = intErr "Yampa" "embedSynch" "Empty list!"+ -- Invarying below since esAux [] is an error.+ esAux tpPrev tbtbs = SF' tf -- True+ where+ tf dt r | r < 0 = usrErr "Yampa" "embedSynch" "Negative ratio."+ | otherwise = (esAux tp tbtbs', b)+ where+ tp = tpPrev + dt * r+ (b, tbtbs') = advance tp tbtbs - -- 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+ -- 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.+-- | 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 _ [] = usrErr "Yampa" "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 _ _ [] = usrErr "Yampa" "deltaEncodeBy" "Empty input list." deltaEncodeBy eq dt (a0:as) = (a0, zip (repeat dt) (debAux a0 as))- where- debAux _ [] = []- debAux a_prev (a:as) | a `eq` a_prev = Nothing : debAux a as- | otherwise = Just a : debAux a as+ where+ debAux _ [] = []+ debAux aPrev (a:as) | a `eq` aPrev = 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.+-- * Debugging / Step by step simulation++-- | A wrapper around an initialized SF (continuation), needed for testing and+-- debugging purposes.+newtype FutureSF a b = FutureSF { unsafeSF :: SF' a b }++-- | Evaluate an SF, and return an output and an initialized SF. ----- Possible signature:+-- /WARN/: Do not use this function for standard simulation. This function is+-- intended only for debugging/testing. Apart from being potentially slower and+-- consuming more memory, it also breaks the FRP abstraction by making samples+-- discrete and step based.+evalAtZero :: SF a b+ -> a -- ^ Input sample+ -> (b, FutureSF a b) -- ^ Output x Continuation+evalAtZero (SF { sfTF = tf }) a = (b, FutureSF tf' )+ where+ (tf', b) = tf a++-- | Evaluate an initialized SF, and return an output and a continuation. ----- resample :: Time -> (c -> [a]) -> SF a b -> ([b] -> d) -> SF c d+-- /WARN/: Do not use this function for standard simulation. This function is+-- intended only for debugging/testing. Apart from being potentially slower and+-- consuming more memory, it also breaks the FRP abstraction by making samples+-- discrete and step based.+evalAt :: FutureSF a b+ -> DTime -> a -- ^ Input sample+ -> (b, FutureSF a b) -- ^ Output x Continuation+evalAt (FutureSF { unsafeSF = tf }) dt a = (b, FutureSF tf')+ where+ (tf', b) = (sfTF' tf) dt a++-- | Given a signal function and time delta, it moves the signal function into+-- the future, returning a new uninitialized SF and the initial output. ----- 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!+-- While the input sample refers to the present, the time delta refers to the+-- future (or to the time between the current sample and the next sample).+--+-- /WARN/: Do not use this function for standard simulation. This function is+-- intended only for debugging/testing. Apart from being potentially slower and+-- consuming more memory, it also breaks the FRP abstraction by making samples+-- discrete and step based.+evalFuture :: SF a b -> a -> DTime -> (b, SF a b)+evalFuture sf a dt = (b, sf' dt)+ where+ (b, sf') = evalStep sf a --- Vim modeline--- vim:set tabstop=8 expandtab:+-- | Steps the signal function into the future one step. It returns the current+-- output, and a signal function that expects, apart from an input, a time+-- between samples.+evalStep :: SF a b -> a -> (b, DTime -> SF a b)+evalStep (SF sf) a = (b, \dt -> SF (sfTF' sf' dt))+ where+ (sf', b) = sf a
src/FRP/Yampa/Switches.hs view
@@ -1,858 +1,744 @@-{-# 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)------ Switches allow you to change the signal function being applied.------ The basic idea of switching is fromed by combining a subordinate signal function--- and a signal function continuation parameterised over some initial data.------ For example, the most basic switch has the following signature:------ @switch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b@------ which indicates that it has two parameters: a signal function--- that produces an output and indicates, with an event, when it is time to--- switch, and a signal function that starts with the residual data left by the--- first SF in the event and continues onwards.------ Note that switching occurs, at most, once. If you want something to switch--- repeatedly, you need to loop. However, some switches are immediate (meaning--- that the second SF is started at the time of switching). If you use the same--- SF that originally provoked the switch, you are very likely to fall into an--- infinite loop.--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]-- -- Application of an SF to a collections- parC, -- SF a b -> SF [a] [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 <https://wiki.haskell.org/Yampa#Switches> 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 <https://wiki.haskell.org/Yampa#Switches> 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 <https://wiki.haskell.org/Yampa#Switches> 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 <https://wiki.haskell.org/Yampa#Switches> 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--- <http://haskell.cs.yale.edu/wp-content/uploads/2011/01/yampa-arcade.pdf>-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--- <http://haskell.cs.yale.edu/wp-content/uploads/2011/01/yampa-arcade.pdf>-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--- <http://haskell.cs.yale.edu/wp-content/uploads/2011/01/yampa-arcade.pdf>-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--- <http://haskell.cs.yale.edu/wp-content/uploads/2011/01/yampa-arcade.pdf>-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--- <http://haskell.cs.yale.edu/wp-content/uploads/2011/01/yampa-arcade.pdf>-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 switchers.-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---- Apply an SF to every element of a list.-parC :: SF a b -> SF [a] [b]-parC sf = SF $ \as -> let os = map (sfTF sf) as- bs = map snd os- sfs = map fst os- in (parCAux sfs, bs)---- Internal definition. Also used in parallel switchers.-parCAux :: [SF' a b] -> SF' [a] [b]-parCAux sfs = SF' tf- where- tf dt as =- let os = map (\(a,sf) -> sfTF' sf dt a) $ safeZip "parC" as sfs- bs = map snd os- sfcs = map fst os- in- (listSeq sfcs `seq` parCAux sfcs, listSeq bs)--listSeq :: [a] -> [a]-listSeq x = x `seq` (listSeq' x)--listSeq' :: [a] -> [a]-listSeq' [] = []-listSeq' rs@(a:as) = a `seq` listSeq' as `seq` rs----- Vim modeline--- vim:set tabstop=8 expandtab:+{-# LANGUAGE Rank2Types #-}+-- |+-- Module : FRP.Yampa.Switches+-- Copyright : (c) Ivan Perez, 2014-2022+-- (c) George Giorgidze, 2007-2012+-- (c) Henrik Nilsson, 2005-2006+-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : ivan.perez@keera.co.uk+-- Stability : provisional+-- Portability : non-portable (GHC extensions)+--+-- Switches allow you to change the signal function being applied.+--+-- The basic idea of switching is formed by combining a subordinate signal+-- function and a signal function continuation parameterised over some initial+-- data.+--+-- For example, the most basic switch has the following signature:+--+-- @switch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b@+--+-- which indicates that it has two parameters: a signal function that produces+-- an output and indicates, with an event, when it is time to switch, and a+-- signal function that starts with the residual data left by the first SF in+-- the event and continues onwards.+--+-- Switching occurs, at most, once. If you want something to switch repeatedly,+-- in general, you need to loop, or to switch onto the same signal function+-- again. However, some switches, explained below, are immediate (meaning that+-- the second SF is started at the time of switching). If you use the same SF+-- that originally provoked the switch, you are very likely to fall into an+-- infinite loop. In those cases, the use of 'dSwitch' or '-->' may help.+--+-- Switches vary depending on a number of criteria:+--+-- - /Decoupled/ vs normal switching /(d)/: when an SF is being applied and a+-- different SF needs to be applied next, one question is which one is used for+-- the time in which the switching takes place. In decoupled switching, the old+-- SF is used for the time of switching, and the one SF is only used after that.+-- In normal or instantaneous or coupled switching, the old SF is discarded+-- immediately and a new SF is used for the output already from that point in+-- time.+--+-- - How the switching event is provided /( \/r\/k)/: normally, an 'Event' is+-- used to indicate that a switching must take place. This event can be part of+-- the argument SF (e.g., 'switch'), it can be part of the input (e.g.,+-- 'rSwitch'), or it can be determined by a second argument SF (e.g, 'kSwitch').+--+-- - How many SFs are being handled /( \/p\/par)/: some combinators deal with+-- only one SF, others handle collections, either in the form of a 'Functor' or+-- a list ('[]').+--+-- - How the input is router /(B\/Z\/ )/: when multiple SFs are being combined,+-- a decision needs to be made about how the input is passed to the internal+-- SFs. In some cases, broadcasting is used to pass the same input to all+-- internal SFs. In others, the input is itself a collection, and each element+-- is passed to one internal SF (i.e., /zipping/). In others, an auxiliary+-- function is used to decide how to route specific inputs to specific SFs in+-- the collection.+--+-- These gives a number of different combinations, some of which make no sense,+-- and also helps determine the expected behaviour of a combinator by looking at+-- its name. For example, 'drpSwitchB' is the decoupled (/d/), recurrent (/r/),+-- parallel (/p/) switch with broadcasting (/B/).+module FRP.Yampa.Switches+ (+ -- * Basic switching+ switch, dSwitch+ , rSwitch, drSwitch+ , kSwitch, dkSwitch++ -- * Parallel composition\/switching (collections)+ -- ** With broadcasting+ , parB+ , pSwitchB, dpSwitchB+ , rpSwitchB, drpSwitchB++ -- ** With helper routing function+ , par+ , pSwitch, dpSwitch+ , rpSwitch, drpSwitch++ -- * Parallel composition\/switching (lists)+ --+ -- ** With "zip" routing+ , parZ+ , pSwitchZ+ , dpSwitchZ+ , rpSwitchZ+ , drpSwitchZ++ -- ** With replication+ , parC+ )+ where++-- External imports+import Control.Arrow (arr, first)++-- Internal imports+import FRP.Yampa.Basic (constant, (>=-))+import FRP.Yampa.Diagnostics (usrErr)+import FRP.Yampa.Event (Event (..), noEventSnd)+import FRP.Yampa.InternalCore (DTime, FunDesc (..), SF (..), SF' (..), fdFun,+ sfArrG, sfConst, sfTF')++-- * Basic switches++-- | 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+ where+ tf dt a =+ case (sfTF' sf1) dt a of+ (sf1', (b, NoEvent)) -> (switchAux sf1' k, b)+ (_, (_, Event c)) -> sfTF (k c) a++ -- Note: While switch behaves as a stateless arrow at this point, that+ -- could change after a switch. Hence, SF' overall.+ switchAuxA1 :: (a -> (b, Event c)) -> (c -> SF a b) -> SF' a b+ switchAuxA1 f1 k = sf+ where+ sf = SF' tf -- False+ tf _ a =+ case f1 a of+ (b, NoEvent) -> (sf, b)+ (_, Event c) -> sfTF (k c) a++-- | Switch with delayed observation.+--+-- 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!+dSwitch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b+dSwitch (SF {sfTF = tf10}) k = SF {sfTF = tf0}+ where+ tf0 a0 = ( case ec0 of+ NoEvent -> dSwitchAux sf1 k+ Event c0 -> fst (sfTF (k c0) a0)+ , b0+ )+ where+ (sf1, (b0, ec0)) = tf10 a0++ -- It would be nice to optimize further here. E.g. if it would be+ -- possible to observe the event source only.+ dSwitchAux :: SF' a (b, Event c) -> (c -> SF a b) -> SF' a b+ dSwitchAux (SFArr _ (FDC (b, NoEvent))) _ = sfConst b+ dSwitchAux (SFArr _ fd1) k = dSwitchAuxA1 (fdFun fd1) k+ dSwitchAux sf1 k = SF' tf+ where+ tf dt a = ( case ec of+ NoEvent -> dSwitchAux sf1' k+ Event c -> fst (sfTF (k c) a)+ , b+ )+ where+ (sf1', (b, ec)) = (sfTF' sf1) dt a++ -- 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 = ( case ec of+ NoEvent -> sf+ Event c -> fst (sfTF (k c) a)+ , b+ )+ where+ (b, ec) = f1 a++-- | Recurring switch.+--+-- Uses the given SF until an event comes in the input, in which case the SF in+-- the event is turned on, until the next event comes in the input, and so on.+--+-- See <https://wiki.haskell.org/Yampa#Switches> for more information on how+-- this switch works.+rSwitch :: SF a b -> SF (a, Event (SF a b)) b+rSwitch sf = switch (first sf) ((noEventSnd >=-) . rSwitch)++-- | Recurring switch with delayed observation.+--+-- Uses the given SF until an event comes in the input, in which case the SF in+-- the event is turned on, until the next event comes in the input, and so on.+--+-- Uses decoupled switch ('dSwitch').+--+-- See <https://wiki.haskell.org/Yampa#Switches> 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)++-- | Call-with-current-continuation switch.+--+-- Applies the first SF until the input signal and the output signal, when+-- passed to the second SF, produce an event, in which case the original SF and+-- the event are used to build an new SF to switch into.+--+-- See <https://wiki.haskell.org/Yampa#Switches> for more information on how+-- this switch works.+kSwitch :: SF a b -> SF (a, b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b+kSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0}+ where+ tf0 a0 = case tfe0 (a0, b0) of+ (sfe, NoEvent) -> (kSwitchAux sf1 sfe, b0)+ (_, Event c0) -> sfTF (k sf10 c0) a0+ where+ (sf1, b0) = tf10 a0++ -- This is as best as we can align this function. Any other attempts at+ -- aligning the arguments of the equal signs result in a more awkward style.+ kSwitchAux (SFArr _ (FDC b)) sfe = kSwitchAuxC1 b sfe+ kSwitchAux (SFArr _ fd1) sfe = kSwitchAuxA1 (fdFun fd1) sfe+ kSwitchAux sf1 (SFArr _ (FDC NoEvent)) = sf1+ kSwitchAux sf1 (SFArr _ fde) = kSwitchAuxAE sf1 (fdFun fde)+ kSwitchAux sf1 sfe = SF' tf -- False+ where+ tf dt a = case (sfTF' sfe) dt (a, b) of+ (sfe', NoEvent) -> (kSwitchAux sf1' sfe', b)+ (_, Event c) -> sfTF (k (freeze sf1 dt) c) a+ where+ (sf1', b) = (sfTF' sf1) dt a++ -- !!! Untested optimization!+ kSwitchAuxC1 b (SFArr _ (FDC NoEvent)) = sfConst b+ kSwitchAuxC1 b (SFArr _ fde) = kSwitchAuxC1AE b (fdFun fde)+ kSwitchAuxC1 b sfe = SF' tf -- False+ where+ tf dt a =+ case (sfTF' sfe) dt (a, b) of+ (sfe', NoEvent) -> (kSwitchAuxC1 b sfe', b)+ (_, Event c) -> sfTF (k (constant b) c) a++ -- !!! Untested optimization!+ kSwitchAuxA1 f1 (SFArr _ (FDC NoEvent)) = sfArrG f1+ kSwitchAuxA1 f1 (SFArr _ fde) = kSwitchAuxA1AE f1 (fdFun fde)+ kSwitchAuxA1 f1 sfe = SF' tf -- False+ where+ tf dt a = case (sfTF' sfe) dt (a, b) of+ (sfe', NoEvent) -> (kSwitchAuxA1 f1 sfe', b)+ (_, Event c) -> sfTF (k (arr f1) c) a+ where+ b = f1 a++ -- !!! Untested optimization!+ kSwitchAuxAE (SFArr _ (FDC b)) fe = kSwitchAuxC1AE b fe+ kSwitchAuxAE (SFArr _ fd1) fe = kSwitchAuxA1AE (fdFun fd1) fe+ kSwitchAuxAE sf1 fe = SF' tf -- False+ where+ tf dt a = case fe (a, b) of+ NoEvent -> (kSwitchAuxAE sf1' fe, b)+ Event c -> sfTF (k (freeze sf1 dt) c) a+ where+ (sf1', b) = (sfTF' sf1) dt 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 = case fe (a, b) of+ NoEvent -> (kSwitchAuxA1AE f1 fe, b)+ Event c -> sfTF (k (arr f1) c) a+ where+ b = f1 a++-- | 'kSwitch' with delayed observation.+--+-- Applies the first SF until the input signal and the output signal, when+-- passed to the second SF, produce an event, in which case the original SF and+-- the event are used to build an new SF to switch into.+--+-- The switch is decoupled ('dSwitch').+--+-- See <https://wiki.haskell.org/Yampa#Switches> for more information on how+-- this switch works.+dkSwitch :: SF a b -> SF (a, b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b+dkSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0}+ where+ tf0 a0 = ( case tfe0 (a0, b0) of+ (sfe, NoEvent) -> dkSwitchAux sf1 sfe+ (_, Event c0) -> fst (sfTF (k sf10 c0) a0)+ , b0+ )+ where+ (sf1, b0) = tf10 a0++ dkSwitchAux sf1 (SFArr _ (FDC NoEvent)) = sf1+ dkSwitchAux sf1 sfe = SF' tf -- False+ where+ tf dt a = ( case (sfTF' sfe) dt (a, b) of+ (sfe', NoEvent) -> dkSwitchAux sf1' sfe'+ (_, Event c) -> fst (sfTF (k (freeze sf1 dt) c) a)+ , b+ )+ where+ (sf1', b) = (sfTF' sf1) dt a++-- * Parallel composition and switching over collections with broadcasting++-- | Tuple a value up with every element of a collection of signal functions.+broadcast :: Functor col => a -> col sf -> col (a, sf)+broadcast a = fmap (\sf -> (a, sf))++-- | Spatial parallel composition of a signal function collection. Given a+-- collection of signal functions, it returns a signal function that broadcasts+-- its input signal to every element of the collection, to return a signal+-- carrying a collection of outputs. See 'par'.+--+-- For more information on how parallel composition works, check+-- <https://www.antonycourtney.com/pubs/hw03.pdf>+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) with broadcasting. See 'pSwitch'.+--+-- For more information on how parallel composition works, check+-- <https://www.antonycourtney.com/pubs/hw03.pdf>+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++-- | Decoupled parallel switch with broadcasting (dynamic collection of signal+-- functions spatially composed in parallel). See 'dpSwitch'.+--+-- For more information on how parallel composition works, check+-- <https://www.antonycourtney.com/pubs/hw03.pdf>+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++-- | Recurring parallel switch with broadcasting.+--+-- Uses the given collection of SFs, until an event comes in the input, in which+-- case the function in the 'Event' is used to transform the collections of SF+-- to be used with 'rpSwitch' again, until the next event comes in the input,+-- and so on.+--+-- Broadcasting is used to decide which subpart of the input goes to each SF in+-- the collection.+--+-- See 'rpSwitch'.+--+-- For more information on how parallel composition works, check+-- <https://www.antonycourtney.com/pubs/hw03.pdf>+rpSwitchB :: Functor col+ => col (SF a b)+ -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b)+rpSwitchB = rpSwitch broadcast++-- | Decoupled recurring parallel switch with broadcasting.+--+-- Uses the given collection of SFs, until an event comes in the input, in which+-- case the function in the 'Event' is used to transform the collections of SF+-- to be used with 'rpSwitch' again, until the next event comes in the input,+-- and so on.+--+-- Broadcasting is used to decide which subpart of the input goes to each SF in+-- the collection.+--+-- This is the decoupled version of 'rpSwitchB'.+--+-- For more information on how parallel composition works, check+-- <https://www.antonycourtney.com/pubs/hw03.pdf>+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 = (parAux rf sfs, cs0)+ where+ bsfs0 = rf a0 sfs0+ sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0+ sfs = fmap fst sfcs0+ cs0 = fmap snd sfcs0++-- Internal definition. Also used in parallel switchers.+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 = (parAux rf sfs', cs)+ where+ bsfs = rf a sfs+ sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs+ sfs' = fmap fst sfcs'+ cs = fmap snd sfcs'++-- | 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.+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 = case (sfTF sfe0) (a0, cs0) of+ (sfe, NoEvent) -> (pSwitchAux sfs sfe, cs0)+ (_, Event d0) -> sfTF (k sfs0 d0) a0+ where+ bsfs0 = rf a0 sfs0+ sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0+ sfs = fmap fst sfcs0+ cs0 = fmap snd sfcs0++ pSwitchAux sfs (SFArr _ (FDC NoEvent)) = parAux rf sfs+ pSwitchAux sfs sfe = SF' tf -- False+ where+ tf dt a = case (sfTF' sfe) dt (a, cs) of+ (sfe', NoEvent) -> (pSwitchAux sfs' sfe', cs)+ (_, Event d) -> sfTF (k (freezeCol sfs dt) d) a+ where+ bsfs = rf a sfs+ sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs+ sfs' = fmap fst sfcs'+ cs = fmap snd sfcs'++-- | 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.+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 = ( case (sfTF sfe0) (a0, cs0) of+ (sfe, NoEvent) -> dpSwitchAux (fmap fst sfcs0) sfe+ (_, Event d0) -> fst (sfTF (k sfs0 d0) a0)+ , cs0+ )+ where+ bsfs0 = rf a0 sfs0+ sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0+ cs0 = fmap snd sfcs0++ dpSwitchAux sfs (SFArr _ (FDC NoEvent)) = parAux rf sfs+ dpSwitchAux sfs sfe = SF' tf -- False+ where+ tf dt a = ( case (sfTF' sfe) dt (a, cs) of+ (sfe', NoEvent) -> dpSwitchAux (fmap fst sfcs') sfe'+ (_, Event d) -> fst (sfTF (k (freezeCol sfs dt) d) a)+ , cs+ )+ where+ bsfs = rf a sfs+ sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs+ cs = fmap snd sfcs'++-- | Recurring parallel switch parameterized on the routing function.+--+-- Uses the given collection of SFs, until an event comes in the input, in which+-- case the function in the 'Event' is used to transform the collections of SF+-- to be used with 'rpSwitch' again, until the next event comes in the input,+-- and so on.+--+-- The routing function is used to decide which subpart of the input goes to+-- each SF in the collection.+--+-- This is the parallel version of 'rSwitch'.+rpSwitch :: 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)+ -- ^ Initial signal function collection.+ -> SF (a, Event (col (SF b c) -> col (SF b c))) (col c)+rpSwitch rf sfs =+ pSwitch (rf . fst) sfs (arr (snd . fst)) $ \sfs' f ->+ noEventSnd >=- rpSwitch rf (f sfs')++-- | Recurring parallel switch with delayed observation parameterized on the+-- routing function.+--+-- Uses the given collection of SFs, until an event comes in the input, in which+-- case the function in the 'Event' is used to transform the collections of SF+-- to be used with 'rpSwitch' again, until the next event comes in the input,+-- and so on.+--+-- The routing function is used to decide which subpart of the input goes to+-- each SF in the collection.+--+-- This is the parallel version of 'drSwitch'.+drpSwitch :: 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)+ -- ^ Initial signal function collection.+ -> SF (a, Event (col (SF b c) -> col (SF b c))) (col c)+drpSwitch rf sfs =+ dpSwitch (rf . fst) sfs (arr (snd . fst)) $ \sfs' f ->+ noEventSnd >=- drpSwitch rf (f sfs')++-- * Parallel composition/switchers with "zip" routing++-- | Parallel composition of a list of SFs.+--+-- Given a list of SFs, returns an SF that takes a list of inputs, applies each+-- SF to each input in order, and returns the SFs' outputs.+--+-- >>> embed (parZ [arr (+1), arr (+2)]) (deltaEncode 0.1 [[0, 0], [1, 1]])+-- [[1,2],[2,3]]+--+-- If there are more SFs than inputs, an exception is thrown.+--+-- >>> embed (parZ [arr (+1), arr (+1), arr (+2)]) (deltaEncode 0.1 [[0, 0], [1, 1]])+-- [[1,1,*** Exception: FRP.Yampa.Switches.parZ: Input list too short.+--+-- If there are more inputs than SFs, the unused inputs are ignored.+--+-- >>> embed (parZ [arr (+1)]) (deltaEncode 0.1 [[0, 0], [1, 1]])+-- [[1],[2]]+parZ :: [SF a b] -> SF [a] [b]+parZ = par (safeZip "parZ")++-- | Parallel switch (dynamic collection of signal functions spatially composed+-- in parallel). See 'pSwitch'.+--+-- For more information on how parallel composition works, check+-- <https://www.antonycourtney.com/pubs/hw03.pdf>+pSwitchZ :: [SF a b]+ -> SF ([a], [b]) (Event c)+ -> ([SF a b] -> c -> SF [a] [b])+ -> SF [a] [b]+pSwitchZ = pSwitch (safeZip "pSwitchZ")++-- | Decoupled parallel switch with broadcasting (dynamic collection of signal+-- functions spatially composed in parallel). See 'dpSwitch'.+--+-- For more information on how parallel composition works, check+-- <https://www.antonycourtney.com/pubs/hw03.pdf>+dpSwitchZ :: [SF a b]+ -> SF ([a], [b]) (Event c)+ -> ([SF a b] -> c -> SF [a] [b])+ -> SF [a] [b]+dpSwitchZ = dpSwitch (safeZip "dpSwitchZ")++-- | Recurring parallel switch with "zip" routing.+--+-- Uses the given list of SFs, until an event comes in the input, in which case+-- the function in the 'Event' is used to transform the list of SF to be used+-- with 'rpSwitchZ' again, until the next event comes in the input, and so on.+--+-- Zip routing is used to decide which subpart of the input goes to each SF in+-- the list.+--+-- See 'rpSwitch'.+--+-- For more information on how parallel composition works, check+-- <https://www.antonycourtney.com/pubs/hw03.pdf>+rpSwitchZ :: [SF a b] -> SF ([a], Event ([SF a b] -> [SF a b])) [b]+rpSwitchZ = rpSwitch (safeZip "rpSwitchZ")++-- | Decoupled recurring parallel switch with "zip" routing.+--+-- Uses the given list of SFs, until an event comes in the input, in which case+-- the function in the 'Event' is used to transform the list of SF to be used+-- with 'rpSwitchZ' again, until the next event comes in the input, and so on.+--+-- Zip routing is used to decide which subpart of the input goes to each SF in+-- the list.+--+-- See 'rpSwitchZ' and 'drpSwitch'.+--+-- For more information on how parallel composition works, check+-- <https://www.antonycourtney.com/pubs/hw03.pdf>+drpSwitchZ :: [SF a b] -> SF ([a], Event ([SF a b] -> [SF a b])) [b]+drpSwitchZ = drpSwitch (safeZip "drpSwitchZ")++-- | Zip two lists.+--+-- PRE: The first list is not shorter than the second.+safeZip :: String -> [a] -> [b] -> [(a, b)]+safeZip fn = safeZip'+ where+ safeZip' :: [a] -> [b] -> [(a, b)]+ safeZip' _ [] = []+ safeZip' (a:as) (b:bs) = (a, b) : safeZip' as bs+ safeZip' _ _ =+ 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++-- | Apply an SF to every element of a list.+--+-- Example:+--+-- >>> embed (parC integral) (deltaEncode 0.1 [[1, 2], [2, 4], [3, 6], [4.0, 8.0 :: Float]])+-- [[0.0,0.0],[0.1,0.2],[0.3,0.6],[0.6,1.2]]+--+-- The number of SFs or expected inputs is determined by the first input list,+-- and not expected to vary over time.+--+-- If more inputs come in a subsequent list, they are ignored.+--+-- >>> embed (parC (arr (+1))) (deltaEncode 0.1 [[0], [1, 1], [3, 4], [6, 7, 8], [1, 1], [0, 0], [1, 9, 8]])+-- [[1],[2],[4],[7],[2],[1],[2]]+--+-- If less inputs come in a subsequent list, an exception is thrown.+--+-- >>> embed (parC (arr (+1))) (deltaEncode 0.1 [[0, 0], [1, 1], [3, 4], [6, 7, 8], [1, 1], [0, 0], [1, 9, 8]])+-- [[1,1],[2,2],[4,5],[7,8],[2,2],[1,1],[2,10]]+parC :: SF a b -> SF [a] [b]+parC sf = SF $ \as -> let os = map (sfTF sf) as+ bs = map snd os+ sfs = map fst os+ in (parCAux sfs, bs)++-- Internal definition. Also used in parallel switchers.+parCAux :: [SF' a b] -> SF' [a] [b]+parCAux sfs = SF' tf+ where+ tf dt as = (listSeq sfcs `seq` parCAux sfcs, listSeq bs)+ where+ os = map (\(a, sf) -> sfTF' sf dt a) $ safeZip "parC" as sfs+ bs = map snd os+ sfcs = map fst os++listSeq :: [a] -> [a]+listSeq x = x `seq` (listSeq' x)++listSeq' :: [a] -> [a]+listSeq' [] = []+listSeq' rs@(a:as) = a `seq` listSeq' as `seq` rs
src/FRP/Yampa/Task.hs view
@@ -1,232 +1,186 @@-{-# LANGUAGE CPP, Rank2Types #-}------------------------------------------------------------------------------------------+{-# LANGUAGE CPP #-}+{-# LANGUAGE Rank2Types #-} -- |--- Module : FRP.Yampa.Task--- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003--- License : BSD-style (see the LICENSE file in the distribution)+-- Module : FRP.Yampa.Task+-- Copyright : (c) Ivan Perez, 2014-2022+-- (c) George Giorgidze, 2007-2012+-- (c) Henrik Nilsson, 2005-2006+-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004+-- License : BSD-style (see the LICENSE file in the distribution) ----- Maintainer : nilsson@cs.yale.edu--- Stability : provisional--- Portability : non-portable (GHC extensions)+-- Maintainer : ivan.perez@keera.co.uk+-- Stability : provisional+-- Portability : non-portable (GHC extensions) -- -- Task abstraction on top of signal transformers.---------------------------------------------------------------------------------------------+module FRP.Yampa.Task+ (+ -- * The Task type+ Task+ , mkTask+ , runTask+ , runTask_+ , taskToSF -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+ -- * Basic tasks+ , constT+ , sleepT+ , snapT -import Control.Monad (when, forM_)+ -- * Basic tasks combinators+ , timeOut+ , abortWhen+ )+ where++-- External imports #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`+-- Internal imports+import FRP.Yampa.Basic (constant)+import FRP.Yampa.Diagnostics (intErr, usrErr)+import FRP.Yampa.Event (Event, lMerge)+import FRP.Yampa.EventS (after, edgeBy, never, snap)+import FRP.Yampa.InternalCore (SF, Time, arr, first, (&&&), (>>>))+import FRP.Yampa.Switches (switch) +infixl 0 `timeOut`, `abortWhen` ---------------------------------------------------------------------------------- The Task type-------------------------------------------------------------------------------+-- * 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.+-- | A task is a partially SF that may terminate with a result. newtype Task a b c =- Task (forall d . (c -> SF a (Either b d)) -> SF a (Either b d))-+ -- CPS-based representation allowing termination to be detected. Note the+ -- rank 2 polymorphic type! The representation can be changed if necessary,+ -- but the Monad laws follow trivially in this case.+ Task (forall d . (c -> SF a (Either b d)) -> SF a (Either b d)) unTask :: Task a b c -> ((c -> SF a (Either b d)) -> SF a (Either b d)) unTask (Task f) = f -+-- | Creates a 'Task' from an SF that returns, as a second output, an 'Event'+-- when the SF terminates. See 'switch'. mkTask :: SF a (b, Event c) -> Task a b c mkTask st = Task (switch (st >>> first (arr Left))) +-- | Runs a task.+--+-- The output from the resulting signal transformer is tagged with Left while+-- 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. --- "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.+-- Check name. 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.+-- | Runs a task that never terminates.+--+-- The output becomes undefined once the underlying task has terminated.+--+-- Convenience function 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_"+ >>> arr (either id (usrErr "YampaTask" "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.)+-- | Creates an SF that represents an SF and produces an event when the task+-- terminates, and otherwise produces just an output. taskToSF :: Task a b c -> SF a (b, Event c) taskToSF tk = runTask tk- >>> (arr (either id (usrErr "AFRPTask" "runTask_"+ >>> (arr (either id (usrErr "YampaTask" "runTask_" "Task terminated!")) &&& edgeBy isEdge (Left undefined))- where- isEdge (Left _) (Left _) = Nothing- isEdge (Left _) (Right c) = Just c- isEdge (Right _) (Right _) = Nothing- isEdge (Right _) (Left _) = Nothing-+ where+ isEdge (Left _) (Right c) = Just c+ isEdge _ _ = Nothing ---------------------------------------------------------------------------------- Functor, Applicative and Monad instance-------------------------------------------------------------------------------+-- * Functor, Applicative and Monad instance instance Functor (Task a b) where- fmap f tk = Task (\k -> unTask tk (k . f))+ fmap f tk = Task (\k -> unTask tk (k . f)) instance Applicative (Task a b) where- pure x = Task (\k -> k x)- f <*> v = Task (\k -> (unTask f) (\c -> unTask v (k . c)))+ pure x = Task (\k -> k x)+ f <*> v = Task (\k -> (unTask f) (\c -> unTask v (k . c))) instance Monad (Task a b) where- tk >>= f = Task (\k -> unTask tk (\c -> unTask (f c) k))- return x = Task (\k -> k x)--{--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).--}+ tk >>= f = Task (\k -> unTask tk (\c -> unTask (f c) k))+ return = pure +-- 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-------------------------------------------------------------------------------+-- * Basic tasks --- Non-terminating task with constant output b.+-- | 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.+-- | "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:+-- | Takes a "snapshot" of the input and terminates immediately with the input+-- value as the result. ----- snapT >> snapT = snapT+-- No time passes; therefore, the following must hold: --+-- @snapT >> snapT = snapT@ snapT :: Task a b a-snapT = mkTask (constant (intErr "AFRPTask" "snapT" "Bad switch?") &&& snap)-+snapT = mkTask (constant (intErr "YampaTask" "snapT" "Bad switch?") &&& snap) ---------------------------------------------------------------------------------- Basic tasks combinators-------------------------------------------------------------------------------+-- * Basic tasks combinators --- Impose a time out on a task.+-- | Impose a time out on a task. timeOut :: Task a b c -> Time -> Task a b (Maybe c) tk `timeOut` t = mkTask ((taskToSF tk &&& after t ()) >>> arr aux)- where- aux ((b, ec), et) = (b, (lMerge (fmap Just ec)- (fmap (const Nothing) et)))+ where+ aux ((b, ec), et) = (b, lMerge (fmap Just ec) (fmap (const Nothing) et)) --- Run a "guarding" event source (SF a (Event b)) in parallel with a--- (possibly non-terminating) task. 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+-- | 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, without 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???+ where+ aux ((b, ec), ed) = (b, lMerge (fmap Left ec) (fmap Right ed))
src/FRP/Yampa/Time.hs view
@@ -1,25 +1,41 @@------------------------------------------------------------------------------------------ -- |--- Module : FRP.Yampa.Time--- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003--- License : BSD-style (see the LICENSE file in the distribution)+-- Module : FRP.Yampa.Time+-- Copyright : (c) Ivan Perez, 2014-2022+-- (c) George Giorgidze, 2007-2012+-- (c) Henrik Nilsson, 2005-2006+-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004+-- License : BSD-style (see the LICENSE file in the distribution) ----- Maintainer : ivan.perez@keera.co.uk--- Stability : provisional--- Portability : non-portable (GHC extensions)+-- 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+-- SF primitives that producing the current running time.+--+-- Time is global for an 'SF', so, every constituent 'SF' will use the same+-- global clock. However, when used in combination with+-- 'FRP.Yampa.Switches.switch'ing, the SF switched into will be started at the+-- time of switching, so any reference to 'localTime' or 'time' from that 'SF'+-- will count using the time of switching as the start time.+--+-- Take also into account that, because 'FRP.Yampa.Integration.derivative' is+-- the derivative of a signal /over time/, differentiating 'localTime' will+-- always produce the value one (@1@). If you really, really, really need to+-- know the time delta, and need to abandon the hybrid\/FRP abstraction, see+-- 'FRP.Yampa.Integration.iterFrom'.+module FRP.Yampa.Time+ ( localTime+ , time+ )+ where -import Control.Arrow+-- External imports+import Control.Arrow ((>>>)) +-- Internal imports+import FRP.Yampa.Basic (constant)+import FRP.Yampa.Integration (integral) 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@@ -28,6 +44,3 @@ -- | Alternative name for localTime. time :: SF a Time time = localTime---- Vim modeline--- vim:set tabstop=8 expandtab:
− src/FRP/Yampa/Utilities.hs
@@ -1,61 +0,0 @@--------------------------------------------------------------------------------------------- |--- Module : FRP.Yampa.Utilities--- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : nilsson@cs.yale.edu--- Stability : provisional--- Portability : portable------ Derived utility definitions.------ ToDo:------ * Possibly add--- impulse :: VectorSpace a k => a -> Event a--- But to do that, we need access to Event, which we currently do not have.------ * The general arrow utilities should be moved to a module--- FRP.Yampa.Utilities.------ * I'm not sure structuring the Yampa \"core\" according to what is--- core functionality and what's not is all that useful. There are--- many cases where we want to implement combinators that fairly--- easily could be implemented in terms of others as primitives simply--- because we expect that that implementation is going to be much more--- efficient, and that the combinators are used sufficiently often to--- warrant doing this. E.g. 'switch' should be a primitive, even though--- it could be derived from 'pSwitch'.------ * Reconsider 'recur'. If an event source has an immediate occurrence,--- we'll get into a loop. For example: recur now. Maybe suppress--- initial occurrences? Initial occurrences are rather pointless in this--- case anyway.--------------------------------------------------------------------------------------------module FRP.Yampa.Utilities (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
− src/FRP/Yampa/Vector2.hs
@@ -1,105 +0,0 @@-{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, FlexibleInstances, StandaloneDeriving #-}--------------------------------------------------------------------------------------------- |--- Module : FRP.Yampa.Vector2--- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : nilsson@cs.yale.edu--- Stability : provisional--- Portability : non-portable (GHC extensions)------ 2D vector abstraction (R^2).-----------------------------------------------------------------------------------------------module FRP.Yampa.Vector2 (- Vector2, -- Abstract, instance of VectorSpace- vector2, -- :: RealFloat a => a -> a -> Vector2 a- vector2X, -- :: RealFloat a => Vector2 a -> a- vector2Y, -- :: RealFloat a => Vector2 a -> a- vector2XY, -- :: RealFloat a => Vector2 a -> (a, a)- vector2Polar, -- :: RealFloat a => a -> a -> Vector2 a- vector2Rho, -- :: RealFloat a => Vector2 a -> a- vector2Theta, -- :: RealFloat a => Vector2 a -> a- vector2RhoTheta, -- :: RealFloat a => Vector2 a -> (a, a)- vector2Rotate -- :: RealFloat a => a -> Vector2 a -> Vector2 a-) where--import FRP.Yampa.VectorSpace-import FRP.Yampa.Forceable------------------------------------------------------------------------------------ 2D vector, constructors and selectors.----------------------------------------------------------------------------------- Restrict coefficient space to RealFloat (rather than Floating) for now.--- While unclear if a complex coefficient space would be useful (and if the--- result really would be a 2d vector), the only thing causing trouble is the--- use of atan2 in vector2Theta. Maybe atan2 can be generalized?--data Vector2 a = RealFloat a => Vector2 !a !a--deriving instance Eq a => Eq (Vector2 a)--deriving instance Show a => Show (Vector2 a)--vector2 :: RealFloat a => a -> a -> Vector2 a-vector2 = Vector2--vector2X :: RealFloat a => Vector2 a -> a-vector2X (Vector2 x _) = x--vector2Y :: RealFloat a => Vector2 a -> a-vector2Y (Vector2 _ y) = y--vector2XY :: RealFloat a => Vector2 a -> (a, a)-vector2XY (Vector2 x y) = (x, y)--vector2Polar :: RealFloat a => a -> a -> Vector2 a-vector2Polar rho theta = Vector2 (rho * cos theta) (rho * sin theta)--vector2Rho :: RealFloat a => Vector2 a -> a-vector2Rho (Vector2 x y) = sqrt (x * x + y * y)--vector2Theta :: RealFloat a => Vector2 a -> a-vector2Theta (Vector2 x y) = atan2 y x--vector2RhoTheta :: RealFloat a => Vector2 a -> (a, a)-vector2RhoTheta v = (vector2Rho v, vector2Theta v)----------------------------------------------------------------------------------- Vector space instance---------------------------------------------------------------------------------instance RealFloat a => VectorSpace (Vector2 a) a where- zeroVector = Vector2 0 0-- a *^ (Vector2 x y) = Vector2 (a * x) (a * y)-- (Vector2 x y) ^/ a = Vector2 (x / a) (y / a)-- negateVector (Vector2 x y) = (Vector2 (-x) (-y))-- (Vector2 x1 y1) ^+^ (Vector2 x2 y2) = Vector2 (x1 + x2) (y1 + y2)-- (Vector2 x1 y1) ^-^ (Vector2 x2 y2) = Vector2 (x1 - x2) (y1 - y2)-- (Vector2 x1 y1) `dot` (Vector2 x2 y2) = x1 * x2 + y1 * y2------------------------------------------------------------------------------------ Additional operations---------------------------------------------------------------------------------vector2Rotate :: RealFloat a => a -> Vector2 a -> Vector2 a-vector2Rotate theta' v = vector2Polar (vector2Rho v) (vector2Theta v + theta')------------------------------------------------------------------------------------ Forceable instance---------------------------------------------------------------------------------instance RealFloat a => Forceable (Vector2 a) where- force = id
− src/FRP/Yampa/Vector3.hs
@@ -1,123 +0,0 @@-{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, FlexibleInstances, StandaloneDeriving #-}--------------------------------------------------------------------------------------------- |--- Module : FRP.Yampa.Vector3--- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : nilsson@cs.yale.edu--- Stability : provisional--- Portability : non-portable (GHC extensions)------ 3D vector abstraction (R^3).-----------------------------------------------------------------------------------------------module FRP.Yampa.Vector3 (- Vector3, -- Abstract, instance of VectorSpace- vector3, -- :: RealFloat a => a -> a -> a -> Vector3 a- vector3X, -- :: RealFloat a => Vector3 a -> a- vector3Y, -- :: RealFloat a => Vector3 a -> a- vector3Z, -- :: RealFloat a => Vector3 a -> a- vector3XYZ, -- :: RealFloat a => Vector3 a -> (a, a, a)- vector3Spherical, -- :: RealFloat a => a -> a -> a -> Vector3 a- vector3Rho, -- :: RealFloat a => Vector3 a -> a- vector3Theta, -- :: RealFloat a => Vector3 a -> a- vector3Phi, -- :: RealFloat a => Vector3 a -> a- vector3RhoThetaPhi, -- :: RealFloat a => Vector3 a -> (a, a, a)- vector3Rotate -- :: RealFloat a => a -> a -> Vector3 a -> Vector3 a-) where--import FRP.Yampa.VectorSpace-import FRP.Yampa.Forceable----------------------------------------------------------------------------------- 3D vector, constructors and selectors.----------------------------------------------------------------------------------- Restrict coefficient space to RealFloat (rather than Floating) for now.--- While unclear if a complex coefficient space would be useful (and if the--- result really would be a 3d vector), the only thing causing trouble is the--- use of atan2 in vector3Theta and vector3Phi. Maybe atan2 can be generalized?--data Vector3 a = RealFloat a => Vector3 !a !a !a--deriving instance Eq a => Eq (Vector3 a)--deriving instance Show a => Show (Vector3 a)--vector3 :: RealFloat a => a -> a -> a -> Vector3 a-vector3 = Vector3--vector3X :: RealFloat a => Vector3 a -> a-vector3X (Vector3 x _ _) = x--vector3Y :: RealFloat a => Vector3 a -> a-vector3Y (Vector3 _ y _) = y--vector3Z :: RealFloat a => Vector3 a -> a-vector3Z (Vector3 _ _ z) = z--vector3XYZ :: RealFloat a => Vector3 a -> (a, a, a)-vector3XYZ (Vector3 x y z) = (x, y, z)--vector3Spherical :: RealFloat a => a -> a -> a -> Vector3 a-vector3Spherical rho theta phi =- Vector3 (rhoSinPhi * cos theta) (rhoSinPhi * sin theta) (rho * cos phi)- where- rhoSinPhi = rho * sin phi--vector3Rho :: RealFloat a => Vector3 a -> a-vector3Rho (Vector3 x y z) = sqrt (x * x + y * y + z * z)--vector3Theta :: RealFloat a => Vector3 a -> a-vector3Theta (Vector3 x y _) = atan2 y x--vector3Phi :: RealFloat a => Vector3 a -> a-vector3Phi v@(Vector3 _ _ z) = acos (z / vector3Rho v)--vector3RhoThetaPhi :: RealFloat a => Vector3 a -> (a, a, a)-vector3RhoThetaPhi (Vector3 x y z) = (rho, theta, phi)- where- rho = sqrt (x * x + y * y + z * z)- theta = atan2 y x- phi = acos (z / rho)------------------------------------------------------------------------------------ Vector space instance---------------------------------------------------------------------------------instance RealFloat a => VectorSpace (Vector3 a) a where- zeroVector = Vector3 0 0 0-- a *^ (Vector3 x y z) = Vector3 (a * x) (a * y) (a * z)-- (Vector3 x y z) ^/ a = Vector3 (x / a) (y / a) (z / a)-- negateVector (Vector3 x y z) = (Vector3 (-x) (-y) (-z))-- (Vector3 x1 y1 z1) ^+^ (Vector3 x2 y2 z2) = Vector3 (x1+x2) (y1+y2) (z1+z2)-- (Vector3 x1 y1 z1) ^-^ (Vector3 x2 y2 z2) = Vector3 (x1-x2) (y1-y2) (z1-z2)-- (Vector3 x1 y1 z1) `dot` (Vector3 x2 y2 z2) = x1 * x2 + y1 * y2 + z1 * z2------------------------------------------------------------------------------------ Additional operations---------------------------------------------------------------------------------vector3Rotate :: RealFloat a => a -> a -> Vector3 a -> Vector3 a-vector3Rotate theta' phi' v =- vector3Spherical (vector3Rho v)- (vector3Theta v + theta')- (vector3Phi v + phi')------------------------------------------------------------------------------------ Forceable instance---------------------------------------------------------------------------------instance RealFloat a => Forceable (Vector3 a) where- force = id
− src/FRP/Yampa/VectorSpace.hs
@@ -1,156 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}--------------------------------------------------------------------------------------------- |--- Module : FRP.Yampa.VectorSpace--- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003--- License : BSD-style (see the LICENSE file in the distribution)------ Maintainer : nilsson@cs.yale.edu--- Stability : provisional--- Portability : non-portable (GHC extensions)------ Vector space type relation and basic instances.-----------------------------------------------------------------------------------------------module FRP.Yampa.VectorSpace where----------------------------------------------------------------------------------- Vector space type relation---------------------------------------------------------------------------------infixr *^-infixl ^/-infix 7 `dot`-infixl 6 ^+^, ^-^---- Maybe norm and normalize should not be class methods, in which case--- the constraint on the coefficient space (a) should (or, at least, could)--- be Fractional (roughly a Field) rather than Floating.---- Minimal instance: zeroVector, (*^), (^+^), dot-class (Eq a, Floating a) => VectorSpace v a | v -> a where- zeroVector :: v- (*^) :: a -> v -> v- (^/) :: v -> a -> v- negateVector :: v -> v- (^+^) :: v -> v -> v- (^-^) :: v -> v -> v- dot :: v -> v -> a- norm :: v -> a- normalize :: v -> v-- v ^/ a = (1/a) *^ v-- negateVector v = (-1) *^ v-- v1 ^-^ v2 = v1 ^+^ negateVector v2-- norm v = sqrt (v `dot` v)-- normalize v = if nv /= 0 then v ^/ nv else error "normalize: zero vector"- where nv = norm v----------------------------------------------------------------------------------- Vector space instances for Float and Double---------------------------------------------------------------------------------instance VectorSpace Float Float where- zeroVector = 0-- a *^ x = a * x-- x ^/ a = x / a-- negateVector x = (-x)-- x1 ^+^ x2 = x1 + x2-- x1 ^-^ x2 = x1 - x2-- x1 `dot` x2 = x1 * x2---instance VectorSpace Double Double where- zeroVector = 0-- a *^ x = a * x-- x ^/ a = x / a-- negateVector x = (-x)-- x1 ^+^ x2 = x1 + x2-- x1 ^-^ x2 = x1 - x2-- x1 `dot` x2 = x1 * x2------------------------------------------------------------------------------------ Vector space instances for small tuples of Floating---------------------------------------------------------------------------------instance (Eq a, Floating a) => VectorSpace (a,a) a where- zeroVector = (0,0)-- a *^ (x,y) = (a * x, a * y)-- (x,y) ^/ a = (x / a, y / a)-- negateVector (x,y) = (-x, -y)-- (x1,y1) ^+^ (x2,y2) = (x1 + x2, y1 + y2)-- (x1,y1) ^-^ (x2,y2) = (x1 - x2, y1 - y2)-- (x1,y1) `dot` (x2,y2) = x1 * x2 + y1 * y2---instance (Eq a, Floating a) => VectorSpace (a,a,a) a where- zeroVector = (0,0,0)-- a *^ (x,y,z) = (a * x, a * y, a * z)-- (x,y,z) ^/ a = (x / a, y / a, z / a)-- negateVector (x,y,z) = (-x, -y, -z)-- (x1,y1,z1) ^+^ (x2,y2,z2) = (x1+x2, y1+y2, z1+z2)-- (x1,y1,z1) ^-^ (x2,y2,z2) = (x1-x2, y1-y2, z1-z2)-- (x1,y1,z1) `dot` (x2,y2,z2) = x1 * x2 + y1 * y2 + z1 * z2---instance (Eq a, Floating a) => VectorSpace (a,a,a,a) a where- zeroVector = (0,0,0,0)-- a *^ (x,y,z,u) = (a * x, a * y, a * z, a * u)-- (x,y,z,u) ^/ a = (x / a, y / a, z / a, u / a)-- negateVector (x,y,z,u) = (-x, -y, -z, -u)-- (x1,y1,z1,u1) ^+^ (x2,y2,z2,u2) = (x1+x2, y1+y2, z1+z2, u1+u2)-- (x1,y1,z1,u1) ^-^ (x2,y2,z2,u2) = (x1-x2, y1-y2, z1-z2, u1-u2)-- (x1,y1,z1,u1) `dot` (x2,y2,z2,u2) = x1 * x2 + y1 * y2 + z1 * z2 + u1 * u2---instance (Eq a, Floating a) => VectorSpace (a,a,a,a,a) a where- zeroVector = (0,0,0,0,0)-- a *^ (x,y,z,u,v) = (a * x, a * y, a * z, a * u, a * v)-- (x,y,z,u,v) ^/ a = (x / a, y / a, z / a, u / a, v / a)-- negateVector (x,y,z,u,v) = (-x, -y, -z, -u, -v)-- (x1,y1,z1,u1,v1) ^+^ (x2,y2,z2,u2,v2) = (x1+x2, y1+y2, z1+z2, u1+u2, v1+v2)-- (x1,y1,z1,u1,v1) ^-^ (x2,y2,z2,u2,v2) = (x1-x2, y1-y2, z1-z2, u1-u2, v1-v2)-- (x1,y1,z1,u1,v1) `dot` (x2,y2,z2,u2,v2) =- x1 * x2 + y1 * y2 + z1 * z2 + u1 * u2 + v1 * v2
− tests/AFRPTests.hs
@@ -1,191 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 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 Bool-runRegTests = do- putStrLn ""- putStrLn "Running the AFRP regression tests ..."- if allGood- then putStrLn "All tests succeeded!"- else mapM_ putStrLn failedTests- return allGood--runSpaceTests :: IO ()-runSpaceTests = do- putStrLn ""- putStrLn "Running the AFRP space tests ..."- putStrLn "Testing the space behaviour. This may take a LONG time."- putStrLn "Observe the process size using some tool like top."- putStrLn "The process should not grow significantly."- putStrLn "Emitted success/failure indications signify termination"- putStrLn "and whether or not the right result was obtained. They do"- putStrLn "not necessarily indicate that the space behaviour is correct"- putStrLn "(i.e., absence of leaks)."- putStrLn ""- rst "arr" 0 arr_st0 arr_st0r- rst "arr" 1 arr_st1 arr_st1r- rst "loop" 0 loop_st0 loop_st0r- rst "loop" 1 loop_st1 loop_st1r- rst "rswitch" 0 rswitch_st0 rswitch_st0r- rst "pswitch" 0 pswitch_st0 pswitch_st0r- rst "pswitch" 1 pswitch_st1 pswitch_st1r- rst "rpswitch" 0 rpswitch_st0 rpswitch_st0r- rst "accum" 0 accum_st0 accum_st0r- rst "accum" 1 accum_st1 accum_st1r- where- rst n i st str = do- putStrLn ("Running " ++ n ++ "_st" ++ show i ++ " ...")- if st ~= str then- putStrLn "Success!"- else- -- We probably won't get here in case of a (space) failure ...- putStrLn "Failure!"---- AC: here because I had trouble running ghci:--- fixTest :: IO ()--- fixTest =--- let vs = loop_t17--- in putStrLn ("loop_t17 output: " ++ show vs)---
− tests/AFRPTestsAccum.hs
@@ -1,362 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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
− tests/AFRPTestsArr.hs
@@ -1,53 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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
− tests/AFRPTestsBasicSF.hs
@@ -1,70 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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
− tests/AFRPTestsCOC.hs
@@ -1,57 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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
− tests/AFRPTestsCommon.hs
@@ -1,168 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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)
− tests/AFRPTestsComp.hs
@@ -1,72 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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
− tests/AFRPTestsDelay.hs
@@ -1,89 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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
− tests/AFRPTestsDer.hs
@@ -1,56 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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
− tests/AFRPTestsEmbed.hs
@@ -1,62 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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
− tests/AFRPTestsEvSrc.hs
@@ -1,585 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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
− tests/AFRPTestsFirstSecond.hs
@@ -1,128 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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
− tests/AFRPTestsKSwitch.hs
@@ -1,129 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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
− tests/AFRPTestsLaws.hs
@@ -1,90 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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
− tests/AFRPTestsLoop.hs
@@ -1,207 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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
− tests/AFRPTestsLoopIntegral.hs
@@ -1,105 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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
− tests/AFRPTestsLoopLaws.hs
@@ -1,110 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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
− tests/AFRPTestsLoopPre.hs
@@ -1,63 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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
− tests/AFRPTestsPSwitch.hs
@@ -1,326 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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)
− tests/AFRPTestsPre.hs
@@ -1,209 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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
− tests/AFRPTestsRPSwitch.hs
@@ -1,247 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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]
− tests/AFRPTestsRSwitch.hs
@@ -1,145 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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
− tests/AFRPTestsReact.hs
@@ -1,71 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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
− tests/AFRPTestsSscan.hs
@@ -1,474 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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]---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
− tests/AFRPTestsSwitch.hs
@@ -1,215 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 => SF (a, Event a) a-impulseIntegral2 =- switch (first integral >>> arr (\(a, ea) -> (a, fmap (^+^ a) ea)))- impulseIntegral2'- where- impulseIntegral2' :: VectorSpace a s => a -> SF (a, Event a) a- impulseIntegral2' a =- switch ((integral >>> arr (^+^ a)) *** notYet- >>> arr (\(a, ea) -> (a, fmap (^+^ a) ea)))- impulseIntegral2'--switch_t5 :: [Double]-switch_t5 = take 50 $ embed impulseIntegral2- (deltaEncode 0.1 (zip (repeat 1.0) evSeq))- where- evSeq = replicate 9 NoEvent ++ [Event 10.0]- ++ replicate 9 NoEvent ++ [Event (-10.0)]- ++ evSeq--switch_t5r =- [ 0.0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 10.9,- 11.0, 11.1, 11.2, 11.3, 11.4, 11.5, 11.6, 11.7, 11.8, 1.9,- 2.0, 2.1, 2.2, 2.3, 2.4, 2.5, 2.6, 2.7, 2.8, 12.9,- 13.0, 13.1, 13.2, 13.3, 13.4, 13.5, 13.6, 13.7, 13.8, 3.9,- 4.0, 4.1, 4.2, 4.3, 4.4, 4.5, 4.6, 4.7, 4.8, 14.9]---switch_trs =- [ switch_t0 ~= switch_t0r,- switch_t1 ~= switch_t1r,- switch_t2 ~= switch_t2r,- switch_t3 ~= switch_t3r,- switch_t4 ~= switch_t4r,- switch_t5 ~= switch_t5r- ]--switch_tr = and switch_trs-
− tests/AFRPTestsTask.hs
@@ -1,218 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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
− tests/AFRPTestsUtils.hs
@@ -1,375 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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
− tests/AFRPTestsWFG.hs
@@ -1,104 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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
tests/HaddockCoverage.hs view
@@ -1,4 +1,3 @@------------------------------------------------------------------------------ -- | -- Module : Main (HaddockCoverage) -- Copyright : (C) 2015 Ivan Perez@@ -13,7 +12,6 @@ -- -- Run haddock on a source tree and report if anything in any -- module is not documented.------------------------------------------------------------------------------ module Main where import Control.Applicative@@ -79,13 +77,13 @@ isHaskellFile fp = (isSuffixOf ".hs" fp || isSuffixOf ".lhs" fp) && not (any (`isSuffixOf` fp) excludedFiles) - excludedFiles = [ "Vector2.hs", "Vector3.hs"- , "Point2.hs", "Point3.hs"- , "MergeableRecord.hs" ]+ excludedFiles = [ "Yampa.hs", "Random.hs" ] getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) getFilesAndDirectories dir = do- c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir+ c <- map (dir </>) . filter (`notElem` ["..", "."])+ <$> getDirectoryContents dir+ (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c -- find-based implementation (not portable)
tests/hlint.hs view
@@ -1,4 +1,3 @@------------------------------------------------------------------------------ -- | -- Module : Main (hlint) -- Copyright : (C) 2013 Edward Kmett@@ -8,7 +7,6 @@ -- Portability : portable -- -- This module runs HLint on the lens source tree.------------------------------------------------------------------------------ module Main where import Control.Monad
− tests/testAFRPMain.hs
@@ -1,78 +0,0 @@-{-# OPTIONS_GHC -fno-warn-tabs #-}-{- $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 Control.Monad (when)-import System.Environment (getArgs, getProgName)-import System.Exit (exitWith, ExitCode(..))-import System.IO---- 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- Right emsg -> usage pname (Just emsg)- Left tFlags ->- if tHelp tFlags- then usage pname Nothing- else do- -- Run regresion tests, check if passed- t <- if tReg tFlags- then runRegTests- else return True- -- Run space tests- when (tSpace tFlags)- runSpaceTests- -- Communicate if all tests have passed- let exitCode = if t then ExitSuccess else (ExitFailure 1)- exitWith exitCode--