Yampa 0.14.2 → 0.14.3
raw patch · 20 files changed
+1367/−1250 lines, 20 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG +163/−149
- Yampa.cabal +1/−1
- src/FRP/Yampa.hs +12/−10
- src/FRP/Yampa/Arrow.hs +17/−16
- src/FRP/Yampa/Basic.hs +22/−24
- src/FRP/Yampa/Conditional.hs +48/−41
- src/FRP/Yampa/Delays.hs +44/−45
- src/FRP/Yampa/Diagnostics.hs +15/−11
- src/FRP/Yampa/Event.hs +81/−41
- src/FRP/Yampa/EventS.hs +106/−104
- src/FRP/Yampa/Hybrid.hs +50/−52
- src/FRP/Yampa/Integration.hs +44/−40
- src/FRP/Yampa/InternalCore.hs +253/−217
- src/FRP/Yampa/Loop.hs +21/−20
- src/FRP/Yampa/Random.hs +29/−29
- src/FRP/Yampa/Scan.hs +26/−23
- src/FRP/Yampa/Simulation.hs +78/−76
- src/FRP/Yampa/Switches.hs +310/−311
- src/FRP/Yampa/Task.hs +33/−28
- src/FRP/Yampa/Time.hs +14/−12
CHANGELOG view
@@ -1,217 +1,231 @@+2023-06-07 Ivan Perez <ivan.perez@keera.co.uk>+ * Version bump (0.14.3) (#269).+ * Improve readability of CHANGELOGs (#261).+ * Conformance with style guide (#266).+ * Reflect new contribution process in README (#265).+ 2023-04-07 Ivan Perez <ivan.perez@keera.co.uk>- * Yampa.cabal: Version bump (0.14.2) (#259).- * src/: Conformance with style guide (#255).- * examples/: Conformance with style guide (#255), move example to- yampa-test library (#257).- * README: Add game to list of games and apps in README (#254).+ * Version bump (0.14.2) (#259).+ * Conformance with style guide (#255).+ * Move example to yampa-test library (#257).+ * Add game to list of games and apps in README (#254). 2023-02-07 Ivan Perez <ivan.perez@keera.co.uk>- * Yampa.cabal: Version bump (0.14.1) (#251).- * src/: Replace broken links (#253), fix typo (#252).+ * Version bump (0.14.1) (#251).+ * Replace broken links (#253).+ * Fix typo (#252). 2022-12-07 Ivan Perez <ivan.perez@keera.co.uk>- * Yampa.cabal: Version bump (0.14) (#242), bump version bounds of- dependency (#241).- * src/: Adjust to work with simple-affine-space-0.2 (#241).+ * Version bump (0.14) (#242).+ * Adjust to work with simple-affine-space-0.2 (#241). 2022-10-07 Ivan Perez <ivan.perez@keera.co.uk>- * Yampa.cabal: Version bump (0.13.7) (#238), add version bounds to- dependencies (#233).- * LICENSE: Update years, copyright holders (#235).- * src/: Update years, copyright holders (#235).- * .travis.yml: Update distribution to bionic (#236).+ * Version bump (0.13.7) (#238).+ * Add version bounds to dependencies (#233).+ * Update years, copyright holders (#235).+ * Update distribution to bionic (#236). 2022-08-07 Ivan Perez <ivan.perez@haskell.sexy>- * Yampa.cabal: Version bump (0.13.6) (#232).- * src/: Fix typos in documentation (#224), replace AFRP with Yampa- (#223), simplify implementation of mapFilterE (#221).- * README: Re-structure README, add content, TOC (#227), fix typo- (#230).- * Replace funding link (#231).- * Thanks to @architsinghal-mriirs.+ * Version bump (0.13.6) (#232).+ * Fix typos in documentation (#224).+ * Replace AFRP with Yampa (#223).+ * Simplify implementation of mapFilterE (#221).+ * Re-structure README, add content, TOC (#227).+ * Fix typo (#230).+ * Replace funding link (#231).+ * Thanks to @architsinghal-mriirs. 2022-06-07 Ivan Perez <ivan.perez@haskell.sexy>- * Yampa.cabal: Version bump (0.13.5) (#220).- * src/: Remove vim modeline settings (#209), remove unnecessary- comments from module export lists (#210), style consistency of- separators (#211), adjust format of export lists (#212), align- lists, tuples, records by leading comma (#213), compress multiple- empty lines (#214), adjust indentation to two spaces (#215), make- arrows less prominent in descriptions (#183), remove unnecessary- import (#222).- * examples/: Replace tabs with spaces (#205), format module header to- conform to style guide (#207), style consistency of separators- (#211), adjust format of export lists (#212), align lists, tuples,- records by leading comma (#213), compress multiple empty lines- (#214), adjust indentation to two spaces (#215).- * tests/: Style consistency of separators (#211).- * README: make arrows less prominent in descriptions (#183).+ * Version bump (0.13.5) (#220).+ * Remove vim modeline settings (#209).+ * Remove unnecessary comments from module export lists (#210).+ * Style consistency of separators (#211).+ * Adjust format of export lists (#212).+ * Align lists, tuples, records by leading comma (#213).+ * Compress multiple empty lines (#214).+ * Adjust indentation to two spaces (#215).+ * Make arrows less prominent in descriptions (#183).+ * Remove unnecessary import (#222).+ * Replace tabs with spaces (#205).+ * Format module header to conform to style guide (#207). 2022-04-07 Ivan Perez <ivan.perez@haskell.sexy>- * Yampa.cabal: Version bump (0.13.4) (#203), syntax rules (#196),- remove regression tests (#201).- * src/: Remove unused extensions (#199), syntax rules (#200), remove- commented code and notes (#202).- * tests/: Rename tests (#195), remove regression tests (#201).- * README: Add new game (#197).+ * Version bump (0.13.4) (#203).+ * Syntax rules (#196).+ * Remove regression tests (#201).+ * Remove unused extensions (#199).+ * Syntax rules (#200).+ * Remove commented code and notes (#202).+ * Rename tests (#195).+ * Add new game (#197). 2021-10-07 Ivan Perez <ivan.perez@haskell.sexy>- * Yampa.cabal: Version bump (0.13.3) (#193), add modules missing from- other modules (#181).- * src/: Code cleaning and style fixes (#190, #191, #192).- * README.md: Restructure documentation (#184), fix installation- instructions (#186), add new games (#188), remove note (#189).+ * Version bump (0.13.3) (#193).+ * Add modules missing from other-modules in Cabal file (#181).+ * Limit line length to 80 characters (#190).+ * Standardize pragma style (#191).+ * Correct module/copyright info in haddock documentation (#192).+ * Restructure documentation in README (#184).+ * Fix installation instructions in README (#186).+ * Mention new games in README (#188).+ * Remove note from README (#189). 2021-09-15 Ivan Perez <ivan.perez@haskell.sexy>- * Yampa.cabal: Version bump (0.13.2), change cabal-version, add- default language (#180).- * src/: Update links (#179).- * README.md: Update installation instructions (#177), links (#178),- pointers to other projects (#162, #160, #153)- * .travis.yml: Enable testing haddock documentation (#72).- * tests/: Avoid modules whose documentation haddock does not generated- even if present (#72).- * src/: Minor adaptations to imports to make tests work (#72),- minor haddock documentation fixes (#175),- complete missing haddock documentation (#72).+ * Version bump (0.13.2), change cabal-version, add default language (#180).+ * Update links in Haddock (#179).+ * Update installation instructions in README (#177).+ * Update links in README (#178).+ * Update pointers to other projects in README (#162)+ * Update pointers to other projects in README (#160)+ * Update pointers to other projects in README (#153)+ * Enable testing haddock documentation in CI (#72).+ * Minor haddock documentation fixes (#175). 2019-10-15 Ivan Perez <ivan.perez@keera.co.uk>- * Yampa.cabal: Version bump (0.13.1), introduce examples- as executables, depend on fail if needed.- * README.md: Add Peoplemon.- * examples/: Fix errors due to module reorg.- * extensions/: Chnage testing to use tasty.- * .travis.yml: Compile with GHC8.8.- * src/: Support MonadFail proposal and GHC 8.8.- * Thanks to @sigrlami, @RyanGlScott and @CraigTreptow.+ * Version bump (0.13.1).+ * Introduce examples as executables in Cabal file.+ * Add Peoplemon to README.+ * Fix errors in examples due to module reorg.+ * Change testing extension to use tasty.+ * Compile with GHC8.8 in CI.+ * Support MonadFail proposal and GHC 8.8.+ * Thanks to @sigrlami, @RyanGlScott and @CraigTreptow. 2018-11-02 Ivan Perez <ivan.perez@keera.co.uk>- * Yampa.cabal: Version bump (0.13).- * README.md: Documents related projects.- * src/: Cleans API, removes deprecated constructs, moves- vector and points into separate library, hides Core,- eliminates Forceable and MergeableRecord, adds documentation.- * examples/: Adds Diagrams example.- * .travis.yml: Compile with GHC8.6 (allowing failures).+ * Version bump (0.13).+ * Document related projects.+ * Clean API, remove deprecated constructs, move vector and point into+ separate library, hide Core.+ * Eliminate Forceable and MergeableRecord.+ * Add documentation.+ * Add Diagrams example.+ * Compile with GHC8.6 in CI (allowing failures). 2018-10-21 Ivan Perez <ivan.perez@keera.co.uk>- * Yampa.cabal: Version bump (0.12).- * README.md: Documents testing.- * src/: Introduces FutureSF, needed for testing.- * extensions/test/: Introduces testing library.- * Thanks to @chriz-keera.+ * Version bump (0.12).+ * Document testing in README.+ * Introduce FutureSF, needed for testing.+ * Introduce testing library.+ * Thanks to @chriz-keera. 2018-08-11 Ivan Perez <ivan.perez@keera.co.uk>- * Yampa.cabal: Version bump (0.11.1).- * README.md: Documents papers.- * src/: Fixes leak.- * Thanks to @tresormuta, @chriz-keera.+ * Version bump (0.11.1).+ * Document papers in README.+ * Fix leak.+ * Thanks to @tresormuta, @chriz-keera. 2018-04-05 Ivan Perez <ivan.perez@keera.co.uk>- * Yampa.cabal: Version bump (0.11).- * src/: Adds documentation; makes type synonym a newtype.- * tests/: Removes deprecated import.- * .travis.yml: Tests on travis with GHC 7.6 to 8.4.- * Thanks to @ptvirgo, @thalerjonathan, @turion.+ * Version bump (0.11).+ * Add documentation; makes type synonym a newtype.+ * Remove deprecated import in tests.+ * Test on travis with GHC 7.6 to 8.4.+ * Thanks to @ptvirgo, @thalerjonathan, @turion. 2017-12-17 Ivan Perez <ivan.perez@keera.co.uk>- * Yampa.cabal: Version bump (0.10.7), adds flag to expose core,- adds flag descriptions, fixes missing modules.- * README.md: Adds images to descriptions.- * doc/: New HCAR including iOS release.- * src/: Exposes new function, removes unused extensions,- simplifies code, adds documentation, fixes multiple bugs.- * stack.yaml: Fixes nix setup.- * tests/: Adapts to new API.- * examples/: Adapts to new API.- * Thanks to @chriz-keera, @suzumiyasmith, @meimisaki,- @RyanGlScott, @madjestic, @mgttlinger, @eapcochran,- @jonmouchou.+ * Version bump (0.10.7).+ * Add flag to cabal file to expose core.+ * Add flag to descriptions.+ * Fix missing modules in cabal file.+ * Add images to descriptions in README.+ * New HCAR entry including iOS release.+ * Expose new function.+ * Remove unused extensions.+ * Simplify code.+ * Add documentation.+ * Fix multiple bugs.+ * Fix nix setup.+ * Adapt tests to new API.+ * Adapt examples to new API.+ * Thanks to @chriz-keera, @suzumiyasmith, @meimisaki, @RyanGlScott,+ @madjestic, @mgttlinger, @eapcochran, @jonmouchou. 2017-08-28 Ivan Perez <ivan.perez@keera.co.uk>- * Yampa.cabal: Version bump (0.10.6.2), fixes issue with dependencies.- * stack.yaml: Includes minimal stack configuration.+ * Version bump (0.10.6.2).+ * Fix issue with dependencies in Cabal file.+ * Include minimal stack configuration. 2017-08-17 Ivan Perez <ivan.perez@keera.co.uk>- * Yampa.cabal: Version bump (0.10.6.1).- * examples/: new examples, using wiimote.- * src/: Minor improvements to documentation.+ * Version bump (0.10.6.1).+ * New examples, using wiimote.+ * Minor improvements to documentation. 2017-05-05 Ivan Perez <ivan.perez@keera.co.uk>- * Yampa.cabal: Version bump (0.10.6).- * tests/: do not warn if they contain tabs.- * src/: Includes combinators to deal with collections,- to iterate over time (for custom/discrete integration),- implements ArrowChoice.+ * Version bump (0.10.6).+ * Do not warn if tests contain tabs.+ * Include combinators to deal with collections.+ * Include combinators to iterate over time (for custom/discrete+ integration).+ * Implement ArrowChoice. 2017-04-26 Ivan Perez <ivan.perez@keera.co.uk>- * .travis.yml: Instruct TravisCI upload package to hackage.- * Yampa.cabal: Version bump (0.10.5.1).+ * Version bump (0.10.5.1).+ * Instruct TravisCI upload package to hackage. 2016-05-23 Ivan Perez <ivan.perez@keera.co.uk>- * src/: Adds new -:> combinator.- * Yampa.cabal: Version bump (0.10.5).+ * Version bump (0.10.5).+ * Add new -:> combinator. 2015-11-14 Ivan Perez <ivan.perez@keera.co.uk>- * tests/: Include haddock. Regression tests now exit with proper exit- code.- * src/: Includes more documentation.- * Yampa.cabal: Include haddock and regression test suites.- Version bump (0.10.4).+ * Version bump (0.10.4).+ * Include haddock in tests.+ * Regression tests now exit with proper exit code.+ * Include more documentation.+ * Include haddock and regression test suites. 2015-10-02 Ivan Perez <ivan.perez@keera.co.uk>- * src/: Event instances of Applicative and Alternative.- * Yampa.cabal: Version bump (0.10.3).+ * Version bump (0.10.3).+ * Event instances of Applicative and Alternative. 2015-06-19 Ivan Perez <ivan.perez@keera.co.uk>- * src:/ instances of DeepSeq (see #5).- * Yampa.cabal: Deepseq added to dependencies. Version bump (0.10.2).+ * Version bump (0.10.2).+ * Instances of DeepSeq (#5). 2015-05-06 Ivan Perez <ivan.perez@keera.co.uk>- * Yampa.cabal: disables tests by default. Version bump (0.10.1.1).+ * Version bump (0.10.1.1).+ * Disable tests by default in Cabal file. 2015-05-05 Ivan Perez <ivan.perez@keera.co.uk>- * Yampa.cabal: exposes internal modules for documentation purposes.- Version bump (0.10.1)+ * Version bump (0.10.1).+ * Expose internal modules for documentation purposes. 2015-05-05 Ivan Perez <ivan.perez@keera.co.uk>- * src/: Reorders code. Marks modules as deprecated. Removes useless functions.- * Yampa.cabal: version bump (0.10.0)+ * Version bump (0.10.0).+ * Reorder code.+ * Mark modules as deprecated.+ * Remove useless functions. 2015-05-05 Ivan Perez <ivan.perez@keera.co.uk>- * src/FRP/Yampa.hs: documentation. Removes tabs.- * README.md: links to games, related projects, documentation.- * Yampa.cabal: version bump (0.9.7)+ * Version bump (0.9.7).+ * Documentation added to FRP.Yampa.+ * Remove tabs from FRP.Yampa.+ * Link to games, related projects, documentation in README. 2015-03-30 Ivan Perez <ivan.perez@keera.co.uk>- * src/FRP/Yampa/Task.hs: Adds Functor and Applicative instances,- for compatibility with base >= 4.8 (issue #7, pull request by- Ryan Scott).- * Yampa.cabal: version bump (0.9.6.1).+ * Version bump (0.9.6.1).+ * Add Functor and Applicative instances for Tasks for compatibility with+ base >= 4.8 (#7).+ * Thanks to Ryan Scott. 2015-03-04 Ivan Perez <ivan.perez@keera.co.uk>- * src/: Coding style improvements.+ * Coding style improvements. 2014-08-29 Ivan Perez <ivan.perez@keera.co.uk>-- * Yampa.cabal: version bump (0.9.6).- * src/: Adds a substantial amount of documentation.- * src/FRP/Yampa.hs: Adds a new pause combinator.+ * Version bump (0.9.6).+ * Add a substantial amount of documentation.+ * Add a new pause combinator. 2014-06-04 Ivan Perez <ivan.perez@keera.co.uk>-- * Adds project to hudson-backed continuous integration server.+ * Add project to hudson-backed continuous integration server. 2014-04-26 Ivan Perez <ivan.perez@keera.es>-- * Yampa.cabal: version bump (0.9.5).- * Adds CHANGELOG to cabal file.+ * Version bump (0.9.5).+ * Add CHANGELOG to cabal file. 2014-04-07 Ivan Perez <ivan.perez@keera.es>-- * Yampa.cabal: new maintainer, version bump (0.9.4).- * src/: documentation is exposed so that Haddock can process it.- * No interface changes.+ * Version bump (0.9.4).+ * New maintainer.+ * Documentation is exposed so that Haddock can process it.+ * No interface changes. Copyright (c) 2003, Henrik Nilsson, Antony Courtney and Yale University. All rights reserved.
Yampa.cabal view
@@ -30,7 +30,7 @@ build-type: Simple name: Yampa-version: 0.14.2+version: 0.14.3 author: Henrik Nilsson, Antony Courtney maintainer: Ivan Perez (ivan.perez@keera.co.uk) homepage: https://github.com/ivanperez-keera/Yampa/
src/FRP/Yampa.hs view
@@ -237,13 +237,13 @@ -- ** Parallel composition and switching -- *** Parallel composition and switching with broadcasting , parB- , pSwitchB,dpSwitchB- , rpSwitchB,drpSwitchB+ , pSwitchB, dpSwitchB+ , rpSwitchB, drpSwitchB -- *** Parallel composition and switching with general routing , par- , pSwitch, dpSwitch- , rpSwitch,drpSwitch+ , pSwitch, dpSwitch+ , rpSwitch, drpSwitch -- * Discrete to continuous-time signal functions -- ** Wave-form generation@@ -317,13 +317,18 @@ -- Reverse function composition and arrow plumbing aids , dup - -- Re-exported module, classes, and types+ -- * Re-exported module, classes, and types , module Control.Arrow , module Data.VectorSpace ) where -import FRP.Yampa.InternalCore+-- External modules+import Control.Arrow+import Data.VectorSpace++-- Internal modules+import FRP.Yampa.Arrow (dup) import FRP.Yampa.Basic import FRP.Yampa.Conditional import FRP.Yampa.Delays@@ -331,13 +336,10 @@ import FRP.Yampa.EventS import FRP.Yampa.Hybrid import FRP.Yampa.Integration+import FRP.Yampa.InternalCore import FRP.Yampa.Loop-import FRP.Yampa.Arrow (dup) import FRP.Yampa.Random import FRP.Yampa.Scan import FRP.Yampa.Simulation import FRP.Yampa.Switches import FRP.Yampa.Time--import Control.Arrow-import Data.VectorSpace
src/FRP/Yampa/Arrow.hs view
@@ -1,14 +1,14 @@ -- |--- 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)+-- 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+-- Maintainer : ivan.perez@keera.co.uk+-- Stability : provisional+-- Portability : portable -- -- Arrow helper functions. module FRP.Yampa.Arrow@@ -24,28 +24,29 @@ ) where -import Control.Arrow+-- External imports+import Control.Arrow (Arrow, arr) -- * Arrow plumbing aids -- | Duplicate an input.-dup :: a -> (a,a)-dup x = (x,x)+dup :: a -> (a, a)+dup x = (x, x) -- * Liftings --- | Lift a binary function onto an arrow+-- | Lift a binary function onto an arrow. arr2 :: Arrow a => (b -> c -> d) -> a (b, c) d arr2 = arr . uncurry --- | Lift a 3-ary function onto an arrow+-- | 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 --- | Lift a 4-ary function onto an arrow+-- | 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 --- | Lift a 5-ary function onto an arrow+-- | Lift a 5-ary function onto an arrow. arr5 :: Arrow a => (b -> c -> d -> e -> f -> g) -> a (b, c, d, e, f) g arr5 = arr . \h (b, c, d, e, f) -> h b c d e f
src/FRP/Yampa/Basic.hs view
@@ -1,14 +1,14 @@ -- |--- 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)+-- 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)+-- Maintainer : ivan.perez@keera.co.uk+-- Stability : provisional+-- Portability : non-portable (GHC extensions) -- -- Defines basic signal functions, and elementary ways of altering them. --@@ -16,8 +16,8 @@ -- 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.+-- 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@@ -34,6 +34,7 @@ ) where +-- Internal imports import FRP.Yampa.InternalCore (SF(..), SF'(..), sfConst, sfId) infixr 0 -->, -:>, >--, -=>, >=-@@ -61,40 +62,37 @@ -- | 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+ 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)} -- | Transform initial input value. ----- Applies a transformation 'f' only to the first input value at--- time zero.+-- Applies a transformation 'f' only to the first input value at time zero. {-# ANN (>=-) "HLint: ignore Avoid lambda" #-} (>=-) :: (a -> a) -> SF a b -> SF a b f >=- (SF {sfTF = tf10}) = SF {sfTF = \a0 -> tf10 (f a0)}
src/FRP/Yampa/Conditional.hs view
@@ -1,28 +1,34 @@ -- |--- 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)+-- 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)+-- Maintainer : ivan.perez@keera.co.uk+-- Stability : provisional+-- Portability : non-portable (GHC extensions) -- -- Apply SFs only under certain conditions. module FRP.Yampa.Conditional- ( provided+ (+ -- * Guards and automata-oriented combinators+ provided++ -- * Variable pause , pause ) where -import Control.Arrow+-- External imports+import Control.Arrow ((&&&), (^>>)) -import FRP.Yampa.Basic-import FRP.Yampa.EventS+-- 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+import FRP.Yampa.Switches (switch) -- * Guards and automata-oriented combinators @@ -34,12 +40,10 @@ -- -- 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.+-- 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 ->@@ -50,36 +54,39 @@ -- * 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}+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 b_init)- -- Otherwise transform the input normally and recurse.+ -- 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 b_init tf10 c, b_init)- (c, False) -> let (k, b0) = tf10 a0- in (pause' b0 k c, b0)+ (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 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)+ 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' 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' tf10' tfP' = SF' tf0'+ where+ tf0' dt a = case (sfTF' tfP') dt a of+ (tfP'', True) -> (pause' bInit' tf10' tfP'', bInit')+ (tfP'', False) -> (pause' b0' tf10'' tfP'', b0')+ where+ (tf10'', b0') = (sfTF' tf10') dt a
src/FRP/Yampa/Delays.hs view
@@ -1,14 +1,14 @@ -- |--- 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)+-- 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) -- -- SF primitives and combinators to delay signals, introducing new values in -- them.@@ -24,12 +24,14 @@ ) where -import Control.Arrow+-- External imports+import Control.Arrow ((>>>)) -import FRP.Yampa.Basic-import FRP.Yampa.Diagnostics+-- Internal imports+import FRP.Yampa.Basic (identity, (-->))+import FRP.Yampa.Diagnostics (usrErr) import FRP.Yampa.InternalCore (SF (..), SF' (..), Time)-import FRP.Yampa.Scan+import FRP.Yampa.Scan (sscanPrim) infixr 0 `fby` @@ -37,8 +39,8 @@ -- | Uninitialized delay operator. ----- The output has an infinitesimal delay (1 sample), and the value at time--- zero is undefined.+-- 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@@ -48,17 +50,16 @@ -- | 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.-+-- delay (one sample), using the given argument to fill in the initial output at+-- time zero. iPre :: a -> SF a a iPre = (--> pre) -- | Lucid-Synchrone-like initialized delay (read "followed by"). ----- 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.+-- 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@@ -66,37 +67,35 @@ -- * Timed delays --- | Delay a signal by a fixed time 't', using the second parameter--- to fill in the initial 't' seconds.+-- | 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 "Yampa" "delay" "Negative delay."- | q == 0 = identity- | otherwise = SF {sfTF = tf0}+delay q aInit | q < 0 = usrErr "Yampa" "delay" "Negative delay."+ | q == 0 = identity+ | otherwise = SF {sfTF = tf0} where- tf0 a0 = (delayAux [] [(q, a0)] 0 a_init, a_init)+ tf0 a0 = (delayAux [] [(q, a0)] 0 aInit, aInit) -- 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.+ -- 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') t_diff a_prev = SF' tf -- True+ delayAux rbuf buf@((bdt, ba) : buf') tDiff aPrev = 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+ tf dt a | tDiff' < bdt = (delayAux rbuf' buf tDiff' aPrev, aPrev)+ | otherwise = nextSmpl rbuf' buf' (tDiff' - bdt) ba where- t_diff' = t_diff + dt- rbuf' = (dt, a) : rbuf+ tDiff' = tDiff + 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+ nextSmpl rbuf [] tDiff a =+ nextSmpl [] (reverse rbuf) tDiff a+ nextSmpl rbuf buf@((bdt, ba) : buf') tDiff a+ | tDiff < bdt = (delayAux rbuf buf tDiff a, a)+ | otherwise = nextSmpl rbuf buf' (tDiff - bdt) ba
src/FRP/Yampa/Diagnostics.hs view
@@ -1,17 +1,21 @@ -- |--- 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)+-- 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 : ivan.perez@keera.co.uk--- 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
src/FRP/Yampa/Event.hs view
@@ -13,9 +13,9 @@ -- Portability : portable -- -- 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.+-- 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,@@ -27,13 +27,56 @@ -- -- Events are essential for many other Yampa constructs, like switches (see -- 'FRP.Yampa.Switches.switch' for details).-module FRP.Yampa.Event where+module FRP.Yampa.Event+ (+ -- * The Event type+ Event(..)+ , noEvent+ , noEventFst+ , noEventSnd -import Control.Applicative+ -- * Internal utilities for event construction+ , maybeToEvent++ -- * Utility functions similar to those available for Maybe+ , event+ , fromEvent+ , isEvent+ , isNoEvent++ -- * Event tagging+ , tag+ , tagWith+ , attach++ -- * Event merging (disjunction) and joining (conjunction)+ , lMerge+ , rMerge+ , merge+ , mergeBy+ , mapMerge+ , mergeEvents+ , catEvents+ , joinE+ , splitE++ -- * Event filtering+ , filterE+ , mapFilterE+ , gate+ )+ 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 -import FRP.Yampa.Diagnostics+-- Internal imports+import FRP.Yampa.Diagnostics (usrErr) infixl 8 `tag`, `attach`, `gate` infixl 7 `joinE`@@ -41,8 +84,8 @@ -- * 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)@@ -60,16 +103,16 @@ 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 --- | 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+ -- | NoEvent is smaller than Event, Event x < Event y if x < y. compare NoEvent NoEvent = EQ compare NoEvent (Event _) = LT compare (Event _) NoEvent = GT@@ -89,37 +132,36 @@ 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'.+ -- | Combine events, return 'NoEvent' if any value in the sequence is+ -- 'NoEvent'. (Event x) >>= k = k x- NoEvent >>= _ = NoEvent+ NoEvent >>= _ = NoEvent (>>) = (*>) -- | See 'pure'.- return = pure+ return = pure #if !(MIN_VERSION_base(4,13,0)) -- | Fail with 'NoEvent'.- fail = Fail.fail+ fail = Fail.fail #endif instance Fail.MonadFail Event where -- | Fail with 'NoEvent'.- fail _ = NoEvent+ fail _ = NoEvent --- | Alternative instance+-- | 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').+ -- | 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 = ()@@ -127,8 +169,8 @@ -- * Internal utilities for event construction --- These utilities are to be considered strictly internal to Yampa for the--- time being.+-- These utilities are to be considered strictly internal to Yampa for the time+-- being. -- | Convert a maybe value into a event ('Event' is isomorphic to 'Maybe'). maybeToEvent :: Maybe a -> Event a@@ -160,16 +202,14 @@ -- | 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 @@ -201,10 +241,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)@@ -233,20 +273,20 @@ [] -> 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 :: Event a -> Event b -> Event (a, b) joinE NoEvent _ = NoEvent joinE _ NoEvent = NoEvent-joinE (Event l) (Event r) = Event (l,r)+joinE (Event l) (Event r) = Event (l, r) -- | Split event carrying pairs into two events.-splitE :: Event (a,b) -> (Event a, Event b)-splitE NoEvent = (NoEvent, NoEvent)-splitE (Event (a,b)) = (Event a, Event b)+splitE :: Event (a, b) -> (Event a, Event b)+splitE NoEvent = (NoEvent, NoEvent)+splitE (Event (a, b)) = (Event a, Event b) -- * Event filtering
src/FRP/Yampa/EventS.hs view
@@ -1,14 +1,14 @@ -- |--- 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)+-- 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. --@@ -54,16 +54,18 @@ ) where -import Control.Arrow+-- External imports+import Control.Arrow (arr, (&&&), (>>>), (>>^)) -import FRP.Yampa.Arrow-import FRP.Yampa.Basic-import FRP.Yampa.Diagnostics-import FRP.Yampa.Event-import FRP.Yampa.Hybrid+-- 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-import FRP.Yampa.Switches+import FRP.Yampa.Scan (sscanPrim)+import FRP.Yampa.Switches (dSwitch, switch) infixr 5 `andThen` @@ -77,8 +79,8 @@ 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 @@ -87,32 +89,32 @@ 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.+--+-- 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+repeatedly q x | q > 0 = afterEach qxs | otherwise = usrErr "Yampa" "repeatedly" "Non-positive period." where- qxs = (q,x):qxs+ 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.-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.-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)+afterEachCat ((q, x) : qxs) | q < 0 = usrErr "Yampa" "afterEachCat" "Negative period." | otherwise = SF {sfTF = tf0} where@@ -121,12 +123,13 @@ else (awaitNextEvent (-q) x qxs, NoEvent) emitEventsScheduleNext _ xs [] = (sfNever, Event (reverse xs))- emitEventsScheduleNext t xs ((q,x):qxs)+ 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+ awaitNextEvent t x qxs = SF' tf -- False where tf dt _ | t' >= 0 = emitEventsScheduleNext t' [x] qxs@@ -161,71 +164,70 @@ , 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.+ -- 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 t_last rqxs qxs t_next x = SF' tf -- True+ pendingEvents tLast rqxs qxs tNext x = SF' tf -- True where tf dt e- | t_next' >= 0- = emitEventsScheduleNext e t_last' rqxs qxs t_next' [x]+ | tNext' >= 0+ = emitEventsScheduleNext e tLast' rqxs qxs tNext' [x] | otherwise- = (pendingEvents t_last'' rqxs' qxs t_next' x, NoEvent)+ = (pendingEvents tLast'' rqxs' qxs tNext' x, NoEvent) where- t_next' = t_next + dt- t_last' = t_last + dt- (t_last'', rqxs') =+ tNext' = tNext + dt+ tLast' = tLast + dt+ (tLast'', rqxs') = case e of- NoEvent -> (t_last', rqxs)- Event x' -> (-q, (t_last'+q,x') : rqxs)+ NoEvent -> (tLast', rqxs)+ Event x' -> (-q, (tLast' + q, x') : rqxs) - -- t_next is the present time w.r.t. the *scheduled* time of the- -- event that is about to be emitted (i.e. >= 0).- -- The time associated with any event at the head of the event- -- queue is also given w.r.t. the event that is about to be emitted.- -- Thus, t_next - q' is the present time w.r.t. the event at the head- -- of the event queue.+ -- 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 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'+ 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- t_last- rqxs- qxs'- (t_next - q')- (x' : rxs)+ | otherwise = emitEventsScheduleNext e+ tLast+ rqxs+ qxs'+ (tNext - q')+ (x' : rxs) --- | 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.+-- | 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 occurring 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 b = sscanPrim f (if b then 2 else 0) NoEvent where@@ -242,8 +244,8 @@ edgeTag :: a -> SF Bool (Event a) edgeTag a = edge >>> arr (`tag` a) --- | Edge detector particularized for detecting transitions--- on a 'Maybe' signal from 'Nothing' to 'Just'.+-- | 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@@ -253,16 +255,16 @@ isJustEdge (Just _) Nothing = Nothing -- | Edge detector parameterized on the edge detection function and initial--- state, i.e., the previous input sample. The first argument to the--- edge detection function is the previous sample, the second the current one.+-- 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}+edgeBy isEdge aInit = SF {sfTF = tf0} where- tf0 a0 = (ebAux a0, maybeToEvent (isEdge a_init a0))+ tf0 a0 = (ebAux a0, maybeToEvent (isEdge aInit a0)) - ebAux a_prev = SF' tf -- True+ ebAux aPrev = SF' tf -- True where- tf _ a = (ebAux a, maybeToEvent (isEdge a_prev a))+ tf _ a = (ebAux a, maybeToEvent (isEdge aPrev a)) -- * Stateful event suppression @@ -281,7 +283,7 @@ -- | Suppress first n events. dropEvents :: Int -> SF (Event a) (Event a)-dropEvents n | n <= 0 = identity+dropEvents n | n <= 0 = identity dropEvents n = -- Here dSwitch or switch does not really matter. dSwitch (never &&& identity)@@ -298,24 +300,23 @@ switch (never &&& (identity &&& now () >>^ \(a, e) -> e `tag` a)) now -- | Event source with a single occurrence at or as soon after (local) time--- @t_ev@ as possible. The value of the event is obtained by sampling the input--- a that time.+-- @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 :: 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+-- | 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.+-- 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, ()))@@ -323,14 +324,15 @@ >>> accumBy updateWindow [] where updateWindow w as = drop (max (length w' - wl) 0) w'- where w' = w ++ as+ where+ w' = w ++ as -- * Repetition and switching -- | Makes an event source recurring by restarting it as soon as it has an -- occurrence. recur :: SF a (Event b) -> SF a (Event b)-recur sfe = switch (never &&& sfe) $ \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
src/FRP/Yampa/Hybrid.hs view
@@ -1,14 +1,14 @@ -- |--- 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)+-- 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) -- -- Discrete to continuous-time signal functions. module FRP.Yampa.Hybrid@@ -30,34 +30,36 @@ ) where -import Control.Arrow+-- External imports+import Control.Arrow (arr, (>>>)) -import FRP.Yampa.Delays-import FRP.Yampa.Event+-- Internal imports+import FRP.Yampa.Delays (iPre)+import FRP.Yampa.Event (Event (..)) import FRP.Yampa.InternalCore (SF, epPrim) -- * 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.+-- 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+hold aInit = epPrim f () aInit where f _ a = ((), a, a) -- | Zero-order hold with a delay. ----- 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.+-- 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]@@ -67,47 +69,43 @@ -- | Tracks input signal when available, holding the last value when the input -- is 'Nothing'. ----- 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@.+-- 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@.+-- 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 --- | 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+accum aInit = epPrim f aInit NoEvent where- f a g = (a', Event a', NoEvent) -- Accumulator, output if Event,- -- output if no event+ 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+accumHold aInit = epPrim f aInit aInit where f a g = (a', a', a') -- Accumulator, output if Event, output if no event where@@ -117,11 +115,11 @@ -- 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+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+accumBy g bInit = epPrim f bInit NoEvent where f b a = (b', Event b', NoEvent) where@@ -129,24 +127,24 @@ -- | 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+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+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+accumFilter g cInit = epPrim f cInit NoEvent where f c a = case g c a of (c', Nothing) -> (c', NoEvent, NoEvent)
src/FRP/Yampa/Integration.hs view
@@ -1,14 +1,14 @@ -- |--- 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)+-- 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) -- -- Integration and derivation of input signals. --@@ -41,14 +41,16 @@ ) where -import Control.Arrow-import Data.VectorSpace+-- External imports+import Control.Arrow ((***), (>>^))+import Data.VectorSpace (VectorSpace, zeroVector, (*^), (^+^), (^-^), (^/)) -import FRP.Yampa.Event-import FRP.Yampa.Hybrid-import FRP.Yampa.InternalCore (SF(..), SF'(..), DTime)+-- 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 #-}@@ -57,39 +59,20 @@ where tf0 a0 = (integralAux igrl0 a0, igrl0) - igrl0 = zeroVector+ igrl0 = zeroVector - integralAux igrl a_prev = SF' tf -- True+ integralAux igrl aPrev = SF' tf -- True where tf dt a = (integralAux igrl' a, igrl') where- igrl' = igrl ^+^ realToFrac dt *^ a_prev+ igrl' = igrl ^+^ realToFrac dt *^ aPrev --- | \"Immediate\" integration (using the function's value at the current time)+-- | \"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`)---- | 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)---- | 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 a_prev = SF' tf -- True- where- tf dt a = (derivativeAux a, (a ^-^ a_prev) ^/ realToFrac dt)+imIntegral = ((\_ a' dt v -> v ^+^ realToFrac dt *^ a') `iterFrom`) -- | Integrate the first input signal and add the /discrete/ accumulation (sum)--- of the second, discrete, input signal.+-- of the second, discrete, input signal. impulseIntegral :: (Fractional k, VectorSpace a k) => SF (a, Event a) a impulseIntegral = (integral *** accumHoldBy (^+^) zeroVector) >>^ uncurry (^+^) @@ -99,3 +82,24 @@ -- [Event 1,NoEvent,Event 2] count :: Integral b => SF (Event a) (Event b) count = accumBy (\n _ -> n + 1) 0++-- * Differentiation++-- | A very crude version of a derivative. It simply divides the value+-- difference by the time difference. Use at your own risk.+derivative :: (Fractional s, VectorSpace a s) => SF a a+derivative = SF {sfTF = tf0}+ where+ tf0 a0 = (derivativeAux a0, zeroVector)++ derivativeAux aPrev = SF' tf -- True+ where+ tf dt a = (derivativeAux a, (a ^-^ aPrev) ^/ realToFrac dt)++-- | Integrate using an auxiliary function that takes the current and the last+-- input, the time between those samples, and the last output, and returns a new+-- output.+iterFrom :: (a -> a -> DTime -> b -> b) -> b -> SF a b+f `iterFrom` b = SF (iterAux b)+ where+ iterAux b a = (SF' (\dt a' -> iterAux (f a a' dt b) a'), b)
src/FRP/Yampa/InternalCore.hs view
@@ -1,21 +1,20 @@ {-# 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)+-- 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+-- 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:@@ -30,19 +29,19 @@ -- 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.+-- * 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).+-- 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,+-- 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@@ -71,9 +70,6 @@ , sfConst , sfArrG - -- *** Scanning- , sfSScan- -- ** Function descriptions , FunDesc(..) , fdFun@@ -82,21 +78,26 @@ , arrPrim , arrEPrim , epPrim++ -- *** Scanning+ , sfSScan ) where +-- External imports #if __GLASGOW_HASKELL__ < 710 import Control.Applicative (Applicative(..)) #endif -import Control.Arrow+import Control.Arrow (Arrow (..), ArrowChoice (..), ArrowLoop (..), (>>>)) #if __GLASGOW_HASKELL__ >= 610 import qualified Control.Category (Category(..)) #endif -import FRP.Yampa.Diagnostics-import FRP.Yampa.Event+-- Internal imports+import FRP.Yampa.Diagnostics (usrErr)+import FRP.Yampa.Event (Event (..)) -- * Basic type definitions with associated utilities @@ -113,34 +114,43 @@ -- | 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.+-- (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.+-- 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.+ 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+ -> !(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+ -> !(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.@@ -174,8 +184,8 @@ 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 = 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@@ -183,47 +193,13 @@ where sf = SFArr (\_ a -> (sf, f a)) (FDG f) --- | 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) = let (c', b, bne') = f c a- in (sfEP f c' bne', b)---- | 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+-- ** 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.+-- 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@@ -254,7 +230,7 @@ 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 :: 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))@@ -264,13 +240,13 @@ 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 :: 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@@ -281,12 +257,12 @@ 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.+-- 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 _ _ =+vfyNoEv _ _ = usrErr "Yampa" "vfyNoEv"@@ -298,7 +274,7 @@ -- | Composition and identity for SFs. instance Control.Category.Category SF where (.) = flip compPrim- id = SF $ \x -> (sfId,x)+ id = SF $ \x -> (sfId, x) #endif -- | Choice of which SF to run based on the value of a signal.@@ -345,7 +321,7 @@ in (choose sfCL sf', Right e) -- | Signal Functions as Arrows. See "The Yampa Arcade", by Courtney, Nilsson--- and Peterson.+-- and Peterson. instance Arrow SF where arr = arrPrim first = firstPrim@@ -355,7 +331,7 @@ #if __GLASGOW_HASKELL__ >= 610 #else- (>>>) = compPrim+ (>>>) = compPrim #endif -- | Functor instance for applied SFs.@@ -365,8 +341,8 @@ -- | 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 ($))+ pure x = arr (const x)+ f <*> x = (f &&& x) >>> arr (uncurry ($)) -- * Lifting. @@ -381,9 +357,46 @@ 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+-- | SF Composition. -- -- The definition exploits the following identities: -- sf >>> identity = sf -- New@@ -410,19 +423,20 @@ -- 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 (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 =- 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')+ 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@@ -443,29 +457,29 @@ 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')+ 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.+ -- 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)@@ -481,8 +495,8 @@ 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.+ -- 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@@ -492,8 +506,8 @@ (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.+-- 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@@ -501,10 +515,14 @@ 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+ -- 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 {}) =@@ -535,9 +553,9 @@ -- 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 (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@@ -552,8 +570,12 @@ 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 :: 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@@ -574,12 +596,12 @@ 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.+ -- 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 ...+ -- 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@@ -599,11 +621,16 @@ 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')+ 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)@@ -613,11 +640,14 @@ 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 :: 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+ -- 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.@@ -627,7 +657,10 @@ 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')+ 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@@ -646,8 +679,11 @@ 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 :: 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@@ -677,23 +713,23 @@ -- * Widening. --- | 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 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 :: 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))@@ -701,17 +737,17 @@ (sf1', b) = (sfTF' sf1) dt a -- Mirror image of first.-secondPrim :: SF a b -> SF (c,a) (c,b)+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 :: 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))@@ -728,7 +764,7 @@ -- 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 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))@@ -741,14 +777,14 @@ -- 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 :: 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))@@ -756,33 +792,33 @@ (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+ 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+ 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+ 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+ 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@@ -802,22 +838,22 @@ -- 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+ 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 :: SF' a c -> SF' a (a, c) pfoIX (SFArr _ fd2) = sfArr (fdFanOut FDI fd2) pfoIX sf2 = SF' tf where@@ -825,7 +861,7 @@ where (sf2', c) = (sfTF' sf2) dt a - pfoXI :: SF' a b -> SF' a (b ,a)+ pfoXI :: SF' a b -> SF' a (b, a) pfoXI (SFArr _ fd1) = sfArr (fdFanOut fd1 FDI) pfoXI sf1 = SF' tf where@@ -833,7 +869,7 @@ where (sf1', b) = (sfTF' sf1) dt a - pfoCX :: b -> SF' a c -> SF' a (b ,c)+ pfoCX :: b -> SF' a c -> SF' a (b, c) pfoCX b (SFArr _ fd2) = sfArr (fdFanOut (FDC b) fd2) pfoCX b sf2 = SF' tf where@@ -841,7 +877,7 @@ where (sf2', c) = (sfTF' sf2) dt a - pfoXC :: SF' a b -> c -> SF' a (b ,c)+ pfoXC :: SF' a b -> c -> SF' a (b, c) pfoXC (SFArr _ fd1) c = sfArr (fdFanOut fd1 (FDC c)) pfoXC sf1 c = SF' tf where@@ -849,7 +885,7 @@ where (sf1', b) = (sfTF' sf1) dt a - pfoAX :: (a -> b) -> SF' a c -> SF' a (b ,c)+ 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@@ -857,7 +893,7 @@ where (sf2', c) = (sfTF' sf2) dt a - pfoXA :: SF' a b -> (a -> c) -> SF' a (b ,c)+ 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@@ -871,19 +907,19 @@ instance ArrowLoop SF where loop = loopPrim -loopPrim :: SF (a,c) (b,c) -> SF a b+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 :: 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+ 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@@ -893,14 +929,14 @@ -- | 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.+-- 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+ sf = SFSScan tf f c b tf _ a = case f c a of Nothing -> (sf, b) Just (c', b') -> (sfSScan f c' b', b')
src/FRP/Yampa/Loop.hs view
@@ -1,17 +1,17 @@ -- |--- 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)+-- 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+-- Well-initialised loops. module FRP.Yampa.Loop ( -- * Loops with guaranteed well-defined feedback@@ -20,21 +20,22 @@ ) where -import Control.Arrow-import Data.VectorSpace+-- External imports+import Control.Arrow (loop, second, (>>>))+import Data.VectorSpace (VectorSpace) -import FRP.Yampa.Delays-import FRP.Yampa.Integration+-- Internal imports+import FRP.Yampa.Delays (iPre)+import FRP.Yampa.Integration (integral) import FRP.Yampa.InternalCore (SF) -- * 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 :: (Fractional s, 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)
src/FRP/Yampa/Random.hs view
@@ -1,14 +1,14 @@ -- |--- 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)+-- 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) -- -- Signals and signal functions with noise and randomness. --@@ -26,21 +26,23 @@ ) where +-- External imports import System.Random (Random (..), RandomGen (..)) -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 (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) streamToSF :: [b] -> SF a b@@ -55,29 +57,27 @@ 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.-+-- 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 "Yampa" "occasionally"- "Non-positive average interval."+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.+ -- 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)+ tf dt _ = (occAux rs, if r < p then Event x else NoEvent)+ where+ p = 1 - exp (- (dt / tAvg)) -- Probability for at least one event.
src/FRP/Yampa/Scan.hs view
@@ -1,19 +1,19 @@ -- |--- 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)+-- 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)+-- 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+-- 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@@ -22,6 +22,7 @@ ) where +-- Internal imports import FRP.Yampa.InternalCore (SF(..), sfSScan) -- ** Simple, stateful signal processing@@ -29,20 +30,22 @@ -- | 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+sscan f bInit = sscanPrim f' bInit bInit where- f' b a = let b' = f b a in Just (b', b')+ 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.+-- | 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.+-- 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}+sscanPrim f cInit bInit = 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')+ tf0 a0 = case f cInit a0 of+ Nothing -> (sfSScan f cInit bInit, bInit)+ Just (c', b') -> (sfSScan f c' b', b')
src/FRP/Yampa/Simulation.hs view
@@ -1,21 +1,21 @@ -- |--- 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)+-- 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) -- -- 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/.+-- 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,@@ -58,11 +58,13 @@ ) where +-- External imports import Control.Monad (unless)-import Data.IORef+import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Maybe (fromMaybe) -import FRP.Yampa.Diagnostics+-- Internal imports+import FRP.Yampa.Diagnostics (intErr, usrErr) import FRP.Yampa.InternalCore (DTime, SF (..), SF' (..), sfTF') -- * Reactimation@@ -74,9 +76,9 @@ -- initial input for the signal transformer at time 0. -- -- Afterwards, an input sensing action is used to obtain new input (if any) and--- the time since the last iteration. The argument to the input sensing--- function indicates if it can block. If no new input is received, it is--- assumed to be the same as in the last iteration.+-- the time since the last iteration. The argument to the input sensing function+-- indicates if it can block. If no new input is received, it is assumed to be+-- the same as in the last iteration. -- -- After applying the signal function to the input, the actuation IO action is -- executed. The first argument indicates if the output has changed, the second@@ -89,7 +91,6 @@ -- 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@@ -106,19 +107,19 @@ done <- actuate True b unless (a `seq` b `seq` done) $ do (dt, ma') <- sense False- let a' = fromMaybe a ma'+ 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+ , rsSF :: SF' a b+ , rsA :: a+ , rsB :: b } -- | A reference to reactimate's state, maintained across samples.@@ -126,15 +127,15 @@ { 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 :: 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:+ 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 }@@ -145,24 +146,23 @@ -- | Process a single input sample. react :: ReactHandle a b- -> (DTime,Maybe a)+ -> (DTime, Maybe a) -> IO Bool-react rh (dt,ma') = do+react rh (dt, ma') = do rs <- readIORef (reactHandle rh) let ReactState {rsActuate = actuate, rsSF = sf, rsA = a, rsB = _b } = rs let a' = fromMaybe a ma'- (sf',b') = (sfTF' sf) dt a'- writeIORef (reactHandle rh) (rs {rsSF = sf',rsA = a',rsB = b'})+ (sf', b') = (sfTF' sf) dt a'+ writeIORef (reactHandle rh) (rs {rsSF = sf', rsA = a', rsB = b'}) done <- actuate rh True b' return done -- * 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]@@ -171,10 +171,10 @@ (sf, b0) = (sfTF sf0) a0 loop _ _ [] = []- loop a_prev sf ((dt, ma) : dtas) =+ loop aPrev sf ((dt, ma) : dtas) = b : (a `seq` b `seq` loop a sf' dtas) where- a = fromMaybe a_prev ma+ a = fromMaybe aPrev ma (sf', b) = (sfTF' sf) dt a -- | Synchronous embedding. The embedded signal function is run on the supplied@@ -188,28 +188,28 @@ tf0 _ = (esAux 0 (zip tts bbs), b) - esAux _ [] = intErr "Yampa" "embedSynch" "Empty list!"+ esAux _ [] = intErr "Yampa" "embedSynch" "Empty list!" -- Invarying below since esAux [] is an error.- esAux tp_prev tbtbs = SF' tf -- True+ esAux tpPrev tbtbs = SF' tf -- True where tf dt r | r < 0 = usrErr "Yampa" "embedSynch" "Negative ratio."- | otherwise = let tp = tp_prev + dt * r- (b, tbtbs') = advance tp tbtbs- in (esAux tp tbtbs', b)+ | 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+ -- 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.+ -- 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 "Yampa" "deltaEncode" "Empty input list." deltaEncode dt aas@(_:_) = deltaEncodeBy (==) dt aas@@ -219,59 +219,61 @@ 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+ debAux _ [] = []+ debAux aPrev (a:as) | a `eq` aPrev = Nothing : debAux a as+ | otherwise = Just a : debAux a as -- * 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. ----- /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.+-- /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+ where+ (tf', b) = tf a -- | Evaluate an initialized SF, and return an output and a continuation. ----- /WARN/: Do not use this function for standard simulation. This function is--- 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.+-- /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+ 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.------ 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).+-- the future, returning a new uninitialized SF and the initial output. ----- /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.+-- 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+ where+ (b, sf') = evalStep sf a -- | Steps the signal function into the future one step. It returns the current -- output, and a signal function that expects, apart from an input, a time -- between samples. evalStep :: SF a b -> a -> (b, DTime -> SF a b) evalStep (SF sf) a = (b, \dt -> SF (sfTF' sf' dt))- where (sf', b) = sf a+ where+ (sf', b) = sf a
src/FRP/Yampa/Switches.hs view
@@ -1,15 +1,15 @@ {-# 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)+-- 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)+-- Maintainer : ivan.perez@keera.co.uk+-- Stability : provisional+-- Portability : non-portable (GHC extensions) -- -- Switches allow you to change the signal function being applied. --@@ -21,10 +21,10 @@ -- -- @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.+-- 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@@ -36,22 +36,21 @@ -- 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.+-- 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').+-- '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 ('[]').+-- 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@@ -62,9 +61,9 @@ -- 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/).+-- 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@@ -75,13 +74,13 @@ -- * Parallel composition\/switching (collections) -- ** With broadcasting , parB- , pSwitchB,dpSwitchB- , rpSwitchB,drpSwitchB+ , pSwitchB, dpSwitchB+ , rpSwitchB, drpSwitchB -- ** With helper routing function , par- , pSwitch, dpSwitch- , rpSwitch,drpSwitch+ , pSwitch, dpSwitch+ , rpSwitch, drpSwitch -- * Parallel composition\/switching (lists) --@@ -97,11 +96,13 @@ ) where -import Control.Arrow+-- External imports+import Control.Arrow (arr, first) -import FRP.Yampa.Basic-import FRP.Yampa.Diagnostics-import FRP.Yampa.Event+-- 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') @@ -117,12 +118,10 @@ -- -- 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.+-- 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!+-- 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@@ -158,35 +157,32 @@ -- -- 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*.+-- 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.+-- 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).+-- 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.+-- 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!+-- 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 =- let (sf1, (b0, ec0)) = tf10 a0- in ( case ec0 of- NoEvent -> dSwitchAux sf1 k- Event c0 -> fst (sfTF (k c0) a0)- , b0- )+ 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.@@ -195,35 +191,35 @@ dSwitchAux (SFArr _ fd1) k = dSwitchAuxA1 (fdFun fd1) k dSwitchAux sf1 k = SF' tf where- tf dt a =- let (sf1', (b, ec)) = (sfTF' sf1) dt a- in ( case ec of- NoEvent -> dSwitchAux sf1' k- Event c -> fst (sfTF (k c) a)- , b- )+ 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 =- let (b, ec) = f1 a- in ( case ec of- NoEvent -> sf- Event c -> fst (sfTF (k c) a)- , b- )+ sf = SF' tf -- False+ tf _ a = ( case ec of+ NoEvent -> sf+ Event c -> fst (sfTF (k c) a)+ , b+ )+ where+ (b, ec) = f1 a -- | Recurring switch. -- -- Uses the given SF until an event comes in the input, in which case the SF in -- the event is turned on, until the next event comes in the input, and so on. ----- See <https://wiki.haskell.org/Yampa#Switches> for more--- information on how this switch works.+-- See <https://wiki.haskell.org/Yampa#Switches> for more information on how+-- this switch works. rSwitch :: SF a b -> SF (a, Event (SF a b)) b rSwitch sf = switch (first sf) ((noEventSnd >=-) . rSwitch) @@ -234,8 +230,8 @@ -- -- Uses decoupled switch ('dSwitch'). ----- See <https://wiki.haskell.org/Yampa#Switches> for more--- information on how this switch works.+-- See <https://wiki.haskell.org/Yampa#Switches> for more information on how+-- this switch works. drSwitch :: SF a b -> SF (a, Event (SF a b)) b drSwitch sf = dSwitch (first sf) ((noEventSnd >=-) . drSwitch) @@ -245,33 +241,35 @@ -- passed to the second SF, produce an event, in which case the original SF and -- the event are used to build an new SF to switch into. ----- See <https://wiki.haskell.org/Yampa#Switches> for more--- information on how this switch works.-kSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b+-- See <https://wiki.haskell.org/Yampa#Switches> for more information on how+-- this switch works.+kSwitch :: SF a b -> SF (a, b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b kSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0} where- tf0 a0 =- let (sf1, b0) = tf10 a0- in case tfe0 (a0, b0) of- (sfe, NoEvent) -> (kSwitchAux sf1 sfe, b0)- (_, Event c0) -> sfTF (k sf10 c0) a0+ 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+ kSwitchAux sf1 (SFArr _ fde) = kSwitchAuxAE sf1 (fdFun fde)+ kSwitchAux sf1 sfe = SF' tf -- False where- tf dt a =- let (sf1', b) = (sfTF' sf1) dt a- in case (sfTF' sfe) dt (a, b) of- (sfe', NoEvent) -> (kSwitchAux sf1' sfe', b)- (_, Event c) -> sfTF (k (freeze sf1 dt) c) a+ 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+ 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@@ -280,25 +278,25 @@ -- !!! Untested optimization! kSwitchAuxA1 f1 (SFArr _ (FDC NoEvent)) = sfArrG f1- kSwitchAuxA1 f1 (SFArr _ fde) = kSwitchAuxA1AE f1 (fdFun fde)- kSwitchAuxA1 f1 sfe = SF' tf -- False+ kSwitchAuxA1 f1 (SFArr _ fde) = kSwitchAuxA1AE f1 (fdFun fde)+ kSwitchAuxA1 f1 sfe = SF' tf -- False where- tf dt a =- let b = f1 a- in case (sfTF' sfe) dt (a, b) of- (sfe', NoEvent) -> (kSwitchAuxA1 f1 sfe', b)- (_, Event c) -> sfTF (k (arr f1) c) a+ 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+ kSwitchAuxAE (SFArr _ (FDC b)) fe = kSwitchAuxC1AE b fe+ kSwitchAuxAE (SFArr _ fd1) fe = kSwitchAuxA1AE (fdFun fd1) fe+ kSwitchAuxAE sf1 fe = SF' tf -- False where- tf dt a =- let (sf1', b) = (sfTF' sf1) dt a- in case fe (a, b) of- NoEvent -> (kSwitchAuxAE sf1' fe, b)- Event c -> sfTF (k (freeze sf1 dt) c) a+ 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@@ -311,11 +309,11 @@ -- !!! 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+ 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. --@@ -325,42 +323,40 @@ -- -- The switch is decoupled ('dSwitch'). ----- See <https://wiki.haskell.org/Yampa#Switches> for more--- information on how this switch works.-dkSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b+-- See <https://wiki.haskell.org/Yampa#Switches> for more information on how+-- this switch works.+dkSwitch :: SF a b -> SF (a, b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b dkSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0} where- tf0 a0 =- 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- )+ 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 =- 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- )+ 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.+-- | 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'.+-- | Spatial parallel composition of a signal function collection. Given a+-- collection of signal functions, it returns a signal function that broadcasts+-- its input signal to every element of the collection, to return a signal+-- carrying a collection of outputs. See 'par'. -- -- For more information on how parallel composition works, check -- <https://www.antonycourtney.com/pubs/hw03.pdf>@@ -372,27 +368,31 @@ -- -- For more information on how parallel composition works, check -- <https://www.antonycourtney.com/pubs/hw03.pdf>-pSwitchB :: Functor col =>- col (SF a b) -> SF (a,col b) (Event c) -> (col (SF a b)->c-> SF a (col b))- -> SF a (col b)+pSwitchB :: 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'.+-- | Decoupled parallel switch with broadcasting (dynamic collection of signal+-- functions spatially composed in parallel). See 'dpSwitch'. -- -- For more information on how parallel composition works, check -- <https://www.antonycourtney.com/pubs/hw03.pdf>-dpSwitchB :: Functor col =>- col (SF a b) -> SF (a,col b) (Event c) -> (col (SF a b)->c->SF a (col b))- -> SF a (col b)+dpSwitchB :: 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.+-- 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.@@ -401,16 +401,17 @@ -- -- For more information on how parallel composition works, check -- <https://www.antonycourtney.com/pubs/hw03.pdf>-rpSwitchB :: Functor col =>- col (SF a b) -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b)+rpSwitchB :: 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.+-- 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.@@ -419,165 +420,161 @@ -- -- For more information on how parallel composition works, check -- <https://www.antonycourtney.com/pubs/hw03.pdf>-drpSwitchB :: Functor col =>- col (SF a b) -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b)+drpSwitchB :: 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.+ -- ^ 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.+ -- ^ 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)+ 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 :: 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)+ 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.+-- 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.+ -- ^ 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.+ -- ^ Signal function collection. -> SF (a, col c) (Event d)- -- ^ Signal function generating the switching event.+ -- ^ Signal function generating the switching event. -> (col (SF b c) -> d -> SF a (col c))- -- ^ Continuation to be invoked once event occurs.+ -- ^ 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+ 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+ 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+ 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.+-- 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.+ -- ^ 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.+ -- ^ 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.+ -- ^ 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.+ -- ^ 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- )+ 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 =- 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- )+ 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.+-- 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.+-- 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.+ -- ^ 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.+ -- ^ 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 ->@@ -586,48 +583,47 @@ -- | 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.+-- 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.+-- 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.+ -- ^ 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.+ -- ^ 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')+ 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.+-- 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]]+-- >>> 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.+-- 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.+-- >>> 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.+-- 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]]-+-- >>> embed (parZ [arr (+1)]) (deltaEncode 0.1 [[0, 0], [1, 1]])+-- [[1],[2]] parZ :: [SF a b] -> SF [a] [b] parZ = par (safeZip "parZ") @@ -636,17 +632,21 @@ -- -- For more information on how parallel composition works, check -- <https://www.antonycourtney.com/pubs/hw03.pdf>-pSwitchZ :: [SF a b] -> SF ([a],[b]) (Event c) -> ([SF a b] -> c -> SF [a] [b])- -> SF [a] [b]+pSwitchZ :: [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'.+-- | Decoupled parallel switch with broadcasting (dynamic collection of signal+-- functions spatially composed in parallel). See 'dpSwitch'. -- -- For more information on how parallel composition works, check -- <https://www.antonycourtney.com/pubs/hw03.pdf>-dpSwitchZ :: [SF a b] -> SF ([a],[b]) (Event c) -> ([SF a b] -> c ->SF [a] [b])- -> SF [a] [b]+dpSwitchZ :: [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.@@ -681,7 +681,7 @@ drpSwitchZ :: [SF a b] -> SF ([a], Event ([SF a b] -> [SF a b])) [b] drpSwitchZ = drpSwitch (safeZip "drpSwitchZ") -safeZip :: String -> [a] -> [b] -> [(a,b)]+safeZip :: String -> [a] -> [b] -> [(a, b)] safeZip fn l1 l2 = safeZip' l1 l2 where safeZip' :: [a] -> [b] -> [(a, b)]@@ -709,24 +709,23 @@ -- | Apply an SF to every element of a list. ----- Example:+-- 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]]+-- >>> 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.+-- 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.+-- 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]]+-- >>> 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.+-- 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]]-+-- >>> 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@@ -737,11 +736,11 @@ 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)+ 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)
src/FRP/Yampa/Task.hs view
@@ -1,36 +1,44 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} -- |--- 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)+-- 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 : 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) -- -- Task abstraction on top of signal transformers. module FRP.Yampa.Task- ( Task+ (+ -- * The Task type+ Task , mkTask , runTask , runTask_ , taskToSF++ -- * Basic tasks , constT , sleepT , snapT++ -- * Basic tasks combinators , timeOut , abortWhen ) where +-- External imports #if __GLASGOW_HASKELL__ < 710 import Control.Applicative (Applicative(..)) #endif +-- Internal imports import FRP.Yampa.Basic (constant) import FRP.Yampa.Diagnostics (intErr, usrErr) import FRP.Yampa.Event (Event, lMerge)@@ -43,12 +51,10 @@ -- * The Task type -- | A task is a partially SF that may terminate with a result.- newtype Task a b c =- -- CPS-based representation allowing termination to be detected.- -- (Note the rank 2 polymorphic type!)- -- The representation can be changed if necessary, but the Monad laws- -- follow trivially in this case.+ -- 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))@@ -62,9 +68,9 @@ -- | 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.+-- 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)@@ -80,8 +86,8 @@ >>> arr (either id (usrErr "YampaTask" "runTask_" "Task terminated!")) --- | Creates an SF that represents an SF and produces an event--- when the task terminates, and otherwise produces just an output.+-- | 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 "YampaTask" "runTask_"@@ -153,7 +159,6 @@ -- No time passes; therefore, the following must hold: -- -- @snapT >> snapT = snapT@- snapT :: Task a b a snapT = mkTask (constant (intErr "YampaTask" "snapT" "Bad switch?") &&& snap) @@ -163,21 +168,21 @@ 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)))+ 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.+-- | 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.+-- 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)))+ aux ((b, ec), ed) = (b, lMerge (fmap Left ec) (fmap Right ed))
src/FRP/Yampa/Time.hs view
@@ -1,19 +1,19 @@ -- |--- 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)+-- 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) -- -- 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+-- 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.@@ -29,8 +29,10 @@ ) 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)