diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,101 +1,286 @@ +2025-02-27 Ivan Perez + * Version bump (0.15) (#322). + * Deprecate FRP.Yampa.Arrow.arr3,arr4,arr5 (#313). + +2024-12-07 Ivan Perez + * Version bump (0.14.12) (#319). + * Re-export missing definitions (#318). + +2024-10-07 Ivan Perez + * 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 + * Version bump (0.14.10) (#302). + * Implement integral using trapezoid rule (#263). + +2024-06-08 Ivan Perez + * 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 + * Version bump (0.14.8) (#294). + +2024-02-09 Ivan Perez + * 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 + * 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 + * 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 + * Version bump (0.14.4) (#274). + * Introduce benchmark (#167). + * Add version bounds to dependencies (#273). + +2023-06-07 Ivan Perez + * 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 + * 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 + * Version bump (0.14.1) (#251). + * Replace broken links (#253). + * Fix typo (#252). + +2022-12-07 Ivan Perez + * Version bump (0.14) (#242). + * Adjust to work with simple-affine-space-0.2 (#241). + +2022-10-07 Ivan Perez + * 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 + * 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 + * 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 + * 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 + * 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 + * 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 + * 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 + * 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 + * 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 + * Version bump (0.11.1). + * Document papers in README. + * Fix leak. + * Thanks to @tresormuta, @chriz-keera. + +2018-04-05 Ivan Perez + * 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 - * 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 - * 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 - * 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 - * 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 - * .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 - * src/: Adds new -:> combinator. - * Yampa.cabal: Version bump (0.10.5). + * Version bump (0.10.5). + * Add new -:> combinator. 2015-11-14 Ivan Perez - * 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 - * 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 - * 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 - * 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 - * 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 - * 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 - * 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 - * 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 - * src/: Coding style improvements. + * Coding style improvements. 2014-08-29 Ivan Perez - - * Yampa.cabal: version bump (0.9.6). - * src/: Adds a substantial amount of documentation. - * src/FRP/Yampa.hs: Adds a new pause combinator. + * Version bump (0.9.6). + * Add a substantial amount of documentation. + * Add a new pause combinator. 2014-06-04 Ivan Perez - - * Adds project to hudson-backed continuous integration server. + * Add project to hudson-backed continuous integration server. 2014-04-26 Ivan Perez - - * 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 - - * 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. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/Yampa.cabal b/Yampa.cabal --- a/Yampa.cabal +++ b/Yampa.cabal @@ -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 diff --git a/benchmarks/Bench.hs b/benchmarks/Bench.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Bench.hs @@ -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 + } diff --git a/examples/Diagrams.hs b/examples/Diagrams.hs new file mode 100644 --- /dev/null +++ b/examples/Diagrams.hs @@ -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)) diff --git a/examples/Elevator/Elevator.hs b/examples/Elevator/Elevator.hs --- a/examples/Elevator/Elevator.hs +++ b/examples/Elevator/Elevator.hs @@ -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 diff --git a/examples/Elevator/TestElevatorMain.hs b/examples/Elevator/TestElevatorMain.hs --- a/examples/Elevator/TestElevatorMain.hs +++ b/examples/Elevator/TestElevatorMain.hs @@ -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 diff --git a/examples/TailgatingDetector/TailgatingDetector.hs b/examples/TailgatingDetector/TailgatingDetector.hs --- a/examples/TailgatingDetector/TailgatingDetector.hs +++ b/examples/TailgatingDetector/TailgatingDetector.hs @@ -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) diff --git a/examples/TailgatingDetector/TestTGMain.hs b/examples/TailgatingDetector/TestTGMain.hs --- a/examples/TailgatingDetector/TestTGMain.hs +++ b/examples/TailgatingDetector/TestTGMain.hs @@ -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 diff --git a/examples/yampa-game/MainBouncingBox.hs b/examples/yampa-game/MainBouncingBox.hs --- a/examples/yampa-game/MainBouncingBox.hs +++ b/examples/yampa-game/MainBouncingBox.hs @@ -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. -- diff --git a/examples/yampa-game/MainCircleMouse.hs b/examples/yampa-game/MainCircleMouse.hs --- a/examples/yampa-game/MainCircleMouse.hs +++ b/examples/yampa-game/MainCircleMouse.hs @@ -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 diff --git a/examples/yampa-game/MainWiimote.hs b/examples/yampa-game/MainWiimote.hs --- a/examples/yampa-game/MainWiimote.hs +++ b/examples/yampa-game/MainWiimote.hs @@ -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 diff --git a/examples/yampa-game/YampaSDL.hs b/examples/yampa-game/YampaSDL.hs --- a/examples/yampa-game/YampaSDL.hs +++ b/examples/yampa-game/YampaSDL.hs @@ -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 diff --git a/src/FRP/Yampa.hs b/src/FRP/Yampa.hs --- a/src/FRP/Yampa.hs +++ b/src/FRP/Yampa.hs @@ -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__ -- --- +-- You can find many examples, tutorials and documentation here: -- --- +-- -- +-- -- --- Structuring a hybrid system in Yampa is done based on two main concepts: +-- -- --- * Signal Functions: 'SF'. Yampa is based on the concept of Signal Functions, --- which are functions from a typed input signal to a typed output signal. --- Conceptually, signals are functions from Time to Value, where time are the --- real numbers and, computationally, a very dense approximation (Double) is --- used. +-- __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 +-- . -- --- * "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 :: -> 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: diff --git a/src/FRP/Yampa/AffineSpace.hs b/src/FRP/Yampa/AffineSpace.hs deleted file mode 100644 --- a/src/FRP/Yampa/AffineSpace.hs +++ /dev/null @@ -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) diff --git a/src/FRP/Yampa/Arrow.hs b/src/FRP/Yampa/Arrow.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Yampa/Arrow.hs @@ -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 diff --git a/src/FRP/Yampa/Basic.hs b/src/FRP/Yampa/Basic.hs --- a/src/FRP/Yampa/Basic.hs +++ b/src/FRP/Yampa/Basic.hs @@ -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)} diff --git a/src/FRP/Yampa/Conditional.hs b/src/FRP/Yampa/Conditional.hs --- a/src/FRP/Yampa/Conditional.hs +++ b/src/FRP/Yampa/Conditional.hs @@ -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 diff --git a/src/FRP/Yampa/Core.hs b/src/FRP/Yampa/Core.hs deleted file mode 100644 --- a/src/FRP/Yampa/Core.hs +++ /dev/null @@ -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 diff --git a/src/FRP/Yampa/Delays.hs b/src/FRP/Yampa/Delays.hs --- a/src/FRP/Yampa/Delays.hs +++ b/src/FRP/Yampa/Delays.hs @@ -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 diff --git a/src/FRP/Yampa/Diagnostics.hs b/src/FRP/Yampa/Diagnostics.hs --- a/src/FRP/Yampa/Diagnostics.hs +++ b/src/FRP/Yampa/Diagnostics.hs @@ -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) diff --git a/src/FRP/Yampa/Event.hs b/src/FRP/Yampa/Event.hs --- a/src/FRP/Yampa/Event.hs +++ b/src/FRP/Yampa/Event.hs @@ -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 diff --git a/src/FRP/Yampa/EventS.hs b/src/FRP/Yampa/EventS.hs --- a/src/FRP/Yampa/EventS.hs +++ b/src/FRP/Yampa/EventS.hs @@ -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: diff --git a/src/FRP/Yampa/Forceable.hs b/src/FRP/Yampa/Forceable.hs deleted file mode 100644 --- a/src/FRP/Yampa/Forceable.hs +++ /dev/null @@ -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 diff --git a/src/FRP/Yampa/Geometry.hs b/src/FRP/Yampa/Geometry.hs deleted file mode 100644 --- a/src/FRP/Yampa/Geometry.hs +++ /dev/null @@ -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 diff --git a/src/FRP/Yampa/Hybrid.hs b/src/FRP/Yampa/Hybrid.hs --- a/src/FRP/Yampa/Hybrid.hs +++ b/src/FRP/Yampa/Hybrid.hs @@ -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) diff --git a/src/FRP/Yampa/Integration.hs b/src/FRP/Yampa/Integration.hs --- a/src/FRP/Yampa/Integration.hs +++ b/src/FRP/Yampa/Integration.hs @@ -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 +-- . +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) diff --git a/src/FRP/Yampa/InternalCore.hs b/src/FRP/Yampa/InternalCore.hs --- a/src/FRP/Yampa/InternalCore.hs +++ b/src/FRP/Yampa/InternalCore.hs @@ -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: --- --- --- --- Structuring a hybrid system in Yampa is done based on two main concepts: --- --- * Signal Functions: 'SF'. Yampa is based on the concept of Signal Functions, --- which are functions from a typed input signal to a typed output signal. --- Conceptually, signals are functions from Time to Value, where time are the --- real numbers and, computationally, a very dense approximation (Double) is --- used. --- --- * Events: 'Event'. Values that may or may not occur (and would probably --- occur rarely). It is often used for incoming network messages, mouse --- clicks, etc. Events are used as values carried by signals. --- --- A complete Yampa system is defined as one Signal Function from some --- type @a@ to a type @b@. The execution of this signal transformer --- with specific input can be accomplished by means of two functions: --- 'reactimate' (which needs an initialization action, --- an input sensing action and an actuation/consumer action and executes --- until explicitly stopped), and 'react' (which executes only one cycle). --- --- Apart from using normal functions and arrow syntax to define 'SF's, you --- can also use several combinators. See [<#g:4>] for basic signals combinators, --- [<#g:11>] for ways of switching from one signal transformation to another, --- and [<#g:16>] for ways of transforming Event-carrying signals into continuous --- signals, [<#g:19>] for ways of delaying signals, and [<#g:21>] for ways to --- feed a signal back to the same signal transformer. --- --- Ways to define Event-carrying signals are given in [<#g:7>], and --- "FRP.Yampa.Event" defines events and event-manipulation functions. --- --- Finally, see [<#g:26>] for sources of randomness (useful in games). - --- CHANGELOG: --- --- - Adds (most) documentation. --- --- - New version using GADTs. --- --- ToDo: --- --- - Specialize def. of repeatedly. Could have an impact on invaders. --- --- - New defs for accs using SFAcc --- --- - Make sure opt worked: e.g. --- --- - > repeatedly >>> count >>> arr (fmap sqr) --- --- - Introduce SFAccHld. --- --- - See if possible to unify AccHld wity Acc??? They are so close. --- --- - Introduce SScan. BUT KEEP IN MIND: Most if not all opts would --- - have been possible without GADTs??? --- --- - Look into pairs. At least pairing of SScan ought to be interesting. --- --- - Would be nice if we could get rid of first & second with impunity --- - thanks to Id optimizations. That's a clear win, with or without --- - an explicit pair combinator. --- --- - delayEventCat is a bit complicated ... --- --- --- Random ideas: --- --- - What if one used rules to optimize --- - (arr :: SF a ()) to (constant ()) --- - (arr :: SF a a) to identity --- But inspection of invader source code seem to indicate that --- these are not very common cases at all. --- --- - It would be nice if it was possible to come up with opt. rules --- that are invariant of how signal function expressions are --- parenthesized. Right now, we have e.g. --- arr f >>> (constant c >>> sf) --- being optimized to --- cpAuxA1 f (cpAuxC1 c sf) --- whereas it clearly should be possible to optimize to just --- cpAuxC1 c sf --- What if we didn't use SF' but --- SFComp :: -> SF' a b -> SF' b c -> SF' a c --- ??? --- --- - The transition function would still be optimized in (pretty much) --- the current way, but it would still be possible to look "inside" --- composed signal functions for lost optimization opts. --- Seems to me this could be done without too much extra effort/no dupl. --- work. --- E.g. new cpAux, the general case: --- --- @ --- cpAux sf1 sf2 = SFComp tf sf1 sf2 --- where --- tf dt a = (cpAux sf1' sf2', c) --- where --- (sf1', b) = (sfTF' sf1) dt a --- (sf2', c) = (sfTF' sf2) dt b --- @ --- --- - The ONLY change was changing the constructor from SF' to SFComp and --- adding sf1 and sf2 to the constructor app.! --- --- - An optimized case: --- cpAuxC1 b sf1 sf2 = SFComp tf sf1 sf2 --- So cpAuxC1 gets an extra arg, and we change the constructor. --- But how to exploit without writing 1000s of rules??? --- Maybe define predicates on SFComp to see if the first or second --- sf are "interesting", and if so, make "reassociate" and make a --- recursive call? E.g. we're in the arr case, and the first sf is another --- arr, so we'd like to combine the two. --- --- - It would also be intersting, then, to know when to STOP playing this --- game, due to the overhead involved. --- --- - Why don't we have a "SWITCH" constructor that indicates that the --- structure will change, and thus that it is worthwile to keep --- looking for opt. opportunities, whereas a plain "SF'" would --- indicate that things NEVER are going to change, and thus we can just --- as well give up? ------------------------------------------------------------------------------------------ - -module FRP.Yampa.InternalCore ( - module Control.Arrow, - -- SF is an instance of Arrow and ArrowLoop. Method instances: - -- arr :: (a -> b) -> SF a b - -- (>>>) :: SF a b -> SF b c -> SF a c - -- (<<<) :: SF b c -> SF a b -> SF a c - -- first :: SF a b -> SF (a,c) (b,c) - -- second :: SF a b -> SF (c,a) (c,b) - -- (***) :: SF a b -> SF a' b' -> SF (a,a') (b,b') - -- (&&&) :: SF a b -> SF a b' -> SF a (b,b') - -- returnA :: SF a a - -- loop :: SF (a,c) (b,c) -> SF a b - - -- * Basic definitions - -- ** Time - Time, -- [s] Both for time w.r.t. some reference and intervals. - DTime, -- [s] Sampling interval, always > 0. - - -- ** Signal Functions - SF(..), -- Signal Function. - - -- ** Future Signal Function - SF'(..), -- Signal Function. - sfTF', - sfId, - sfConst, - sfArrG, - - -- *** Scanning - sfSScan, - - Transition, - - -- ** Function descriptions - FunDesc(..), - fdFun, - - -- ** Lifting - arrPrim, - arrEPrim, -- For optimization - epPrim - -) where - -import Control.Arrow -#if __GLASGOW_HASKELL__ >= 610 -import qualified Control.Category (Category(..)) -#endif - -import FRP.Yampa.Diagnostics -import FRP.Yampa.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 where and is one of: --- X - arbitrary signal function --- A - arbitrary pure arrow --- C - constant arrow --- E - event-processing arrow --- G - arrow known not to be identity, constant (C) or --- event-processing (E). - -cpXX :: SF' a b -> SF' b c -> SF' a c -cpXX (SFArr _ fd1) sf2 = cpAX fd1 sf2 -cpXX sf1 (SFArr _ fd2) = cpXA sf1 fd2 -{- --- !!! 2005-07-07: Too strict. --- !!! But the question is if it is worth to define pre in terms of sscan ... --- !!! It is slower than the simplest possible pre, and the kind of coding --- !!! required to ensure that the laziness props of the second SF are --- !!! preserved might just slow things down further ... -cpXX (SFSScan _ f1 s1 b) (SFSScan _ f2 s2 c) = - sfSScan f (s1, b, s2, c) c - where - f (s1, b, s2, c) a = - case f1 s1 a of - Nothing -> - case f2 s2 b of - Nothing -> Nothing - Just (s2', c') -> Just ((s1, b, s2', c'), c') - Just (s1', b') -> - case f2 s2 b' of - Nothing -> Just ((s1', b', s2, c), c) - Just (s2', c') -> Just ((s1', b', s2', c'), c') --} --- !!! 2005-07-07: Indeed, this is a bit slower than the code above (14%). --- !!! But both are better than not composing (35% faster and 26% faster)! -cpXX (SFSScan _ f1 s1 b) (SFSScan _ f2 s2 c) = - sfSScan f (s1, b, s2, c) c - where - f (s1, b, s2, c) a = - let - (u, s1', b') = case f1 s1 a of - Nothing -> (True, s1, b) - Just (s1',b') -> (False, s1', b') - in - case f2 s2 b' of - Nothing | u -> Nothing - | otherwise -> Just ((s1', b', s2, c), c) - Just (s2', c') -> Just ((s1', b', s2', c'), c') -cpXX (SFSScan _ f1 s1 eb) (SFEP _ f2 s2 cne) = - sfSScan f (s1, eb, s2, cne) cne - where - f (s1, eb, s2, cne) a = - case f1 s1 a of - Nothing -> - case eb of - NoEvent -> Nothing - Event b -> - let (s2', c, cne') = f2 s2 b - in - Just ((s1, eb, s2', cne'), c) - Just (s1', eb') -> - case eb' of - NoEvent -> Just ((s1', eb', s2, cne), cne) - Event b -> - let (s2', c, cne') = f2 s2 b - in - Just ((s1', eb', s2', cne'), c) --- !!! 2005-07-09: This seems to yield only a VERY marginal speedup --- !!! without seq. With seq, substantial speedup! -cpXX (SFEP _ f1 s1 bne) (SFSScan _ f2 s2 c) = - sfSScan f (s1, bne, s2, c) c - where - f (s1, bne, s2, c) ea = - let (u, s1', b', bne') = case ea of - NoEvent -> (True, s1, bne, bne) - Event a -> - let (s1', b, bne') = f1 s1 a - in - (False, s1', b, bne') - in - case f2 s2 b' of - Nothing | u -> Nothing - | otherwise -> Just (seq s1' (s1', bne', s2, c), c) - Just (s2', c') -> Just (seq s1' (s1', bne', s2', c'), c') --- The function "f" is invoked whenever an event is to be processed. It then --- computes the output, the new state, and the new NoEvent output. --- However, when sequencing event processors, the ones in the latter --- part of the chain may not get invoked since previous ones may --- decide not to "fire". But a "new" NoEvent output still has to be --- produced, i.e. the old one retained. Since it cannot be computed by --- invoking the last event-processing function in the chain, it has to --- be remembered. Since the composite event-processing function remains --- constant/unchanged, the NoEvent output has to be part of the state. --- An alternarive would be to make the event-processing function take an --- extra argument. But that is likely to make the simple case more --- expensive. See note at sfEP. -cpXX (SFEP _ f1 s1 bne) (SFEP _ f2 s2 cne) = - sfEP f (s1, s2, cne) (vfyNoEv bne cne) - where - f (s1, s2, cne) a = - case f1 s1 a of - (s1', NoEvent, NoEvent) -> ((s1', s2, cne), cne, cne) - (s1', Event b, NoEvent) -> - let (s2', c, cne') = f2 s2 b in ((s1', s2', cne'), c, cne') - _ -> usrErr "AFRP" "cpXX" "Assertion failed: Functions on events must not map NoEvent to Event." --- !!! 2005-06-28: Why isn't SFCpAXA (FDC ...) checked for? --- !!! No invariant rules that out, and it would allow to drop the --- !!! event processor ... Does that happen elsewhere? -cpXX sf1@(SFEP{}) (SFCpAXA _ (FDE f21 f21ne) sf22 fd23) = - cpXX (cpXE sf1 f21 f21ne) (cpXA sf22 fd23) --- f21 will (hopefully) be invoked less frequently if merged with the --- event processor. -cpXX sf1@(SFEP{}) (SFCpAXA _ (FDG f21) sf22 fd23) = - cpXX (cpXG sf1 f21) (cpXA sf22 fd23) --- Only functions whose domain is known to be Event can be merged --- from the left with event processors. -cpXX (SFCpAXA _ fd11 sf12 (FDE f13 f13ne)) sf2@(SFEP{}) = - cpXX (cpAX fd11 sf12) (cpEX f13 f13ne sf2) --- !!! Other cases to look out for: --- !!! any sf >>> SFCpAXA = SFCpAXA if first arr is const. --- !!! But the following will presumably not work due to type restrictions. --- !!! Need to reconstruct sf2 I think. --- cpXX sf1 sf2@(SFCpAXA _ _ (FDC b) sf22 fd23) = sf2 -cpXX (SFCpAXA _ fd11 sf12 fd13) (SFCpAXA _ fd21 sf22 fd23) = - -- Termination: The first argument to cpXX is no larger than - -- the current first argument, and the second is smaller. - cpAXA fd11 (cpXX (cpXA sf12 (fdComp fd13 fd21)) sf22) fd23 --- !!! 2005-06-27: The if below accounts for a significant slowdown. --- !!! One would really like a cheme where opts only take place --- !!! after a structural change ... --- cpXX sf1 sf2 = cpXXInv sf1 sf2 --- cpXX sf1 sf2 = cpXXAux sf1 sf2 -cpXX sf1 sf2 = SF' tf -- False - -- if sfIsInv sf1 && sfIsInv sf2 then cpXXInv sf1 sf2 else SF' tf False - where - tf dt a = (cpXX sf1' sf2', c) - where - (sf1', b) = (sfTF' sf1) dt a - (sf2', c) = (sfTF' sf2) dt b - - -{- -cpXXAux sf1@(SF' _ _) sf2@(SF' _ _) = SF' tf False - where - tf dt a = (cpXXAux sf1' sf2', c) - where - (sf1', b) = (sfTF' sf1) dt a - (sf2', c) = (sfTF' sf2) dt b -cpXXAux sf1 sf2 = SF' tf False - where - tf dt a = (cpXXAux sf1' sf2', c) - where - (sf1', b) = (sfTF' sf1) dt a - (sf2', c) = (sfTF' sf2) dt b --} - -{- -cpXXAux sf1 sf2 | unsimplifiable sf1 sf2 = SF' tf False - | otherwise = cpXX sf1 sf2 - where - tf dt a = (cpXXAux sf1' sf2', c) - where - (sf1', b) = (sfTF' sf1) dt a - (sf2', c) = (sfTF' sf2) dt b - - unsimplifiable sf1@(SF' _ _) sf2@(SF' _ _) = True - unsimplifiable sf1 sf2 = True --} - -{- --- wrong ... -cpXXAux sf1@(SF' _ False) sf2 = SF' tf False -cpXXAux sf1@(SFCpAXA _ False _ _ _) sf2 = SF' tf False -cpXXAux sf1 sf2@(SF' _ False) = SF' tf False -cpXXAux sf1 sf2@(SFCpAXA _ False _ _ _) = SF' tf False -cpXXAux sf1 sf2 = - if sfIsInv sf1 && sfIsInv sf2 then cpXXInv sf1 sf2 else SF' tf False - where - tf dt a = (cpXXAux sf1' sf2', c) - where - (sf1', b) = (sfTF' sf1) dt a - (sf2', c) = (sfTF' sf2) dt b --} - -{- -cpXXInv sf1 sf2 = SF' tf True - where - tf dt a = sf1 `seq` sf2 `seq` (cpXXInv sf1' sf2', c) - where - (sf1', b) = (sfTF' sf1) dt a - (sf2', c) = (sfTF' sf2) dt b --} - --- !!! No. We need local defs. Keep fd1 and fd2. Extract f1 and f2 --- !!! once and fo all. Get rid of FDI and FDC at the top level. --- !!! First local def. analyse sf2. SFArr, SFAcc etc. tf in --- !!! recursive case just make use of f1 and f3. --- !!! if sf2 is SFInv, that's delegated to a second local --- !!! recursive def. that does not analyse sf2. - -cpAXA :: FunDesc a b -> SF' b c -> FunDesc c d -> SF' a d --- Termination: cpAX/cpXA, via cpCX, cpEX etc. only call cpAXA if sf2 --- is SFCpAXA, and then on the embedded sf and hence on a smaller arg. -cpAXA FDI sf2 fd3 = cpXA sf2 fd3 -cpAXA fd1 sf2 FDI = cpAX fd1 sf2 -cpAXA (FDC b) sf2 fd3 = cpCXA b sf2 fd3 -cpAXA _ _ (FDC d) = sfConst d -cpAXA fd1 sf2 fd3 = - cpAXAAux fd1 (fdFun fd1) fd3 (fdFun fd3) sf2 - where - -- Really: cpAXAAux :: SF' b c -> SF' a d - -- Note: Event cases are not optimized (EXA etc.) - cpAXAAux :: FunDesc a b -> (a -> b) -> FunDesc c d -> (c -> d) - -> SF' b c -> SF' a d - cpAXAAux fd1 _ fd3 _ (SFArr _ fd2) = - sfArr (fdComp (fdComp fd1 fd2) fd3) - cpAXAAux fd1 _ fd3 _ sf2@(SFSScan {}) = - cpAX fd1 (cpXA sf2 fd3) - cpAXAAux fd1 _ fd3 _ sf2@(SFEP {}) = - cpAX fd1 (cpXA sf2 fd3) - cpAXAAux fd1 _ fd3 _ (SFCpAXA _ fd21 sf22 fd23) = - cpAXA (fdComp fd1 fd21) sf22 (fdComp fd23 fd3) - cpAXAAux fd1 f1 fd3 f3 sf2 = SFCpAXA tf fd1 sf2 fd3 -{- - if sfIsInv sf2 then - cpAXAInv fd1 f1 fd3 f3 sf2 - else - SFCpAXA tf False fd1 sf2 fd3 --} - where - tf dt a = (cpAXAAux fd1 f1 fd3 f3 sf2', f3 c) - where - (sf2', c) = (sfTF' sf2) dt (f1 a) - -{- - cpAXAInv fd1 f1 fd3 f3 sf2 = SFCpAXA tf True fd1 sf2 fd3 - where - tf dt a = sf2 `seq` (cpAXAInv fd1 f1 fd3 f3 sf2', f3 c) - where - (sf2', c) = (sfTF' sf2) dt (f1 a) --} - -cpAX :: FunDesc a b -> SF' b c -> SF' a c -cpAX FDI sf2 = sf2 -cpAX (FDC b) sf2 = cpCX b sf2 -cpAX (FDE f1 f1ne) sf2 = cpEX f1 f1ne sf2 -cpAX (FDG f1) sf2 = cpGX f1 sf2 - -cpXA :: SF' a b -> FunDesc b c -> SF' a c -cpXA sf1 FDI = sf1 -cpXA _ (FDC c) = sfConst c -cpXA sf1 (FDE f2 f2ne) = cpXE sf1 f2 f2ne -cpXA sf1 (FDG f2) = cpXG sf1 f2 - --- Don't forget that the remaining signal function, if it is --- SF', later could turn into something else, like SFId. -cpCX :: b -> SF' b c -> SF' a c -cpCX b (SFArr _ fd2) = sfConst ((fdFun fd2) b) --- 2005-07-01: If we were serious about the semantics of sscan being required --- to be independent of the sampling interval, I guess one could argue for a --- fixed-point computation here ... Or maybe not. --- cpCX b (SFSScan _ _ _ _) = sfConst -cpCX b (SFSScan _ f s c) = sfSScan (\s _ -> f s b) s c -cpCX b (SFEP _ _ _ cne) = sfConst (vfyNoEv b cne) -cpCX b (SFCpAXA _ fd21 sf22 fd23) = - cpCXA ((fdFun fd21) b) sf22 fd23 -cpCX b sf2 = SFCpAXA tf (FDC b) sf2 FDI -{- - if sfIsInv sf2 then - cpCXInv b sf2 - else - SFCpAXA tf False (FDC b) sf2 FDI --} - where - tf dt _ = (cpCX b sf2', c) - where - (sf2', c) = (sfTF' sf2) dt b - - -{- -cpCXInv b sf2 = SFCpAXA tf True (FDC b) sf2 FDI - where - tf dt _ = sf2 `seq` (cpCXInv b sf2', c) - where - (sf2', c) = (sfTF' sf2) dt b --} - - -cpCXA :: b -> SF' b c -> FunDesc c d -> SF' a d -cpCXA b sf2 FDI = cpCX b sf2 -cpCXA _ _ (FDC c) = sfConst c -cpCXA b sf2 fd3 = cpCXAAux (FDC b) b fd3 (fdFun fd3) sf2 - where - -- fd1 = FDC b - -- f3 = fdFun fd3 - - -- Really: SF' b c -> SF' a d - cpCXAAux :: FunDesc a b -> b -> FunDesc c d -> (c -> d) - -> SF' b c -> SF' a d - cpCXAAux _ b _ f3 (SFArr _ fd2) = sfConst (f3 ((fdFun fd2) b)) - cpCXAAux _ b _ f3 (SFSScan _ f s c) = sfSScan f' s (f3 c) - where - f' s _ = case f s b of - Nothing -> Nothing - Just (s', c') -> Just (s', f3 c') - cpCXAAux _ b _ f3 (SFEP _ _ _ cne) = sfConst (f3 (vfyNoEv b cne)) - cpCXAAux _ b fd3 _ (SFCpAXA _ fd21 sf22 fd23) = - cpCXA ((fdFun fd21) b) sf22 (fdComp fd23 fd3) - cpCXAAux fd1 b fd3 f3 sf2 = SFCpAXA tf fd1 sf2 fd3 -{- - if sfIsInv sf2 then - cpCXAInv fd1 b fd3 f3 sf2 - else - SFCpAXA tf False fd1 sf2 fd3 --} - where - tf dt _ = (cpCXAAux fd1 b fd3 f3 sf2', f3 c) - where - (sf2', c) = (sfTF' sf2) dt b - -{- - -- For some reason, seq on sf2' in tf is faster than making - -- cpCXAInv strict in sf2 by seq-ing on the top level (which would - -- be similar to pattern matching on sf2). - cpCXAInv fd1 b fd3 f3 sf2 = SFCpAXA tf True fd1 sf2 fd3 - where - tf dt _ = sf2 `seq` (cpCXAInv fd1 b fd3 f3 sf2', f3 c) - where - (sf2', c) = (sfTF' sf2) dt b --} - - -cpGX :: (a -> b) -> SF' b c -> SF' a c -cpGX f1 sf2 = cpGXAux (FDG f1) f1 sf2 - where - cpGXAux :: FunDesc a b -> (a -> b) -> SF' b c -> SF' a c - cpGXAux fd1 _ (SFArr _ fd2) = sfArr (fdComp fd1 fd2) - -- We actually do know that (fdComp (FDG f1) fd21) is going to - -- result in an FDG. So we *could* call a cpGXA here. But the - -- price is "inlining" of part of fdComp. - cpGXAux _ f1 (SFSScan _ f s c) = sfSScan (\s a -> f s (f1 a)) s c - -- We really shouldn't see an EP here, as that would mean - -- an arrow INTRODUCING events ... - cpGXAux fd1 _ (SFCpAXA _ fd21 sf22 fd23) = - cpAXA (fdComp fd1 fd21) sf22 fd23 - cpGXAux fd1 f1 sf2 = SFCpAXA tf fd1 sf2 FDI -{- - if sfIsInv sf2 then - cpGXInv fd1 f1 sf2 - else - SFCpAXA tf False fd1 sf2 FDI --} - where - tf dt a = (cpGXAux fd1 f1 sf2', c) - where - (sf2', c) = (sfTF' sf2) dt (f1 a) - -{- - cpGXInv fd1 f1 sf2 = SFCpAXA tf True fd1 sf2 FDI - where - tf dt a = sf2 `seq` (cpGXInv fd1 f1 sf2', c) - where - (sf2', c) = (sfTF' sf2) dt (f1 a) --} - - -cpXG :: SF' a b -> (b -> c) -> SF' a c -cpXG sf1 f2 = cpXGAux (FDG f2) f2 sf1 - where - -- Really: cpXGAux :: SF' a b -> SF' a c - cpXGAux :: FunDesc b c -> (b -> c) -> SF' a b -> SF' a c - cpXGAux fd2 _ (SFArr _ fd1) = sfArr (fdComp fd1 fd2) - cpXGAux _ f2 (SFSScan _ f s b) = sfSScan f' s (f2 b) - where - f' s a = case f s a of - Nothing -> Nothing - Just (s', b') -> Just (s', f2 b') - cpXGAux _ f2 (SFEP _ f1 s bne) = sfEP f s (f2 bne) - where - f s a = let (s', b, bne') = f1 s a in (s', f2 b, f2 bne') - cpXGAux fd2 _ (SFCpAXA _ fd11 sf12 fd22) = - cpAXA fd11 sf12 (fdComp fd22 fd2) - cpXGAux fd2 f2 sf1 = SFCpAXA tf FDI sf1 fd2 -{- - if sfIsInv sf1 then - cpXGInv fd2 f2 sf1 - else - SFCpAXA tf False FDI sf1 fd2 --} - where - tf dt a = (cpXGAux fd2 f2 sf1', f2 b) - where - (sf1', b) = (sfTF' sf1) dt a - -{- - cpXGInv fd2 f2 sf1 = SFCpAXA tf True FDI sf1 fd2 - where - tf dt a = (cpXGInv fd2 f2 sf1', f2 b) - where - (sf1', b) = (sfTF' sf1) dt a --} - -cpEX :: (Event a -> b) -> b -> SF' b c -> SF' (Event a) c -cpEX f1 f1ne sf2 = cpEXAux (FDE f1 f1ne) f1 f1ne sf2 - where - cpEXAux :: FunDesc (Event a) b -> (Event a -> b) -> b - -> SF' b c -> SF' (Event a) c - cpEXAux fd1 _ _ (SFArr _ fd2) = sfArr (fdComp fd1 fd2) - cpEXAux _ f1 _ (SFSScan _ f s c) = sfSScan (\s a -> f s (f1 a)) s c - -- We must not capture cne in the f closure since cne can change! - -- See cpXX the SFEP/SFEP case for a similar situation. However, - -- FDE represent a state-less signal function, so *its* NoEvent - -- value never changes. Hence we only need to verify that it is - -- NoEvent once. - cpEXAux _ f1 f1ne (SFEP _ f2 s cne) = - sfEP f (s, cne) (vfyNoEv f1ne cne) - where - f scne@(s, cne) a = - case f1 (Event a) of - NoEvent -> (scne, cne, cne) - Event b -> - let (s', c, cne') = f2 s b in ((s', cne'), c, cne') - cpEXAux fd1 _ _ (SFCpAXA _ fd21 sf22 fd23) = - cpAXA (fdComp fd1 fd21) sf22 fd23 - -- The rationale for the following is that the case analysis - -- is typically not going to be more expensive than applying - -- the function and possibly a bit cheaper. Thus if events - -- are sparse, we might win, and if not, we don't loose to - -- much. - cpEXAux fd1 f1 f1ne sf2 = SFCpAXA tf fd1 sf2 FDI -{- - if sfIsInv sf2 then - cpEXInv fd1 f1 f1ne sf2 - else - SFCpAXA tf False fd1 sf2 FDI --} - where - tf dt ea = (cpEXAux fd1 f1 f1ne sf2', c) - where - (sf2', c) = - case ea of - NoEvent -> (sfTF' sf2) dt f1ne - _ -> (sfTF' sf2) dt (f1 ea) - -{- - cpEXInv fd1 f1 f1ne sf2 = SFCpAXA tf True fd1 sf2 FDI - where - tf dt ea = sf2 `seq` (cpEXInv fd1 f1 f1ne sf2', c) - where - (sf2', c) = - case ea of - NoEvent -> (sfTF' sf2) dt f1ne - _ -> (sfTF' sf2) dt (f1 ea) --} - -cpXE :: SF' a (Event b) -> (Event b -> c) -> c -> SF' a c -cpXE sf1 f2 f2ne = cpXEAux (FDE f2 f2ne) f2 f2ne sf1 - where - cpXEAux :: FunDesc (Event b) c -> (Event b -> c) -> c - -> SF' a (Event b) -> SF' a c - cpXEAux fd2 _ _ (SFArr _ fd1) = sfArr (fdComp fd1 fd2) - cpXEAux _ f2 f2ne (SFSScan _ f s eb) = sfSScan f' s (f2 eb) - where - f' s a = case f s a of - Nothing -> Nothing - Just (s', NoEvent) -> Just (s', f2ne) - Just (s', eb') -> Just (s', f2 eb') - cpXEAux _ f2 f2ne (SFEP _ f1 s ebne) = - sfEP f s (vfyNoEv ebne f2ne) - where - f s a = - case f1 s a of - (s', NoEvent, NoEvent) -> (s', f2ne, f2ne) - (s', eb, NoEvent) -> (s', f2 eb, f2ne) - _ -> usrErr "AFRP" "cpXEAux" "Assertion failed: Functions on events must not map NoEvent to Event." - cpXEAux fd2 _ _ (SFCpAXA _ fd11 sf12 fd13) = - cpAXA fd11 sf12 (fdComp fd13 fd2) - cpXEAux fd2 f2 f2ne sf1 = SFCpAXA tf FDI sf1 fd2 -{- - if sfIsInv sf1 then - cpXEInv fd2 f2 f2ne sf1 - else - SFCpAXA tf False FDI sf1 fd2 --} - where - tf dt a = (cpXEAux fd2 f2 f2ne sf1', - case eb of NoEvent -> f2ne; _ -> f2 eb) - where - (sf1', eb) = (sfTF' sf1) dt a - -{- - cpXEInv fd2 f2 f2ne sf1 = SFCpAXA tf True FDI sf1 fd2 - where - tf dt a = sf1 `seq` (cpXEInv fd2 f2 f2ne sf1', - case eb of NoEvent -> f2ne; _ -> f2 eb) - where - (sf1', eb) = (sfTF' sf1) dt a --} - - --- * Widening. --- The definition exploits the following identities: --- first identity = identity -- New --- first (constant b) = arr (\(_, c) -> (b, c)) --- (first (arr f)) = arr (\(a, c) -> (f a, c)) -firstPrim :: SF a b -> SF (a,c) (b,c) -firstPrim (SF {sfTF = tf10}) = SF {sfTF = tf0} - where - tf0 ~(a0, c0) = (fpAux sf1, (b0, c0)) - where - (sf1, b0) = tf10 a0 - - --- Also used in parSplitPrim -fpAux :: SF' a b -> SF' (a,c) (b,c) -fpAux (SFArr _ FDI) = sfId -- New -fpAux (SFArr _ (FDC b)) = sfArrG (\(~(_, c)) -> (b, c)) -fpAux (SFArr _ fd1) = sfArrG (\(~(a, c)) -> ((fdFun fd1) a, c)) -fpAux sf1 = SF' tf - -- if sfIsInv sf1 then fpInv sf1 else SF' tf False - where - tf dt ~(a, c) = (fpAux sf1', (b, c)) - where - (sf1', b) = (sfTF' sf1) dt a - - -{- -fpInv :: SF' a b -> SF' (a,c) (b,c) -fpInv sf1 = SF' tf True - where - tf dt ~(a, c) = sf1 `seq` (fpInv sf1', (b, c)) - where - (sf1', b) = (sfTF' sf1) dt a --} - - --- Mirror image of first. -secondPrim :: SF a b -> SF (c,a) (c,b) -secondPrim (SF {sfTF = tf10}) = SF {sfTF = tf0} - where - tf0 ~(c0, a0) = (spAux sf1, (c0, b0)) - where - (sf1, b0) = tf10 a0 - - --- Also used in parSplitPrim -spAux :: SF' a b -> SF' (c,a) (c,b) -spAux (SFArr _ FDI) = sfId -- New -spAux (SFArr _ (FDC b)) = sfArrG (\(~(c, _)) -> (c, b)) -spAux (SFArr _ fd1) = sfArrG (\(~(c, a)) -> (c, (fdFun fd1) a)) -spAux sf1 = SF' tf - -- if sfIsInv sf1 then spInv sf1 else SF' tf False - where - tf dt ~(c, a) = (spAux sf1', (c, b)) - where - (sf1', b) = (sfTF' sf1) dt a - - -{- -spInv :: SF' a b -> SF' (c,a) (c,b) -spInv sf1 = SF' tf True - where - tf dt ~(c, a) = sf1 `seq` (spInv sf1', (c, b)) - where - (sf1', b) = (sfTF' sf1) dt a --} - - --- * Parallel composition. --- The definition exploits the following identities (that hold for SF): --- identity *** identity = identity -- New --- sf *** identity = first sf -- New --- identity *** sf = second sf -- New --- constant b *** constant d = constant (b, d) --- constant b *** arr f2 = arr (\(_, c) -> (b, f2 c) --- arr f1 *** constant d = arr (\(a, _) -> (f1 a, d) --- arr f1 *** arr f2 = arr (\(a, b) -> (f1 a, f2 b) -parSplitPrim :: SF a b -> SF c d -> SF (a,c) (b,d) -parSplitPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0} - where - tf0 ~(a0, c0) = (psXX sf1 sf2, (b0, d0)) - where - (sf1, b0) = tf10 a0 - (sf2, d0) = tf20 c0 - - -- Naming convention: ps where and is one of: - -- X - arbitrary signal function - -- A - arbitrary pure arrow - -- C - constant arrow - - psXX :: SF' a b -> SF' c d -> SF' (a,c) (b,d) - psXX (SFArr _ fd1) (SFArr _ fd2) = sfArr (fdPar fd1 fd2) - psXX (SFArr _ FDI) sf2 = spAux sf2 -- New - psXX (SFArr _ (FDC b)) sf2 = psCX b sf2 - psXX (SFArr _ fd1) sf2 = psAX (fdFun fd1) sf2 - psXX sf1 (SFArr _ FDI) = fpAux sf1 -- New - psXX sf1 (SFArr _ (FDC d)) = psXC sf1 d - psXX sf1 (SFArr _ fd2) = psXA sf1 (fdFun fd2) --- !!! Unclear if this really is a gain. --- !!! potentially unnecessary tupling and untupling. --- !!! To be investigated. --- !!! 2005-07-01: At least for MEP 6, the corresponding opt for --- !!! &&& was harmfull. On that basis, disable it here too. --- psXX (SFCpAXA _ fd11 sf12 fd13) (SFCpAXA _ fd21 sf22 fd23) = --- cpAXA (fdPar fd11 fd21) (psXX sf12 sf22) (fdPar fd13 fd23) - psXX sf1 sf2 = SF' tf -{- - if sfIsInv sf1 && sfIsInv sf2 then - psXXInv sf1 sf2 - else - SF' tf False --} - where - tf dt ~(a, c) = (psXX sf1' sf2', (b, d)) - where - (sf1', b) = (sfTF' sf1) dt a - (sf2', d) = (sfTF' sf2) dt c - -{- - psXXInv :: SF' a b -> SF' c d -> SF' (a,c) (b,d) - psXXInv sf1 sf2 = SF' tf True - where - tf dt ~(a, c) = sf1 `seq` sf2 `seq` (psXXInv sf1' sf2', - (b, d)) - where - (sf1', b) = (sfTF' sf1) dt a - (sf2', d) = (sfTF' sf2) dt c --} - - psCX :: b -> SF' c d -> SF' (a,c) (b,d) - psCX b (SFArr _ fd2) = sfArr (fdPar (FDC b) fd2) - psCX b sf2 = SF' tf -{- - if sfIsInv sf2 then - psCXInv b sf2 - else - SF' tf False --} - where - tf dt ~(_, c) = (psCX b sf2', (b, d)) - where - (sf2', d) = (sfTF' sf2) dt c - -{- - psCXInv :: b -> SF' c d -> SF' (a,c) (b,d) - psCXInv b sf2 = SF' tf True - where - tf dt ~(_, c) = sf2 `seq` (psCXInv b sf2', (b, d)) - where - (sf2', d) = (sfTF' sf2) dt c --} - - psXC :: SF' a b -> d -> SF' (a,c) (b,d) - psXC (SFArr _ fd1) d = sfArr (fdPar fd1 (FDC d)) - psXC sf1 d = SF' tf -{- - if sfIsInv sf1 then - psXCInv sf1 d - else - SF' tf False --} - where - tf dt ~(a, _) = (psXC sf1' d, (b, d)) - where - (sf1', b) = (sfTF' sf1) dt a - -{- - psXCInv :: SF' a b -> d -> SF' (a,c) (b,d) - psXCInv sf1 d = SF' tf True - where - tf dt ~(a, _) = sf1 `seq` (psXCInv sf1' d, (b, d)) - where - (sf1', b) = (sfTF' sf1) dt a --} - - psAX :: (a -> b) -> SF' c d -> SF' (a,c) (b,d) - psAX f1 (SFArr _ fd2) = sfArr (fdPar (FDG f1) fd2) - psAX f1 sf2 = SF' tf -{- - if sfIsInv sf2 then - psAXInv f1 sf2 - else - SF' tf False --} - where - tf dt ~(a, c) = (psAX f1 sf2', (f1 a, d)) - where - (sf2', d) = (sfTF' sf2) dt c - -{- - psAXInv :: (a -> b) -> SF' c d -> SF' (a,c) (b,d) - psAXInv f1 sf2 = SF' tf True - where - tf dt ~(a, c) = sf2 `seq` (psAXInv f1 sf2', (f1 a, d)) - where - (sf2', d) = (sfTF' sf2) dt c --} - - psXA :: SF' a b -> (c -> d) -> SF' (a,c) (b,d) - psXA (SFArr _ fd1) f2 = sfArr (fdPar fd1 (FDG f2)) - psXA sf1 f2 = SF' tf -{- - if sfIsInv sf1 then - psXAInv sf1 f2 - else - SF' tf False --} - where - tf dt ~(a, c) = (psXA sf1' f2, (b, f2 c)) - where - (sf1', b) = (sfTF' sf1) dt a - -{- - psXAInv :: SF' a b -> (c -> d) -> SF' (a,c) (b,d) - psXAInv sf1 f2 = SF' tf True - where - tf dt ~(a, c) = sf1 `seq` (psXAInv sf1' f2, (b, f2 c)) - where - (sf1', b) = (sfTF' sf1) dt a --} - - --- !!! Hmmm. Why don't we optimize the FDE cases here??? --- !!! Seems pretty obvious that we should! --- !!! It should also be possible to optimize an event processor in --- !!! parallel with another event processor or an Arr FDE. - -parFanOutPrim :: SF a b -> SF a c -> SF a (b, c) -parFanOutPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0} - where - tf0 a0 = (pfoXX sf1 sf2, (b0, c0)) - where - (sf1, b0) = tf10 a0 - (sf2, c0) = tf20 a0 - - -- Naming convention: pfo where and is one of: - -- X - arbitrary signal function - -- A - arbitrary pure arrow - -- I - identity arrow - -- C - constant arrow - - pfoXX :: SF' a b -> SF' a c -> SF' a (b ,c) - pfoXX (SFArr _ fd1) (SFArr _ fd2) = sfArr(fdFanOut fd1 fd2) - pfoXX (SFArr _ FDI) sf2 = pfoIX sf2 - pfoXX (SFArr _ (FDC b)) sf2 = pfoCX b sf2 - pfoXX (SFArr _ fd1) sf2 = pfoAX (fdFun fd1) sf2 - pfoXX sf1 (SFArr _ FDI) = pfoXI sf1 - pfoXX sf1 (SFArr _ (FDC c)) = pfoXC sf1 c - pfoXX sf1 (SFArr _ fd2) = pfoXA sf1 (fdFun fd2) --- !!! Unclear if this really would be a gain --- !!! 2005-07-01: NOT a win for MEP 6. --- pfoXX (SFCpAXA _ fd11 sf12 fd13) (SFCpAXA _ fd21 sf22 fd23) = --- cpAXA (fdPar fd11 fd21) (psXX sf12 sf22) (fdPar fd13 fd23) - pfoXX sf1 sf2 = SF' tf -{- - if sfIsInv sf1 && sfIsInv sf2 then - pfoXXInv sf1 sf2 - else - SF' tf False --} - where - tf dt a = (pfoXX sf1' sf2', (b, c)) - where - (sf1', b) = (sfTF' sf1) dt a - (sf2', c) = (sfTF' sf2) dt a - -{- - pfoXXInv :: SF' a b -> SF' a c -> SF' a (b ,c) - pfoXXInv sf1 sf2 = SF' tf True - where - tf dt a = sf1 `seq` sf2 `seq` (pfoXXInv sf1' sf2', (b, c)) - where - (sf1', b) = (sfTF' sf1) dt a - (sf2', c) = (sfTF' sf2) dt a --} - - pfoIX :: SF' a c -> SF' a (a ,c) - pfoIX (SFArr _ fd2) = sfArr (fdFanOut FDI fd2) - pfoIX sf2 = SF' tf -{- - if sfIsInv sf2 then - pfoIXInv sf2 - else - SF' tf False --} - where - tf dt a = (pfoIX sf2', (a, c)) - where - (sf2', c) = (sfTF' sf2) dt a - -{- - pfoIXInv :: SF' a c -> SF' a (a ,c) - pfoIXInv sf2 = SF' tf True - where - tf dt a = sf2 `seq` (pfoIXInv sf2', (a, c)) - where - (sf2', c) = (sfTF' sf2) dt a --} - - pfoXI :: SF' a b -> SF' a (b ,a) - pfoXI (SFArr _ fd1) = sfArr (fdFanOut fd1 FDI) - pfoXI sf1 = SF' tf -{- - if sfIsInv sf1 then - pfoXIInv sf1 - else - SF' tf False --} - where - tf dt a = (pfoXI sf1', (b, a)) - where - (sf1', b) = (sfTF' sf1) dt a - -{- - pfoXIInv :: SF' a b -> SF' a (b ,a) - pfoXIInv sf1 = SF' tf True - where - tf dt a = sf1 `seq` (pfoXIInv sf1', (b, a)) - where - (sf1', b) = (sfTF' sf1) dt a --} - - pfoCX :: b -> SF' a c -> SF' a (b ,c) - pfoCX b (SFArr _ fd2) = sfArr (fdFanOut (FDC b) fd2) - pfoCX b sf2 = SF' tf -{- - if sfIsInv sf2 then - pfoCXInv b sf2 - else - SF' tf False --} - where - tf dt a = (pfoCX b sf2', (b, c)) - where - (sf2', c) = (sfTF' sf2) dt a - -{- - pfoCXInv :: b -> SF' a c -> SF' a (b ,c) - pfoCXInv b sf2 = SF' tf True - where - tf dt a = sf2 `seq` (pfoCXInv b sf2', (b, c)) - where - (sf2', c) = (sfTF' sf2) dt a --} - - pfoXC :: SF' a b -> c -> SF' a (b ,c) - pfoXC (SFArr _ fd1) c = sfArr (fdFanOut fd1 (FDC c)) - pfoXC sf1 c = SF' tf -{- - if sfIsInv sf1 then - pfoXCInv sf1 c - else - SF' tf False --} - where - tf dt a = (pfoXC sf1' c, (b, c)) - where - (sf1', b) = (sfTF' sf1) dt a - -{- - pfoXCInv :: SF' a b -> c -> SF' a (b ,c) - pfoXCInv sf1 c = SF' tf True - where - tf dt a = sf1 `seq` (pfoXCInv sf1' c, (b, c)) - where - (sf1', b) = (sfTF' sf1) dt a --} - - pfoAX :: (a -> b) -> SF' a c -> SF' a (b ,c) - pfoAX f1 (SFArr _ fd2) = sfArr (fdFanOut (FDG f1) fd2) - pfoAX f1 sf2 = SF' tf -{- - if sfIsInv sf2 then - pfoAXInv f1 sf2 - else - SF' tf False --} - where - tf dt a = (pfoAX f1 sf2', (f1 a, c)) - where - (sf2', c) = (sfTF' sf2) dt a - -{- - pfoAXInv :: (a -> b) -> SF' a c -> SF' a (b ,c) - pfoAXInv f1 sf2 = SF' tf True - where - tf dt a = sf2 `seq` (pfoAXInv f1 sf2', (f1 a, c)) - where - (sf2', c) = (sfTF' sf2) dt a --} - - pfoXA :: SF' a b -> (a -> c) -> SF' a (b ,c) - pfoXA (SFArr _ fd1) f2 = sfArr (fdFanOut fd1 (FDG f2)) - pfoXA sf1 f2 = SF' tf -{- - if sfIsInv sf1 then - pfoXAInv sf1 f2 - else - SF' tf False --} - where - tf dt a = (pfoXA sf1' f2, (b, f2 a)) - where - (sf1', b) = (sfTF' sf1) dt a - -{- - pfoXAInv :: SF' a b -> (a -> c) -> SF' a (b ,c) - pfoXAInv sf1 f2 = SF' tf True - where - tf dt a = sf1 `seq` (pfoXAInv sf1' f2, (b, f2 a)) - where - (sf1', b) = (sfTF' sf1) dt a --} - - --- * ArrowLoop instance and implementation - -instance ArrowLoop SF where - loop = loopPrim - - -loopPrim :: SF (a,c) (b,c) -> SF a b -loopPrim (SF {sfTF = tf10}) = SF {sfTF = tf0} - where - tf0 a0 = (loopAux sf1, b0) - where - (sf1, (b0, c0)) = tf10 (a0, c0) - - loopAux :: SF' (a,c) (b,c) -> SF' a b - loopAux (SFArr _ FDI) = sfId - loopAux (SFArr _ (FDC (b, _))) = sfConst b - loopAux (SFArr _ fd1) = - sfArrG (\a -> let (b,c) = (fdFun fd1) (a,c) in b) - loopAux sf1 = SF' tf -{- - if sfIsInv sf1 then - loopInv sf1 - else - SF' tf False --} - where - tf dt a = (loopAux sf1', b) - where - (sf1', (b, c)) = (sfTF' sf1) dt (a, c) - -{- - loopInv :: SF' (a,c) (b,c) -> SF' a b - loopInv sf1 = SF' tf True - where - tf dt a = sf1 `seq` (loopInv sf1', b) - where - (sf1', (b, c)) = (sfTF' sf1) dt (a, c) --} - --- * Scanning --- -sfSScan :: (c -> a -> Maybe (c, b)) -> c -> b -> SF' a b -sfSScan f c b = sf - where - sf = SFSScan tf f c b - tf _ a = case f c a of - Nothing -> (sf, b) - Just (c', b') -> (sfSScan f c' b', b') - --- Vim modeline --- vim:set tabstop=8 expandtab: +{-# 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: +-- +-- +-- +-- 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 where and is one of: +-- X - arbitrary signal function +-- A - arbitrary pure arrow +-- C - constant arrow +-- E - event-processing arrow +-- G - arrow known not to be identity, constant (C) or +-- event-processing (E). + +cpXX :: SF' a b -> SF' b c -> SF' a c +cpXX (SFArr _ fd1) sf2 = cpAX fd1 sf2 +cpXX sf1 (SFArr _ fd2) = cpXA sf1 fd2 +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 where and is one of: + -- X - arbitrary signal function + -- A - arbitrary pure arrow + -- C - constant arrow + + psXX :: SF' a b -> SF' c d -> SF' (a, c) (b, d) + psXX (SFArr _ fd1) (SFArr _ fd2) = sfArr (fdPar fd1 fd2) + psXX (SFArr _ FDI) sf2 = spAux sf2 -- New + psXX (SFArr _ (FDC b)) sf2 = psCX b sf2 + psXX (SFArr _ fd1) sf2 = psAX (fdFun fd1) sf2 + psXX sf1 (SFArr _ FDI) = fpAux sf1 -- New + psXX sf1 (SFArr _ (FDC d)) = psXC sf1 d + psXX sf1 (SFArr _ fd2) = psXA sf1 (fdFun fd2) + 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 where and is one of: + -- X - arbitrary signal function + -- A - arbitrary pure arrow + -- I - identity arrow + -- C - constant arrow + + pfoXX :: SF' a b -> SF' a c -> SF' a (b, c) + pfoXX (SFArr _ fd1) (SFArr _ fd2) = sfArr(fdFanOut fd1 fd2) + pfoXX (SFArr _ FDI) sf2 = pfoIX sf2 + pfoXX (SFArr _ (FDC b)) sf2 = pfoCX b sf2 + pfoXX (SFArr _ fd1) sf2 = pfoAX (fdFun fd1) sf2 + pfoXX sf1 (SFArr _ FDI) = pfoXI sf1 + pfoXX sf1 (SFArr _ (FDC c)) = pfoXC sf1 c + pfoXX sf1 (SFArr _ fd2) = pfoXA sf1 (fdFun fd2) + 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') diff --git a/src/FRP/Yampa/Internals.hs b/src/FRP/Yampa/Internals.hs deleted file mode 100644 --- a/src/FRP/Yampa/Internals.hs +++ /dev/null @@ -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 diff --git a/src/FRP/Yampa/Loop.hs b/src/FRP/Yampa/Loop.hs --- a/src/FRP/Yampa/Loop.hs +++ b/src/FRP/Yampa/Loop.hs @@ -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: diff --git a/src/FRP/Yampa/MergeableRecord.hs b/src/FRP/Yampa/MergeableRecord.hs deleted file mode 100644 --- a/src/FRP/Yampa/MergeableRecord.hs +++ /dev/null @@ -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 = setL1 vN ~+~ foo --- let fooFinal = mrFinalize foo --- @ ------------------------------------------------------------------------------------------ - -module FRP.Yampa.MergeableRecord ( - MergeableRecord(..), - MR, -- Abstract - mrMake, - (~+~), - mrMerge, - mrFinalize -) where - -class MergeableRecord a where - mrDefault :: a - - --- Type constructor for mergeable records. -newtype MR a = MR (a -> a) - - --- Construction of a mergeable record. -mrMake :: MergeableRecord a => (a -> a) -> MR a -mrMake f = (MR f) - - --- Merge two mergeable records. Left "overrides" in case of conflict. -(~+~) :: MergeableRecord a => MR a -> MR a -> MR a -(MR f1) ~+~ (MR f2) = MR (f1 . f2) - -mrMerge :: MergeableRecord a => MR a -> MR a -> MR a -mrMerge = (~+~) - - --- Finalization: turn a mergeable record into a record. -mrFinalize :: MergeableRecord a => MR a -> a -mrFinalize (MR f) = f mrDefault diff --git a/src/FRP/Yampa/Miscellany.hs b/src/FRP/Yampa/Miscellany.hs deleted file mode 100644 --- a/src/FRP/Yampa/Miscellany.hs +++ /dev/null @@ -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 ($) diff --git a/src/FRP/Yampa/Point2.hs b/src/FRP/Yampa/Point2.hs deleted file mode 100644 --- a/src/FRP/Yampa/Point2.hs +++ /dev/null @@ -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 diff --git a/src/FRP/Yampa/Point3.hs b/src/FRP/Yampa/Point3.hs deleted file mode 100644 --- a/src/FRP/Yampa/Point3.hs +++ /dev/null @@ -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 diff --git a/src/FRP/Yampa/Random.hs b/src/FRP/Yampa/Random.hs --- a/src/FRP/Yampa/Random.hs +++ b/src/FRP/Yampa/Random.hs @@ -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. diff --git a/src/FRP/Yampa/Scan.hs b/src/FRP/Yampa/Scan.hs --- a/src/FRP/Yampa/Scan.hs +++ b/src/FRP/Yampa/Scan.hs @@ -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') diff --git a/src/FRP/Yampa/Simulation.hs b/src/FRP/Yampa/Simulation.hs --- a/src/FRP/Yampa/Simulation.hs +++ b/src/FRP/Yampa/Simulation.hs @@ -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 diff --git a/src/FRP/Yampa/Switches.hs b/src/FRP/Yampa/Switches.hs --- a/src/FRP/Yampa/Switches.hs +++ b/src/FRP/Yampa/Switches.hs @@ -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 for more --- information on how this switch works. - --- !!! Suboptimal. Overall, the constructor is invarying since rSwitch is --- !!! being invoked recursively on a switch. In fact, we don't even care --- !!! whether the subordinate signal function is invarying or not. --- !!! We could make use of a signal function transformer sfInv to --- !!! mark the constructor as invarying. Would that make sense? --- !!! The price would be an extra loop with case analysis. --- !!! The potential gain is fewer case analyses in superior loops. -rSwitch :: SF a b -> SF (a, Event (SF a b)) b -rSwitch sf = switch (first sf) ((noEventSnd >=-) . rSwitch) - -{- --- Old version. New is more efficient. Which one is clearer? -rSwitch :: SF a b -> SF (a, Event (SF a b)) b -rSwitch sf = switch (first sf) rSwitch' - where - rSwitch' sf = switch (sf *** notYet) rSwitch' --} - - --- | Recurring switch with delayed observation. --- --- See for more --- information on how this switch works. -drSwitch :: SF a b -> SF (a, Event (SF a b)) b -drSwitch sf = dSwitch (first sf) ((noEventSnd >=-) . drSwitch) - -{- --- Old version. New is more efficient. Which one is clearer? -drSwitch :: SF a b -> SF (a, Event (SF a b)) b -drSwitch sf = dSwitch (first sf) drSwitch' - where - drSwitch' sf = dSwitch (sf *** notYet) drSwitch' --} - - --- | "Call-with-current-continuation" switch. --- --- See for more --- information on how this switch works. - --- !!! Has not been optimized properly. --- !!! Nor has opts been tested! --- !!! Don't forget Inv opts! -kSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b -kSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0} - where - tf0 a0 = - let (sf1, b0) = tf10 a0 - in - case tfe0 (a0, b0) of - (sfe, NoEvent) -> (kSwitchAux sf1 sfe, b0) - (_, Event c0) -> sfTF (k sf10 c0) a0 - --- Same problem as above: must pass k explicitly??? --- kSwitchAux (SFId _) sfe = kSwitchAuxI1 sfe - kSwitchAux (SFArr _ (FDC b)) sfe = kSwitchAuxC1 b sfe - kSwitchAux (SFArr _ fd1) sfe = kSwitchAuxA1 (fdFun fd1) sfe - -- kSwitchAux (SFArrE _ f1) sfe = kSwitchAuxA1 f1 sfe - -- kSwitchAux (SFArrEE _ f1) sfe = kSwitchAuxA1 f1 sfe - kSwitchAux sf1 (SFArr _ (FDC NoEvent)) = sf1 - kSwitchAux sf1 (SFArr _ fde) = kSwitchAuxAE sf1 (fdFun fde) - -- kSwitchAux sf1 (SFArrE _ fe) = kSwitchAuxAE sf1 fe - -- kSwitchAux sf1 (SFArrEE _ fe) = kSwitchAuxAE sf1 fe - kSwitchAux sf1 sfe = SF' tf -- False - where - tf dt a = - let (sf1', b) = (sfTF' sf1) dt a - in - case (sfTF' sfe) dt (a, b) of - (sfe', NoEvent) -> (kSwitchAux sf1' sfe', b) - (_, Event c) -> sfTF (k (freeze sf1 dt) c) a - -{- --- !!! Untested optimization! - kSwitchAuxI1 (SFConst _ NoEvent) = sfId - kSwitchAuxI1 (SFArr _ fe) = kSwitchAuxI1AE fe - kSwitchAuxI1 sfe = SF' tf - where - tf dt a = - case (sfTF' sfe) dt (a, a) of - (sfe', NoEvent) -> (kSwitchAuxI1 sfe', a) - (_, Event c) -> sfTF (k identity c) a --} - --- !!! Untested optimization! - kSwitchAuxC1 b (SFArr _ (FDC NoEvent)) = sfConst b - kSwitchAuxC1 b (SFArr _ fde) = kSwitchAuxC1AE b (fdFun fde) - -- kSwitchAuxC1 b (SFArrE _ fe) = kSwitchAuxC1AE b fe - -- kSwitchAuxC1 b (SFArrEE _ fe) = kSwitchAuxC1AE b fe - kSwitchAuxC1 b sfe = SF' tf -- False - where - tf dt a = - case (sfTF' sfe) dt (a, b) of - (sfe', NoEvent) -> (kSwitchAuxC1 b sfe', b) - (_, Event c) -> sfTF (k (constant b) c) a - --- !!! Untested optimization! - kSwitchAuxA1 f1 (SFArr _ (FDC NoEvent)) = sfArrG f1 - kSwitchAuxA1 f1 (SFArr _ fde) = kSwitchAuxA1AE f1 (fdFun fde) - -- kSwitchAuxA1 f1 (SFArrE _ fe) = kSwitchAuxA1AE f1 fe - -- kSwitchAuxA1 f1 (SFArrEE _ fe) = kSwitchAuxA1AE f1 fe - kSwitchAuxA1 f1 sfe = SF' tf -- False - where - tf dt a = - let b = f1 a - in - case (sfTF' sfe) dt (a, b) of - (sfe', NoEvent) -> (kSwitchAuxA1 f1 sfe', b) - (_, Event c) -> sfTF (k (arr f1) c) a - - -- !!! Untested optimization! - -- kSwitchAuxAE (SFId _) fe = kSwitchAuxI1AE fe - kSwitchAuxAE (SFArr _ (FDC b)) fe = kSwitchAuxC1AE b fe - kSwitchAuxAE (SFArr _ fd1) fe = kSwitchAuxA1AE (fdFun fd1) fe - -- kSwitchAuxAE (SFArrE _ f1) fe = kSwitchAuxA1AE f1 fe - -- kSwitchAuxAE (SFArrEE _ f1) fe = kSwitchAuxA1AE f1 fe - kSwitchAuxAE sf1 fe = SF' tf -- False - where - tf dt a = - let (sf1', b) = (sfTF' sf1) dt a - in - case fe (a, b) of - NoEvent -> (kSwitchAuxAE sf1' fe, b) - Event c -> sfTF (k (freeze sf1 dt) c) a - -{- --- !!! Untested optimization! - kSwitchAuxI1AE fe = SF' tf -- False - where - tf dt a = - case fe (a, a) of - NoEvent -> (kSwitchAuxI1AE fe, a) - Event c -> sfTF (k identity c) a --} - --- !!! Untested optimization! - kSwitchAuxC1AE b fe = SF' tf -- False - where - tf _ a = - case fe (a, b) of - NoEvent -> (kSwitchAuxC1AE b fe, b) - Event c -> sfTF (k (constant b) c) a - --- !!! Untested optimization! - kSwitchAuxA1AE f1 fe = SF' tf -- False - where - tf _ a = - let b = f1 a - in - case fe (a, b) of - NoEvent -> (kSwitchAuxA1AE f1 fe, b) - Event c -> sfTF (k (arr f1) c) a - - --- | 'kSwitch' with delayed observation. --- --- See for more --- information on how this switch works. - --- !!! Has not been optimized properly. Should be like kSwitch. -dkSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b -dkSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0} - where - tf0 a0 = - let (sf1, b0) = tf10 a0 - in (case tfe0 (a0, b0) of - (sfe, NoEvent) -> dkSwitchAux sf1 sfe - (_, Event c0) -> fst (sfTF (k sf10 c0) a0), - b0) - - dkSwitchAux sf1 (SFArr _ (FDC NoEvent)) = sf1 - dkSwitchAux sf1 sfe = SF' tf -- False - where - tf dt a = - let (sf1', b) = (sfTF' sf1) dt a - in (case (sfTF' sfe) dt (a, b) of - (sfe', NoEvent) -> dkSwitchAux sf1' sfe' - (_, Event c) -> fst (sfTF (k (freeze sf1 dt) c) a), - b) - - ------------------------------------------------------------------------------- --- Parallel composition and switching over collections with broadcasting ------------------------------------------------------------------------------- - --- | Tuple a value up with every element of a collection of signal --- functions. -broadcast :: Functor col => a -> col sf -> col (a, sf) -broadcast a = fmap (\sf -> (a, sf)) - - --- !!! Hmm. We should really optimize here. --- !!! Check for Arr in parallel! --- !!! Check for Arr FDE in parallel!!! --- !!! Check for EP in parallel!!!!! --- !!! Cf &&&. --- !!! But how??? All we know is that the collection is a functor ... --- !!! Maybe that kind of generality does not make much sense for --- !!! par and parB? (Although it is niceto be able to switch into a --- !!! par or parB from within a pSwitch[B].) --- !!! If we had a parBList, that could be defined in terms of &&&, surely? --- !!! E.g. --- !!! parBList [] = constant [] --- !!! parBList (sf:sfs) = sf &&& parBList sfs >>> arr (\(x,xs) -> x:xs) --- !!! --- !!! This ought to optimize quite well. E.g. --- !!! parBList [arr1,arr2,arr3] --- !!! = arr1 &&& parBList [arr2,arr3] >>> arrX --- !!! = arr1 &&& (arr2 &&& parBList [arr3] >>> arrX) >>> arrX --- !!! = arr1 &&& (arr2 &&& (arr3 &&& parBList [] >>> arrX) >>> arrX) >>> arrX --- !!! = arr1 &&& (arr2 &&& (arr3C >>> arrX) >>> arrX) >>> arrX --- !!! = arr1 &&& (arr2 &&& (arr3CcpX) >>> arrX) >>> arrX --- !!! = arr1 &&& (arr23CcpX >>> arrX) >>> arrX --- !!! = arr1 &&& (arr23CcpXcpX) >>> arrX --- !!! = arr123CcpXcpXcpX - --- | Spatial parallel composition of a signal function collection. --- Given a collection of signal functions, it returns a signal --- function that 'broadcast's its input signal to every element --- of the collection, to return a signal carrying a collection --- of outputs. See 'par'. --- --- For more information on how parallel composition works, check --- -parB :: Functor col => col (SF a b) -> SF a (col b) -parB = par broadcast - --- | Parallel switch (dynamic collection of signal functions spatially composed --- in parallel). See 'pSwitch'. --- --- For more information on how parallel composition works, check --- -pSwitchB :: Functor col => - col (SF a b) -> SF (a,col b) (Event c) -> (col (SF a b)->c-> SF a (col b)) - -> SF a (col b) -pSwitchB = pSwitch broadcast - --- | Delayed parallel switch with broadcasting (dynamic collection of --- signal functions spatially composed in parallel). See 'dpSwitch'. --- --- For more information on how parallel composition works, check --- -dpSwitchB :: Functor col => - col (SF a b) -> SF (a,col b) (Event c) -> (col (SF a b)->c->SF a (col b)) - -> SF a (col b) -dpSwitchB = dpSwitch broadcast - --- For more information on how parallel composition works, check --- -rpSwitchB :: Functor col => - col (SF a b) -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b) -rpSwitchB = rpSwitch broadcast - --- For more information on how parallel composition works, check --- -drpSwitchB :: Functor col => - col (SF a b) -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b) -drpSwitchB = drpSwitch broadcast - - ------------------------------------------------------------------------------- --- Parallel composition and switching over collections with general routing ------------------------------------------------------------------------------- - --- | Spatial parallel composition of a signal function collection parameterized --- on the routing function. --- -par :: Functor col => - (forall sf . (a -> col sf -> col (b, sf))) -- ^ Determines the input to each signal function - -- in the collection. IMPORTANT! The routing function MUST - -- preserve the structure of the signal function collection. - - -> col (SF b c) -- ^ Signal function collection. - -> SF a (col c) -par rf sfs0 = SF {sfTF = tf0} - where - tf0 a0 = - let bsfs0 = rf a0 sfs0 - sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0 - sfs = fmap fst sfcs0 - cs0 = fmap snd sfcs0 - in - (parAux rf sfs, cs0) - - --- Internal definition. Also used in parallel 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 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 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 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 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 +-- +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 +-- +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 +-- +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 +-- +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 +-- +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 +-- +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 +-- +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 +-- +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 +-- +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 diff --git a/src/FRP/Yampa/Task.hs b/src/FRP/Yampa/Task.hs --- a/src/FRP/Yampa/Task.hs +++ b/src/FRP/Yampa/Task.hs @@ -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)) diff --git a/src/FRP/Yampa/Time.hs b/src/FRP/Yampa/Time.hs --- a/src/FRP/Yampa/Time.hs +++ b/src/FRP/Yampa/Time.hs @@ -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: diff --git a/src/FRP/Yampa/Utilities.hs b/src/FRP/Yampa/Utilities.hs deleted file mode 100644 --- a/src/FRP/Yampa/Utilities.hs +++ /dev/null @@ -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 diff --git a/src/FRP/Yampa/Vector2.hs b/src/FRP/Yampa/Vector2.hs deleted file mode 100644 --- a/src/FRP/Yampa/Vector2.hs +++ /dev/null @@ -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 diff --git a/src/FRP/Yampa/Vector3.hs b/src/FRP/Yampa/Vector3.hs deleted file mode 100644 --- a/src/FRP/Yampa/Vector3.hs +++ /dev/null @@ -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 diff --git a/src/FRP/Yampa/VectorSpace.hs b/src/FRP/Yampa/VectorSpace.hs deleted file mode 100644 --- a/src/FRP/Yampa/VectorSpace.hs +++ /dev/null @@ -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 diff --git a/tests/AFRPTests.hs b/tests/AFRPTests.hs deleted file mode 100644 --- a/tests/AFRPTests.hs +++ /dev/null @@ -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) - - - diff --git a/tests/AFRPTestsAccum.hs b/tests/AFRPTestsAccum.hs deleted file mode 100644 --- a/tests/AFRPTestsAccum.hs +++ /dev/null @@ -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 diff --git a/tests/AFRPTestsArr.hs b/tests/AFRPTestsArr.hs deleted file mode 100644 --- a/tests/AFRPTestsArr.hs +++ /dev/null @@ -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 diff --git a/tests/AFRPTestsBasicSF.hs b/tests/AFRPTestsBasicSF.hs deleted file mode 100644 --- a/tests/AFRPTestsBasicSF.hs +++ /dev/null @@ -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 diff --git a/tests/AFRPTestsCOC.hs b/tests/AFRPTestsCOC.hs deleted file mode 100644 --- a/tests/AFRPTestsCOC.hs +++ /dev/null @@ -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 diff --git a/tests/AFRPTestsCommon.hs b/tests/AFRPTestsCommon.hs deleted file mode 100644 --- a/tests/AFRPTestsCommon.hs +++ /dev/null @@ -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) diff --git a/tests/AFRPTestsComp.hs b/tests/AFRPTestsComp.hs deleted file mode 100644 --- a/tests/AFRPTestsComp.hs +++ /dev/null @@ -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 diff --git a/tests/AFRPTestsDelay.hs b/tests/AFRPTestsDelay.hs deleted file mode 100644 --- a/tests/AFRPTestsDelay.hs +++ /dev/null @@ -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 diff --git a/tests/AFRPTestsDer.hs b/tests/AFRPTestsDer.hs deleted file mode 100644 --- a/tests/AFRPTestsDer.hs +++ /dev/null @@ -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 diff --git a/tests/AFRPTestsEmbed.hs b/tests/AFRPTestsEmbed.hs deleted file mode 100644 --- a/tests/AFRPTestsEmbed.hs +++ /dev/null @@ -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 diff --git a/tests/AFRPTestsEvSrc.hs b/tests/AFRPTestsEvSrc.hs deleted file mode 100644 --- a/tests/AFRPTestsEvSrc.hs +++ /dev/null @@ -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 diff --git a/tests/AFRPTestsFirstSecond.hs b/tests/AFRPTestsFirstSecond.hs deleted file mode 100644 --- a/tests/AFRPTestsFirstSecond.hs +++ /dev/null @@ -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 diff --git a/tests/AFRPTestsKSwitch.hs b/tests/AFRPTestsKSwitch.hs deleted file mode 100644 --- a/tests/AFRPTestsKSwitch.hs +++ /dev/null @@ -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 diff --git a/tests/AFRPTestsLaws.hs b/tests/AFRPTestsLaws.hs deleted file mode 100644 --- a/tests/AFRPTestsLaws.hs +++ /dev/null @@ -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 diff --git a/tests/AFRPTestsLoop.hs b/tests/AFRPTestsLoop.hs deleted file mode 100644 --- a/tests/AFRPTestsLoop.hs +++ /dev/null @@ -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 diff --git a/tests/AFRPTestsLoopIntegral.hs b/tests/AFRPTestsLoopIntegral.hs deleted file mode 100644 --- a/tests/AFRPTestsLoopIntegral.hs +++ /dev/null @@ -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 diff --git a/tests/AFRPTestsLoopLaws.hs b/tests/AFRPTestsLoopLaws.hs deleted file mode 100644 --- a/tests/AFRPTestsLoopLaws.hs +++ /dev/null @@ -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 diff --git a/tests/AFRPTestsLoopPre.hs b/tests/AFRPTestsLoopPre.hs deleted file mode 100644 --- a/tests/AFRPTestsLoopPre.hs +++ /dev/null @@ -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 diff --git a/tests/AFRPTestsPSwitch.hs b/tests/AFRPTestsPSwitch.hs deleted file mode 100644 --- a/tests/AFRPTestsPSwitch.hs +++ /dev/null @@ -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) diff --git a/tests/AFRPTestsPre.hs b/tests/AFRPTestsPre.hs deleted file mode 100644 --- a/tests/AFRPTestsPre.hs +++ /dev/null @@ -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 diff --git a/tests/AFRPTestsRPSwitch.hs b/tests/AFRPTestsRPSwitch.hs deleted file mode 100644 --- a/tests/AFRPTestsRPSwitch.hs +++ /dev/null @@ -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] diff --git a/tests/AFRPTestsRSwitch.hs b/tests/AFRPTestsRSwitch.hs deleted file mode 100644 --- a/tests/AFRPTestsRSwitch.hs +++ /dev/null @@ -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 diff --git a/tests/AFRPTestsReact.hs b/tests/AFRPTestsReact.hs deleted file mode 100644 --- a/tests/AFRPTestsReact.hs +++ /dev/null @@ -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 diff --git a/tests/AFRPTestsSscan.hs b/tests/AFRPTestsSscan.hs deleted file mode 100644 --- a/tests/AFRPTestsSscan.hs +++ /dev/null @@ -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 diff --git a/tests/AFRPTestsSwitch.hs b/tests/AFRPTestsSwitch.hs deleted file mode 100644 --- a/tests/AFRPTestsSwitch.hs +++ /dev/null @@ -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 - diff --git a/tests/AFRPTestsTask.hs b/tests/AFRPTestsTask.hs deleted file mode 100644 --- a/tests/AFRPTestsTask.hs +++ /dev/null @@ -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 diff --git a/tests/AFRPTestsUtils.hs b/tests/AFRPTestsUtils.hs deleted file mode 100644 --- a/tests/AFRPTestsUtils.hs +++ /dev/null @@ -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 diff --git a/tests/AFRPTestsWFG.hs b/tests/AFRPTestsWFG.hs deleted file mode 100644 --- a/tests/AFRPTestsWFG.hs +++ /dev/null @@ -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 diff --git a/tests/HaddockCoverage.hs b/tests/HaddockCoverage.hs --- a/tests/HaddockCoverage.hs +++ b/tests/HaddockCoverage.hs @@ -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) diff --git a/tests/hlint.hs b/tests/hlint.hs --- a/tests/hlint.hs +++ b/tests/hlint.hs @@ -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 diff --git a/tests/testAFRPMain.hs b/tests/testAFRPMain.hs deleted file mode 100644 --- a/tests/testAFRPMain.hs +++ /dev/null @@ -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 - -