├── .github └── FUNDING.yml ├── .gitignore ├── .travis.yml ├── README.md ├── cabal.project ├── doc ├── diagrams │ └── Diagrams.md └── hcar │ ├── .gitignore │ ├── Makefile │ ├── Yampa-IY.tex │ ├── android.gif │ ├── android.png │ ├── androidbreakout.png │ ├── arpeggigon.png │ ├── breakout.png │ ├── hcar.sty │ ├── report.tex │ └── template.tex ├── yampa-test ├── CHANGELOG ├── LICENSE ├── Setup.hs ├── examples │ └── Testing.hs ├── src │ └── FRP │ │ └── Yampa │ │ ├── Debug.hs │ │ ├── LTLFuture.hs │ │ ├── LTLPast.hs │ │ ├── QuickCheck.hs │ │ └── Stream.hs ├── tests │ ├── Main.hs │ ├── Space.hs │ ├── Test │ │ └── FRP │ │ │ └── Yampa │ │ │ ├── Arrow.hs │ │ │ ├── Basic.hs │ │ │ ├── Conditional.hs │ │ │ ├── Delays.hs │ │ │ ├── Event.hs │ │ │ ├── EventS.hs │ │ │ ├── Hybrid.hs │ │ │ ├── Integration.hs │ │ │ ├── InternalCore.hs │ │ │ ├── Loop.hs │ │ │ ├── Random.hs │ │ │ ├── Scan.hs │ │ │ ├── Simulation.hs │ │ │ ├── Switches.hs │ │ │ ├── Task.hs │ │ │ └── Time.hs │ └── TestsCommon.hs └── yampa-test.cabal └── yampa ├── CHANGELOG ├── HLint.hs ├── LICENSE ├── README.md ├── Setup.hs ├── Yampa.cabal ├── benchmarks └── Bench.hs ├── examples ├── Core.hs ├── Diagrams.hs ├── Elevator │ ├── Elevator.hs │ └── TestElevatorMain.hs ├── TailgatingDetector │ ├── TailgatingDetector.hs │ └── TestTGMain.hs └── yampa-game │ ├── IdentityList.hs │ ├── MainBouncingBox.hs │ ├── MainCircleMouse.hs │ ├── MainWiimote.hs │ └── YampaSDL.hs ├── src └── FRP │ ├── Yampa.hs │ └── Yampa │ ├── Arrow.hs │ ├── Basic.hs │ ├── Conditional.hs │ ├── Delays.hs │ ├── Diagnostics.hs │ ├── Event.hs │ ├── EventS.hs │ ├── Hybrid.hs │ ├── Integration.hs │ ├── InternalCore.hs │ ├── Loop.hs │ ├── Random.hs │ ├── Scan.hs │ ├── Simulation.hs │ ├── Switches.hs │ ├── Task.hs │ └── Time.hs ├── stack.yaml └── tests ├── HaddockCoverage.hs └── hlint.hs /.github/FUNDING.yml: -------------------------------------------------------------------------------- 1 | # These are supported funding model platforms 2 | 3 | github: ivanperez-keera 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Taken from the gitignore project (https://raw.githubusercontent.com/github/gitignore/master/Haskell.gitignore) 2 | dist 3 | dist-* 4 | cabal-dev 5 | *.o 6 | *.hi 7 | *.hie 8 | *.chi 9 | *.chs.h 10 | *.dyn_o 11 | *.dyn_hi 12 | .hpc 13 | .hsenv 14 | .cabal-sandbox/ 15 | cabal.sandbox.config 16 | *.prof 17 | *.aux 18 | *.hp 19 | *.eventlog 20 | .stack-work/ 21 | cabal.project.local 22 | cabal.project.local~ 23 | .HTF/ 24 | .ghc.environment.* 25 | 26 | # Others 27 | yampa/tests/testAFRPMain 28 | .virthualenv 29 | SourceGraph 30 | .tags 31 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | dist: bionic 2 | 3 | # The following enables several GHC versions to be tested; often it's enough to 4 | # test only against the last release in a major GHC version. Feel free to omit 5 | # lines listings versions you don't need/want testing for. 6 | env: 7 | - CABALVER=2.4 GHCVER=7.6.3 8 | - CABALVER=2.4 GHCVER=7.8.4 9 | - CABALVER=2.4 GHCVER=7.10.3 10 | - CABALVER=2.4 GHCVER=8.0.2 11 | - CABALVER=2.4 GHCVER=8.2.2 12 | - CABALVER=2.4 GHCVER=8.4.4 13 | - CABALVER=2.4 GHCVER=8.6.5 14 | - CABALVER=2.4 GHCVER=8.8.3 15 | - CABALVER=2.4 GHCVER=8.10.1 16 | # - CABALVER=head GHCVER=head # see section about GHC HEAD snapshots 17 | 18 | # Note: the distinction between `before_install` and `install` is not important. 19 | before_install: 20 | # We remove the pgdg.list file because it's there to add the postgresql 21 | # repository, and we don't need it. Leaving it in causes problems with Ubuntu 22 | # Bionic (the distro is no longer supported by postgresql). 23 | - sudo rm /etc/apt/sources.list.d/pgdg.list 24 | 25 | - travis_retry sudo add-apt-repository -y ppa:hvr/ghc 26 | - travis_retry sudo apt-get update 27 | - travis_retry sudo apt-get install --yes libcwiid-dev libsdl1.2-dev 28 | - travis_retry sudo apt-get install --yes cabal-install-$CABALVER ghc-$GHCVER # see note about happy/alex 29 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH 30 | - cabal --version 31 | - ghc --version 32 | - travis_retry cabal update 33 | 34 | install: 35 | - travis_retry cabal install --enable-tests -fexamples --only-dependencies yampa/ yampa-test/ 36 | 37 | script: 38 | - if [ "${TRAVIS_HASKELL_VERSION}" == "8.4.4" ]; then cabal install -ftest-doc-coverage --run-tests -j1 yampa/ yampa-test/; else cabal install --enable-tests -fexamples -j1 yampa/ yampa-test/; fi 39 | 40 | after_script: 41 | 42 | branches: 43 | only: 44 | - master 45 | - /^develop.*$/ 46 | - /^hotfix.*$/ 47 | - /^release.*$/ 48 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | yampa/README.md -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | yampa/ 3 | yampa-test/ 4 | 5 | -------------------------------------------------------------------------------- /doc/diagrams/Diagrams.md: -------------------------------------------------------------------------------- 1 | Attention: The licenses mentioned here may be incorrect. Please, do not use 2 | these files without checking with the original authors. 3 | 4 | | Function(s) | Diagram | Format | Author | License | 5 | |-------------------------|-------------------------------------|--------|------------------|---------------| 6 | | `arr` | [![arr](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/png/combinator-arr-narrow.png)](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/dia/combinator-arr-narrow.dia) | dia | Henrik Nilsson | Public Domain | 7 | | `(>>>)` | [![(>>>)](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/png/combinator-compose-narrow.png)](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/dia/combinator-compose-narrow.dia) | dia | Henrik Nilsson | Public Domain | 8 | | `loop` | [![Loop](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/png/combinator-loop-narrow.png)](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/dia/combinator-loop-narrow.dia) | dia | Henrik Nilsson | Public Domain | 9 | | `(&&&)` | [![&&&](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/png/combinator-parfanout-narrow.png)](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/dia/combinator-parfanout-narrow.dia) | dia | Henrik Nilsson | Public Domain | 10 | | Signal Function network | [![SF network](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/png/varying-structure.png)](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/dia/varying-structure.dia) | dia | Henrik Nilsson | Public Domain | 11 | | `kSwitch` | [![kSwitch](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/png/Yampa_kSwitch.png)](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/svg/Yampa_kSwitch.svg) | SVG | Gerold Meisinger | CC BY-NC-SA | 12 | | `pSwitchB` | [![pSwitchB](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/png/Yampa_pSwitchB.png)](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/svg/Yampa_pSwitchB.svg) | SVG | Gerold Meisinger | CC BY-NC-SA | 13 | | `pSwitch` | [![pSwitch](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/png/Yampa_pSwitch.png)](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/svg/Yampa_pSwitch.svg) | SVG | Gerold Meisinger | CC BY-NC-SA | 14 | | `rpSwitchB` | [![rpSwitchB](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/png/Yampa_rpSwitchB.png)](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/svg/Yampa_rpSwitchB.svg) | SVG | Gerold Meisinger | CC BY-NC-SA | 15 | | `rpSwitch` | [![rpSwitch](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/png/Yampa_rpSwitch.png)](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/svg/Yampa_rpSwitch.svg) | SVG | Gerold Meisinger | CC BY-NC-SA | 16 | | `rSwitch` | [![rSwitch](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/png/Yampa_rSwitch.png)](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/svg/Yampa_rSwitch.svg) | SVG | Gerold Meisinger | CC BY-NC-SA | 17 | | `switch` | [![switch](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/png/Yampa_switch.png)](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/svg/Yampa_switch.svg) | SVG | Gerold Meisinger | CC BY-NC-SA | 18 | | Basic Signal Functions | [![yampa_signalfunctions](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/png/yampa_signalfunctions.png)](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/svg/yampa_signalfunctions.svg) | SVG | Gerold Meisinger | CC BY-NC-SA | 19 | | Reactimate Activity | [![yampa_reactimate_activity](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/png/yampa_reactimate_activity.png)](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/svg/yampa_reactimate_activity.svg) | SVG | Gerold Meisinger | CC BY-NC-SA | 20 | | Reactimate Dataflow | [![yampa_reactimate_dataflow](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/png/yampa_reactimate_dataflow.png)](http://www.cs.nott.ac.uk/~psxip1/images/frp-diagrams/svg/yampa_reactimate_dataflow.svg) | SVG | Gerold Meisinger | CC BY-NC-SA | 21 | -------------------------------------------------------------------------------- /doc/hcar/.gitignore: -------------------------------------------------------------------------------- 1 | *.aux 2 | *.log 3 | *.pdf 4 | *.toc 5 | *.out 6 | html/ 7 | -------------------------------------------------------------------------------- /doc/hcar/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: default clean 2 | 3 | default: report.pdf 4 | 5 | report.pdf: report.tex Yampa-IY.tex \ 6 | hcar.sty \ 7 | androidbreakout.png arpeggigon.png 8 | 9 | %.pdf: %.tex 10 | pdflatex $< 11 | pdflatex $< 12 | 13 | clean: 14 | rm -f *.out *.pdf *.aux *.log *.toc 15 | -------------------------------------------------------------------------------- /doc/hcar/Yampa-IY.tex: -------------------------------------------------------------------------------- 1 | % Yampa-IY.tex 2 | \begin{hcarentry}[updated]{Yampa} 3 | \report{Ivan Perez}%11/18 4 | \label{yampa} 5 | \makeheader 6 | 7 | Yampa (Github: \href{http://git.io/vTvxQ}{http://git.io/vTvxQ}, Hackage: 8 | \href{http://goo.gl/JGwycF}{http://goo.gl/JGwycF}), is a Functional Reactive 9 | Programming implementation in the form of a EDSL to define \emph{Signal 10 | Functions}, that is, transformations of input signals into output signals 11 | (aka. \emph{behaviours} in other FRP dialects). 12 | 13 | Yampa systems are defined as combinations of Signal Functions. Yampa includes 14 | combinators to create constant signals, apply pointwise (or time-wise) 15 | transformations, access the running time, introduce delays and create 16 | loopbacks (carrying present output as future input). Systems can be 17 | dynamic: their structure can be changed using \emph{switching} 18 | combinators, which apply a different signal function at some point in 19 | the future. Combinators that deal with collections enable adding, 20 | removing, altering, pausing and unpausing signal functions at will. 21 | 22 | A suitable thinking model for FRP in Yampa is that of signal 23 | processing, in which components (signal functions) transform signals 24 | based on their present value and a component's internal state. 25 | Components can, therefore, be serialized, applied in parallel, etc. 26 | Yampa's signal functions implement the Arrow and ArrowLoop 27 | typeclasses, making it possible to use both arrow notation and arrow 28 | combinators. 29 | 30 | Yampa combinators guarantee \emph{causality}: the value of an output 31 | signal at a time $t$ can only depend on values of input signals at 32 | times $[0,t]$. Efficiency is provided by limiting history only to the 33 | immediate past, and letting signals functions explicitly carry 34 | \emph{state} for the future. Unlike other implementations of FRP, 35 | Yampa enforces a strict separation of effects and pure 36 | transformations: all IO code must exist outside Signal Functions, 37 | making systems easier to reason about and debug. 38 | 39 | Yampa has been used to create both free/open-source and commercial games. 40 | Examples of the former include Frag 41 | (\href{http://goo.gl/8bfSmz}{http://goo.gl/8bfSmz}), a basic reimplementation 42 | of the Quake III Arena engine in Haskell, and Haskanoid 43 | (\href{http://git.io/v8eq3}{http://git.io/v8eq3}), an arkanoid game featuring 44 | SDL graphics and sound with Wiimote \& Kinect support, which works on Windows, 45 | Linux, Mac, Android, iOS and web browsers (thanks to GHCJS). Examples of the 46 | latter include Keera Studios' Magic Cookies!, a Haskell puzzle board game for 47 | iOS and Android available on iTunes 48 | (\href{https://goo.gl/6gB6sb}{https://goo.gl/6gB6sb}) 49 | % https://itunes.apple.com/us/app/magic-cookies/id1244709871 50 | and Google Play 51 | (\href{https://goo.gl/0A8z6i}{https://goo.gl/0A8z6i}), and the upcoming 52 | games Pang-a-lambda and NPuzzles, also by Keera Studios. 53 | 54 | %** 55 | %*ignore 56 | \begin{center} 57 | \includegraphics[width=.7\columnwidth]{html/android.png} 58 | % \caption{Screenshot of Yampa game Haskanoid running on Android.} 59 | \end{center} 60 | %*endignore 61 | 62 | Guerric Chupin (ENSTA ParisTech), under the supervision of Henrik Nilsson 63 | (Functional Programming Lab, University of Nottingham~\cref{nottingham}) has 64 | developed Arpeggigon~\cref{arpeggigon} 65 | (\href{https://gitlab.com/chupin/arpeggigon}{https://gitlab.com/chupin/arpeggigon}), 66 | an interactive cellular automaton for composing groove-based music. The aim 67 | was to evaluate two reactive but complementary frameworks for implementing 68 | interactive time-aware applications. Arpeggigon uses Yampa for music 69 | generation, Gtk2HS for Graphical User Interface, jack for handling MIDI I/O, 70 | and Keera Hails to implement a declarative MVC architecture, based on 71 | \emph{Reactive Values and Relations} (RVRs). The results have been written up 72 | in an application paper, \emph{Funky Grooves: Declarative Programming of 73 | Full-Fledged Musical Applications}, presented at PADL 2017. The code and an 74 | extended version of the paper are publicly available 75 | (\href{https://gitlab.com/chupin/arpeggigon}{https://gitlab.com/chupin/arpeggigon}). 76 | Arpeggigon has also been demonstrated at FARM 2017, the Haskell eXchange 2017, 77 | and Haskell in Leipzig 2017. 78 | 79 | %** 80 | %*ignore 81 | \begin{center} 82 | \includegraphics[width=.7\columnwidth]{html/arpeggigon.png} 83 | % \caption{Screenshot of Guerric Chupin's Arpeggigon, which combines Reactive Values 84 | % and FRP.} 85 | \end{center} 86 | %*endignore 87 | 88 | Yampa is under active development, with many Haskellers participating and 89 | sending their contributions. Recent releases have featured a much smaller and 90 | cleaner API, a testing extension based on Temporal Logic with QuickCheck, new 91 | Signal Function combinators, and full documentation. We have also included more 92 | examples of work with different backends, including SDL, SDL2, OpenGL, 93 | Diagrams, Gloss, HTML DOM, HTML5 Canvas and WX. Our github repository includes 94 | development branches with features that have been used for custom games, some 95 | presented in the Haskell Symposium 2017 paper ``Back to the Future: time travel 96 | in FRP''. Yampa will now be extended with systematic benchmarking using an 97 | approach inspired by Martin Handley's AutoBench. 98 | 99 | We are working on extensions to make Yampa more general and modular, increase 100 | performance, enable new use cases and address existing limitations. In 2016 we 101 | published, together with Manuel B\"arenz, a monadic arrowized reactive 102 | framework called Dunai (\href{https://git.io/vXsw1}{https://git.io/vXsw1}), and 103 | a minimal FRP implementation called BearRiver. BearRiver provides all the core 104 | features of Yampa, as well as additional extensions. We have demonstrated the 105 | usefulness of our approach and the compatibility with existing Yampa games by 106 | using BearRiver to compile and execute the Haskanoid and Magic Cookies! for 107 | Android without changing the code of such games. To collaborate with our 108 | research, please contact Ivan Perez 109 | (\href{mailto:ivan.perez@acm.org}{ivan.perez@acm.org}) or Henrik Nilsson 110 | (\href{mailto:nhn@cs.nott.ac.uk}{nhn@cs.nott.ac.uk}). 111 | 112 | There are several other channels that anyone can use to reach other Yampa users 113 | and implementors, including a 114 | \href{http://mailman.cs.yale.edu/mailman/listinfo/yampa-users}{mailing list} 115 | and the \texttt{\#yampa} IRC channel on freenode. We are also active on Haskell 116 | Caf\'e and the facebook group 117 | \href{https://www.facebook.com/groups/programming.haskell/}{Programming 118 | Haskell}, and subscribe to the Yampa keyword on StackOverflow. We encourage 119 | all Haskellers to participate on Yampa's development by opening issues on our 120 | Github page (\href{http://git.io/vTvxQ}{http://git.io/vTvxQ}), adding 121 | improvements, creating tutorials and examples, and using Yampa in their next 122 | amazing Haskell games. We thank the kind users who have already sent us their 123 | contributions. 124 | \end{hcarentry} 125 | -------------------------------------------------------------------------------- /doc/hcar/android.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ivanperez-keera/Yampa/bac428449e85c29d2380709a0323168179f6345d/doc/hcar/android.gif -------------------------------------------------------------------------------- /doc/hcar/android.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ivanperez-keera/Yampa/bac428449e85c29d2380709a0323168179f6345d/doc/hcar/android.png -------------------------------------------------------------------------------- /doc/hcar/androidbreakout.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ivanperez-keera/Yampa/bac428449e85c29d2380709a0323168179f6345d/doc/hcar/androidbreakout.png -------------------------------------------------------------------------------- /doc/hcar/arpeggigon.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ivanperez-keera/Yampa/bac428449e85c29d2380709a0323168179f6345d/doc/hcar/arpeggigon.png -------------------------------------------------------------------------------- /doc/hcar/breakout.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ivanperez-keera/Yampa/bac428449e85c29d2380709a0323168179f6345d/doc/hcar/breakout.png -------------------------------------------------------------------------------- /doc/hcar/hcar.sty: -------------------------------------------------------------------------------- 1 | \ProvidesPackage{hcar} 2 | 3 | \newif\ifhcarfinal 4 | \hcarfinalfalse 5 | \DeclareOption{final}{\hcarfinaltrue} 6 | \ProcessOptions 7 | 8 | \RequirePackage{keyval} 9 | \RequirePackage{color} 10 | \RequirePackage{array} 11 | 12 | \ifhcarfinal 13 | \RequirePackage[T1]{fontenc} 14 | \RequirePackage{lmodern} 15 | \RequirePackage{tabularx} 16 | \RequirePackage{booktabs} 17 | \RequirePackage{framed} 18 | \RequirePackage[obeyspaces,T1]{url} 19 | \RequirePackage 20 | [bookmarks=true,colorlinks=true, 21 | urlcolor=urlcolor, 22 | linkcolor=linkcolor, 23 | breaklinks=true, 24 | pdftitle={Haskell Communities and Activities Report}]% 25 | {hyperref} 26 | \else 27 | \RequirePackage[obeyspaces]{url} 28 | \fi 29 | \urlstyle{sf} 30 | 31 | \definecolor{urlcolor}{rgb}{0.1,0.3,0} 32 | \definecolor{linkcolor}{rgb}{0.3,0,0} 33 | \definecolor{shadecolor}{rgb}{0.9,0.95,1}%{0.98,1.0,0.95} 34 | \definecolor{framecolor}{gray}{0.9} 35 | \definecolor{oldgray}{gray}{0.7} 36 | 37 | \newcommand{\Contact}{\subsubsection*{Contact}\raggedright} 38 | \newcommand{\FurtherReading}{\subsubsection*{Further reading}\raggedright} 39 | \newcommand{\FuturePlans}{\subsubsection*{Future plans}} 40 | \newcommand{\WhatsNew}{\subsubsection*{What is new?}} 41 | 42 | \newcommand{\Separate}{\smallskip\noindent} 43 | \newcommand{\FinalNote}{\smallskip\noindent} 44 | 45 | \newcommand{\urlpart}{\begingroup\urlstyle{sf}\Url} 46 | \newcommand{\email}[1]{\href{mailto:\EMailRepl{#1}{ at }}{$\langle$\urlpart{#1}$\rangle$}} 47 | \newcommand{\cref}[1]{($\rightarrow\,$\ref{#1})} 48 | 49 | \ifhcarfinal 50 | \let\hcarshaded=\shaded 51 | \let\endhcarshaded=\endshaded 52 | \else 53 | \newsavebox{\shadedbox} 54 | \newlength{\shadedboxwidth} 55 | \def\hcarshaded 56 | {\begingroup 57 | \setlength{\shadedboxwidth}{\linewidth}% 58 | \addtolength{\shadedboxwidth}{-2\fboxsep}% 59 | \begin{lrbox}{\shadedbox}% 60 | \begin{minipage}{\shadedboxwidth}\ignorespaces} 61 | \def\endhcarshaded 62 | {\end{minipage}% 63 | \end{lrbox}% 64 | \noindent 65 | \colorbox{shadecolor}{\usebox{\shadedbox}}% 66 | \endgroup} 67 | \fi 68 | 69 | \ifhcarfinal 70 | \newenvironment{hcartabularx} 71 | {\tabularx{\linewidth}{l>{\raggedleft}X}} 72 | {\endtabularx} 73 | \else 74 | \newenvironment{hcartabularx} 75 | {\begin{tabular}{@{}m{.3\linewidth}@{}>{\raggedleft}p{.7\linewidth}@{}}} 76 | {\end{tabular}} 77 | \fi 78 | 79 | \ifhcarfinal 80 | \let\hcartoprule=\toprule 81 | \let\hcarbottomrule=\bottomrule 82 | \else 83 | \let\hcartoprule=\hline 84 | \let\hcarbottomrule=\hline 85 | \fi 86 | 87 | \define@key{hcarentry}{chapter}[]{\let\level\chapter} 88 | \define@key{hcarentry}{section}[]{\let\level\section} 89 | \define@key{hcarentry}{subsection}[]{\let\level\subsection} 90 | \define@key{hcarentry}{subsubsection}[]{\let\level\subsubsection} 91 | \define@key{hcarentry}{level}{\let\level=#1} 92 | %\define@key{hcarentry}{label}{\def\entrylabel{\label{#1}}} 93 | \define@key{hcarentry}{new}[]% 94 | {\let\startnew=\hcarshaded\let\stopnew=\endhcarshaded 95 | \def\startupdated{\let\orig@addv\addvspace\let\addvspace\@gobble}% 96 | \def\stopupdated{\let\addvspace\orig@addv}} 97 | \define@key{hcarentry}{old}[]{\def\normalcolor{\color{oldgray}}\color{oldgray}}% 98 | \define@key{hcarentry}{updated}[]% 99 | {\def\startupdated 100 | {\leavevmode\let\orig@addv\addvspace\let\addvspace\@gobble\hcarshaded}% 101 | \def\stopupdated{\endhcarshaded\let\addvspace\orig@addv}} 102 | 103 | \def\@makeheadererror{\PackageError{hcar}{hcarentry without header}{}} 104 | 105 | \newenvironment{hcarentry}[2][]% 106 | {\let\level\subsection 107 | \let\startupdated=\empty\let\stopupdated=\empty 108 | \let\startnew=\empty\let\stopnew=\empty 109 | %\let\entrylabel=\empty 110 | \global\let\@makeheaderwarning\@makeheadererror 111 | \setkeys{hcarentry}{#1}% 112 | \startnew\startupdated 113 | \level{#2}% 114 | % test: 115 | \global\let\@currentlabel\@currentlabel 116 | %\stopupdated 117 | \let\report@\empty 118 | \let\groupleaders@\empty 119 | \let\members@\empty 120 | \let\contributors@\empty 121 | \let\participants@\empty 122 | \let\developers@\empty 123 | \let\maintainer@\empty 124 | \let\status@\empty 125 | \let\release@\empty 126 | \let\portability@\empty 127 | \let\entry@\empty}% 128 | {\stopnew\@makeheaderwarning}% 129 | 130 | \renewcommand{\labelitemi}{$\circ$} 131 | \settowidth{\leftmargini}{\labelitemi} 132 | \addtolength{\leftmargini}{\labelsep} 133 | 134 | \newcommand*\MakeKey[2]% 135 | {\expandafter\def\csname #1\endcsname##1% 136 | {\expandafter\def\csname #1@\endcsname{\Key@{#2}{##1}}\ignorespaces}} 137 | \MakeKey{report}{Report by:} 138 | \MakeKey{status}{Status:} 139 | \MakeKey{groupleaders}{Group leaders:} 140 | \MakeKey{members}{Members:} 141 | \MakeKey{contributors}{Contributors:} 142 | \MakeKey{participants}{Participants:} 143 | \MakeKey{developers}{Developers:} 144 | \MakeKey{maintainer}{Maintainer:} 145 | \MakeKey{release}{Current release:} 146 | \MakeKey{portability}{Portability:} 147 | \MakeKey{entry}{Entry:} 148 | 149 | \newcommand\Key@[2]{#1 & #2\tabularnewline} 150 | 151 | \newcommand\makeheader 152 | {\smallskip 153 | \begingroup 154 | \sffamily 155 | \small 156 | \noindent 157 | \let\ohrule\hrule 158 | \def\hrule{\color{framecolor}\ohrule}% 159 | \begin{hcartabularx} 160 | \hline 161 | \report@ 162 | \groupleaders@ 163 | \members@ 164 | \participants@ 165 | \developers@ 166 | \contributors@ 167 | \maintainer@ 168 | \status@ 169 | \release@ 170 | \portability@ 171 | \hcarbottomrule 172 | \end{hcartabularx} 173 | \endgroup 174 | \stopupdated 175 | \global\let\@makeheaderwarning\empty 176 | \@afterindentfalse 177 | \@xsect\smallskipamount} 178 | 179 | % columns/linebreaks, interchanged 180 | \newcommand\NCi{&\let\NX\NCii}% 181 | \newcommand\NCii{&\let\NX\NL}% 182 | \newcommand\NL{\\\let\NX\NCi}% 183 | \let\NX\NCi 184 | \newcommand\hcareditor[1]{ (ed.)&\\} 185 | \newcommand\hcarauthor[1]{#1\NX}% 186 | \newcommand\hcareditors[1]{\multicolumn{3}{c}{#1 (eds.)}\\[2ex]} 187 | -------------------------------------------------------------------------------- /doc/hcar/report.tex: -------------------------------------------------------------------------------- 1 | \documentclass[DIV16,twocolumn,10pt]{scrreprt} 2 | \usepackage{paralist} 3 | \usepackage{graphicx} 4 | \usepackage[final]{hcar} 5 | \usepackage{caption} 6 | 7 | %include polycode.fmt 8 | %include forall.fmt 9 | %include greek.fmt 10 | %include colorcode.fmt 11 | % \definecolor{codecolor}{rgb}{1,1,1} 12 | % \colorhs 13 | % \let\Conid\mathsf 14 | 15 | \begin{document} 16 | 17 | \include{Yampa-IY} 18 | 19 | \end{document} 20 | -------------------------------------------------------------------------------- /doc/hcar/template.tex: -------------------------------------------------------------------------------- 1 | \documentclass[DIV16,twocolumn,10pt]{scrreprt} 2 | \usepackage{paralist} 3 | \usepackage{graphicx} 4 | \usepackage[final]{hcar} 5 | 6 | %include polycode.fmt 7 | %include forall.fmt 8 | %include greek.fmt 9 | %include colorcode.fmt 10 | \definecolor{codecolor}{rgb}{1,1,1} 11 | \colorhs 12 | \let\Conid\mathsf 13 | 14 | \begin{document} 15 | 16 | \begin{hcarentry}{(MYSTUFF)} 17 | \report{(MY NAME)} 18 | \status{(PROJECT STATUS IN ONE LINE)} 19 | \participants{(PARTICIPANTS OTHER THAN MYSELF)}% optional 20 | \makeheader 21 | 22 | Put the text here. 23 | If you want to include Haskell code, consider using lhs2tex syntax (\url{http://people.cs.uu.nl/andres/lhs2tex/}). 24 | 25 | What's following are suggestions for the content of an entry. 26 | 27 | (WHAT IS IT?) 28 | 29 | (WHAT IS ITS STATUS? / WHAT HAS HAPPENED SINCE LAST TIME?) 30 | 31 | (CAN OTHERS GET IT?) 32 | 33 | (WHAT ARE THE IMMEDIATE PLANS?) 34 | 35 | \FurtherReading 36 | \url{(PROJECT URL)} 37 | \end{hcarentry} 38 | 39 | \end{document} 40 | -------------------------------------------------------------------------------- /yampa-test/CHANGELOG: -------------------------------------------------------------------------------- 1 | 2025-02-27 Ivan Perez 2 | * Version bump (0.15) (#322). 3 | 4 | 2024-12-07 Ivan Perez 5 | * Version bump (0.14.12) (#319). 6 | * Remove unused function Test.FRP.Yampa.Event.randomEventFunction (#314). 7 | * Remove unused variables in Test.FRP.Yampa.Basic (#315). 8 | * Remove redundant imports (#316). 9 | * Import functions to test from FRP.Yampa (#317). 10 | * Add version bounds to base (#320). 11 | 12 | 2024-10-07 Ivan Perez 13 | * Version bump (0.14.11) (#310). 14 | * Bump version bounds of dependencies (#309). 15 | 16 | 2024-08-07 Ivan Perez 17 | * Version bump (0.14.10) (#302). 18 | * Add test for trapezoidIntegral (#263). 19 | 20 | 2024-06-08 Ivan Perez 21 | * Version bump (0.14.9) (#299). 22 | 23 | 2024-04-07 Ivan Perez 24 | * Version bump (0.14.8) (#294). 25 | * Move definitions to separate line (#292). 26 | * Remove vertical space (#293). 27 | 28 | 2024-02-09 Ivan Perez 29 | * Version bump (0.14.7) (#289). 30 | 31 | 2023-12-07 Ivan Perez 32 | * Version bump (0.14.6) (#282). 33 | 34 | 2023-10-07 Ivan Perez 35 | * Version bump (0.14.5) (#278). 36 | * Move test for consistency with module tested (#267). 37 | 38 | 2023-08-07 Ivan Perez 39 | * Version bump (0.14.4) (#274). 40 | * Add version bounds to dependencies (#273). 41 | 42 | 2023-06-07 Ivan Perez 43 | * Version bump (0.14.3) (#269). 44 | * Improve readability of CHANGELOGs (#261). 45 | 46 | 2023-04-07 Ivan Perez 47 | * Version bump (0.14.2) (#259). 48 | * Introduce testing example from Yampa library (#257). 49 | * Conformance with style guide (#256). 50 | 51 | 2023-02-07 Ivan Perez 52 | * Version bump (0.14.1) (#251). 53 | * Add tests for module FRP.Yampa.Hybrid (#243). 54 | * Add tests for module FRP.Yampa.Arrow (#244). 55 | * Complete unit tests for FRP.Yampa.Test (#245). 56 | * Complete unit tests for FRP.Yampa.Simulation (#246). 57 | * Complete unit tests for FRP.Yampa.EventS (#247). 58 | * Complete unit tests for FRP.Yampa.Random (#248). 59 | * Complete unit tests for FRP.Yampa.Switches (#250). 60 | 61 | 2022-12-07 Ivan Perez 62 | * Version bump (0.14) (#242). 63 | * Add tests for module FRP.Yampa.Event (#237). 64 | * Explicit import from Control.Applicative with old versions of base 65 | (#239). 66 | * Complete unit tests for FRP.Yampa.Integration (#240). 67 | * Adjust to work with simple-affine-space-0.2 (#241). 68 | 69 | 2022-10-07 Ivan Perez 70 | * Version bump (0.13.7) (#238). 71 | * Update years, copyright holders (#235). 72 | 73 | 2022-08-07 Ivan Perez 74 | * Version bump (0.13.6) (#232). 75 | * Complete unit tests for FRP.Yampa.Basic (#219). 76 | * Complete unit tests for FRP.Yampa.Conditional (#225). 77 | * Complete unit tests for FRP.Yampa.Delays (#226). 78 | 79 | 2022-06-07 Ivan Perez 80 | * Version bump (0.13.5) (#220). 81 | * Fix broken link in description in Cabal file (#204). 82 | * Enable all warnings (#206). 83 | * Rename test (#208). 84 | * Adjust modules to run regression tests with QuickCheck testing module 85 | (#208). 86 | * Reorganize tests to match Yampa's module hierarchy (#216). 87 | * Style consistency of separators (#211). 88 | * Adjust format of export lists (#212). 89 | * Compress multiple empty lines (#214). 90 | * Adjust indentation to two spaces (#215). 91 | * Replace tabs with spaces (#205). 92 | * Remove local option disable warning on tabs (#206). 93 | * Format module header to conform to style guide (#207). 94 | * Align lists, tuples, records by leading comma (#213). 95 | * Reorganize declarations and tests within modules to match Yampa (#217). 96 | * Move ArrowLoop tests into InternalCore test module (#218). 97 | 98 | 2022-04-07 Ivan Perez 99 | * Version bump (0.13.4) (#203). 100 | * Syntax rules (#196). 101 | * Add regression tests (#201). 102 | * Remove incorrect tests (#198). 103 | * Add regression tests (#201). 104 | 105 | 2021-10-07 Ivan Perez 106 | * Version bump (0.13.3). 107 | 108 | 2021-09-15 Ivan Perez 109 | * Version bump (0.13.2). 110 | 111 | 2019-10-15 Ivan Perez 112 | * Version bump (0.2). 113 | * Use tasty for testing. 114 | * Thanks to @RyanGlScott. 115 | 116 | 2018-10-27 Ivan Perez 117 | * Version bump (0.1.1). 118 | * Fix bug (#108). 119 | 120 | 2018-10-21 Ivan Perez 121 | * Initial version. 122 | 123 | Copyright (c) 2014-2018, Ivan Perez. 124 | All rights reserved. 125 | 126 | -------------------------------------------------------------------------------- /yampa-test/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017-2022, Ivan Perez 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Ivan Perez nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | -- 33 | 34 | This library borrows from the Yampa library, which has the following notices: 35 | Copyright (c) 2014-2022, Ivan Perez 36 | Copyright (c) 2007-2012, George Griogidge 37 | Copyright (c) 2005-2006, Henrik Nilsson 38 | Copyright (c) 2003-2004, Henrik Nilsson, Antony Courtney and Yale University. 39 | All rights reserved. 40 | 41 | Redistribution and use in source and binary forms, with or without 42 | modification, are permitted provided that the following conditions 43 | are met: 44 | 45 | - Redistributions of source code must retain the above copyright notice, 46 | this list of conditions and the following disclaimer. 47 | 48 | - Redistributions in binary form must reproduce the above copyright 49 | notice, this list of conditions and the following disclaimer in the 50 | documentation and/or other materials provided with the distribution. 51 | 52 | - Neither name of the copyright holders nor the names of its 53 | contributors may be used to endorse or promote products derived from 54 | this software without specific prior written permission. 55 | 56 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE CONTRIBUTORS 57 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 58 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 59 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 60 | HOLDERS OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 61 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 62 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS 63 | OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 64 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR 65 | TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE 66 | USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 67 | -------------------------------------------------------------------------------- /yampa-test/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /yampa-test/examples/Testing.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | {-# LANGUAGE MultiWayIf #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | -- | 5 | -- Module : FRP.Yampa 6 | -- Copyright : (c) Ivan Perez, 2017-2023 7 | -- License : BSD-style (see the LICENSE file in the distribution) 8 | -- 9 | -- Maintainer : ivan.perez@keera.co.uk 10 | -- Stability : provisional 11 | -- Portability : non-portable (GHC extensions) 12 | module Testing where 13 | 14 | -- Examples accompanying the ICFP 2017 paper. 15 | -- 16 | -- Changes with respect to the paper: 17 | -- 18 | -- - The signature of ballTrulyFalling' in the paper was SF () Double. It's 19 | -- been changed to the intended meaning: TPred () 20 | 21 | -- - The function uniDistStreamMaxDT had the wrong type and the name on the 22 | -- paper was: uniDistStream. This has been fixed. 23 | -- 24 | 25 | import FRP.Yampa 26 | import FRP.Yampa.Stream 27 | import FRP.Yampa.QuickCheck 28 | import FRP.Yampa.LTLFuture 29 | import Test.QuickCheck 30 | 31 | -- * Sample temporal predicates 32 | 33 | -- fallingBall :: Double -> SF () Double 34 | -- fallingBall p0 = proc () -> do 35 | -- v <- integral0 -< -9.8 36 | -- p <- integral0 -< v 37 | -- returnA -< (p0 + p) 38 | 39 | ballFellLower :: Double -> TPred () 40 | ballFellLower p0 = SP (fallingBall p0 >>> arr (\p1 -> p1 <= p0)) 41 | 42 | -- > evalT (ballFellLower 100) stream01 43 | -- True 44 | 45 | ballFallingLower :: Double -> TPred () 46 | ballFallingLower p0 = Always (ballFellLower p0) 47 | 48 | -- > evalT (ballFallingLower 100) stream01 49 | -- True 50 | 51 | -- fallingBallPair :: Double -> SF () (Double, Double) 52 | -- fallingBallPair p0 = fallingBall p0 >>> (identity &&& iPre p0) 53 | 54 | ballTrulyFalling :: Double -> TPred () 55 | ballTrulyFalling p0 = 56 | Always (SP (fallingBallPair p0 >>> arr (\(pn, po) -> pn < po))) 57 | 58 | -- > evalT (ballTrulyFalling 100) stream01 59 | -- False 60 | 61 | ballTrulyFalling' :: Double -> TPred () 62 | ballTrulyFalling' p0 = 63 | Next (Always (SP (fallingBallPair p0 >>> arr (\(pn, po) -> pn < po)))) 64 | 65 | -- > evalT (ballTrulyFalling ′ 100) stream01 66 | -- True 67 | 68 | bouncingBall :: Double -> Double -> SF () (Double, Double) 69 | bouncingBall p0 v0 = switch (fallingBall'' p0 v0 >>> (identity &&& hit)) 70 | (\(p0', v0') -> bouncingBall p0' (-v0')) 71 | -- 72 | -- fallingBall'' :: Double -> Double -> SF () (Double, Double) 73 | -- fallingBall'' p0 v0 = proc () -> do 74 | -- v <- arr (v0+) <<< integral -< -9.8 75 | -- p <- arr (p0+) <<< integral -< v 76 | -- returnA -< (p, v) 77 | -- 78 | -- hit :: SF (Double, Double) (Event (Double, Double)) 79 | -- hit = arr 80 | -- (\(p0, v0) -> if ((p0 <= 0) && (v0 < 0)) then Event (p0, v0) else NoEvent) 81 | 82 | ballLower :: Double -> TPred () 83 | ballLower p0 = Always (SP (bouncingBall p0 0 >>> arr (\(p1, v1) -> p1 <= p0))) 84 | 85 | -- > evalT (ballBouncingLower 100) stream05 86 | -- False 87 | 88 | ballBouncingLower = ballLower 89 | 90 | ballOverFloor :: Double -> TPred () 91 | ballOverFloor p0 = 92 | Always (SP (bouncingBall p0 0 >>> arr (\(p1, v1) -> p1 >= 0))) 93 | 94 | -- > evalT (ballOverFloor 100) stream05 95 | -- False 96 | 97 | fallingBall :: Double -> SF () Double 98 | fallingBall p0 = constant (-9.8) >>> integral0 >>> integral0 >>> arr (+p0) 99 | 100 | -- ballFellLower :: Double -> TPred () 101 | -- ballFellLower p0 = SP (fallingBall p0, (\_ p1 -> p1 <= p0)) 102 | 103 | testFellBall = evalT (ballFellLower 100) stream0_1 104 | 105 | testFellBall2 = evalT (ballFellLower 100) stream0_2 106 | 107 | testFallingBall = evalT (ballFallingLower 100) stream0_1 108 | 109 | fallingBallPair :: Double -> SF () (Double, Double) 110 | fallingBallPair p0 = fallingBall p0 >>> (identity &&& iPre p0) 111 | 112 | -- ballTrulyFalling :: Double -> TPred () 113 | -- ballTrulyFalling p0 = 114 | -- Always $ SP (fallingBallPair p0, \() (pn,po) -> pn < po) 115 | 116 | testBallTrulyFalling = evalT (ballTrulyFalling 100) stream0_1 117 | 118 | -- ballTrulyFalling' :: Double -> TPred () 119 | -- ballTrulyFalling' p0 = 120 | -- Next $ Always $ SP (fallingBallPair p0, \() (pn,po) -> pn < po) 121 | 122 | testBallTrulyFalling' = evalT (ballTrulyFalling' 100) stream0_1 123 | 124 | fallingBall'' :: Double -> Double -> SF () (Double, Double) 125 | fallingBall'' p0 v0 = proc () -> do 126 | v <- arr (v0 +) <<< integral -< -9.8 127 | p <- arr (p0 +) <<< integral -< v 128 | returnA -< (p, v) 129 | 130 | hit :: SF (Double, Double) (Event (Double, Double)) 131 | hit = 132 | arr (\(p0, v0) -> if (p0 <= 0 && v0 < 0) then Event (p0, v0) else NoEvent) 133 | 134 | -- bouncingBall :: Double -> Double -> SF () (Double, Double) 135 | -- bouncingBall p0 v0 = switch (fallingBall'' p0 v0 >>> (identity &&& hit)) 136 | -- (\(p0', v0') -> bouncingBall p0' (-v0')) 137 | 138 | -- ballBouncingLower :: Double -> TPred () 139 | -- ballBouncingLower p0 = 140 | -- Always $ SP (bouncingBall p0 0, (\_ (p1,_) -> p1 <= p0)) 141 | 142 | testBallBouncing = evalT (ballBouncingLower 100) stream0_5 143 | 144 | showBallBouncing = 145 | embed 146 | (bouncingBall 100 0 >>> arr fst ) 147 | ((), map (second Just) (replicate 39 (0.5, ()))) 148 | 149 | -- ballOverFloor :: Double -> TPred () 150 | -- ballOverFloor p0 = Always $ SP (bouncingBall p0 0, (\_ (p1, v1) -> p1 >= 0)) 151 | 152 | testBallOverFloor = evalT (ballOverFloor 100) stream0_5' 153 | 154 | showBallBouncing1 = 155 | embed 156 | (bouncingBall 110.24999999999999 0 >>> arr fst ) 157 | ((), map (second Just) (replicate 102 (0.5, ()))) 158 | 159 | testBallOverFloor' = evalT (ballOverFloor 110.24999999999999) stream0_5' 160 | 161 | propTestBallOverFloor = 162 | forAll myStream (evalT (ballOverFloor 110.24999999999999)) 163 | where myStream :: Gen (SignalSampleStream ()) 164 | myStream = uniDistStream 165 | 166 | propTestBallOverFloorFixed = 167 | forAll myStream (evalT (ballOverFloor 110.24999999999999)) 168 | where myStream :: Gen (SignalSampleStream ()) 169 | myStream = fixedDelayStream (1/60) 170 | 171 | bouncingBall' p0 v0 = bouncingBall p0 v0 >>> arr fst 172 | 173 | ballAboveFloor :: Double -> Double -> SF () (Double, Bool) 174 | ballAboveFloor p0 v0 = proc () -> do 175 | ballPos <- bouncingBall' p0 v0 -< () 176 | let aboveFloor = ballPos >= 0 177 | returnA -< (ballPos, aboveFloor) 178 | 179 | -- * Sample streams 180 | 181 | stream0_1 = ((), replicate 21 (0.1, ())) 182 | 183 | stream0_2 = ((), (replicate 20 (0.1, ())) ++ [(-1000000, ())]) 184 | 185 | stream0_5 = ((), replicate 39 (0.5, ())) 186 | 187 | stream0_5' = ((), replicate 20 (0.5, ())) 188 | 189 | -- ** Extended SFs 190 | 191 | integral0 = imIntegral 0 192 | 193 | -- * Talk 194 | 195 | greaterThan :: SF (Int, Int) Bool 196 | greaterThan = arr $ \(x,y) -> x > y 197 | 198 | alwaysGreater :: TPred (Int, Int) 199 | alwaysGreater = Always $ SP greaterThan 200 | 201 | -- > evalT alwaysGreater ((5,1), [(0.001, (6, 1)), (0.001, (9, 2))]) 202 | -- True 203 | eval1 = evalT alwaysGreater ((5,1), [(0.001, (6, 1)), (0.001, (9, 2))]) 204 | 205 | -- > evalT alwaysGreater ((1,5), [(0.001, (6, 1)), (0.001, (9, 2))]) 206 | -- False 207 | eval2 = evalT alwaysGreater ((1,5), [(0.001, (6, 1)), (0.001, (9, 2))]) 208 | 209 | alwaysGreaterProperty :: Property 210 | alwaysGreaterProperty = forAll arbitrary (evalT alwaysGreater) 211 | 212 | evalQ1 = quickCheck alwaysGreaterProperty 213 | -------------------------------------------------------------------------------- /yampa-test/src/FRP/Yampa/Debug.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Copyright : (c) Ivan Perez, 2017-2022 3 | -- License : BSD-style (see the LICENSE file in the distribution) 4 | -- Maintainer : ivan.perez@keera.co.uk 5 | -- 6 | -- Debug FRP networks by inspecting their behaviour inside. 7 | module FRP.Yampa.Debug where 8 | 9 | -- External imports 10 | import Debug.Trace (trace) 11 | import FRP.Yampa (SF, arr) 12 | import System.IO.Unsafe (unsafePerformIO) 13 | 14 | -- | Signal Function that prints the value passing through using 'trace'. 15 | traceSF :: Show a => SF a a 16 | traceSF = traceSFWith show 17 | 18 | -- | Signal Function that prints the value passing through using 'trace', and a 19 | -- customizable 'show' function. 20 | traceSFWith :: (a -> String) -> SF a a 21 | traceSFWith f = arr (\x -> trace (f x) x) 22 | 23 | -- | Execute an IO action using 'unsafePerformIO' at every step, and ignore the 24 | -- result. 25 | traceSFWithIO :: (a -> IO b) -> SF a a 26 | traceSFWithIO f = arr (\x -> unsafePerformIO (f x >> return x)) 27 | -------------------------------------------------------------------------------- /yampa-test/src/FRP/Yampa/LTLFuture.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | -- | 3 | -- Copyright : (c) Ivan Perez, 2017-2022 4 | -- License : BSD-style (see the LICENSE file in the distribution) 5 | -- Maintainer : ivan.perez@keera.co.uk 6 | -- 7 | -- Linear Temporal Logics based on SFs. 8 | -- 9 | -- This module contains a definition of LTL with Next on top of Signal 10 | -- Functions. 11 | -- 12 | -- LTL predicates are parameterized over an input. A basic proposition is a 13 | -- Signal Function that produces a boolean function. 14 | module FRP.Yampa.LTLFuture 15 | ( TPred(..) 16 | , evalT 17 | ) 18 | where 19 | 20 | -- External imports 21 | import FRP.Yampa (DTime, SF, evalFuture) 22 | 23 | -- Internal imports 24 | import FRP.Yampa.Stream (SignalSampleStream, evalSF, firstSample) 25 | 26 | -- | Type representing future-time linear temporal logic predicates with until 27 | -- and next. 28 | data TPred a where 29 | SP :: SF a Bool -> TPred a 30 | And :: TPred a -> TPred a -> TPred a 31 | Or :: TPred a -> TPred a -> TPred a 32 | Not :: TPred a -> TPred a 33 | Implies :: TPred a -> TPred a -> TPred a 34 | Always :: TPred a -> TPred a 35 | Eventually :: TPred a -> TPred a 36 | Next :: TPred a -> TPred a 37 | Until :: TPred a -> TPred a -> TPred a 38 | 39 | -- | Evaluates a temporal predicate at time t=0 with a concrete sample stream. 40 | -- 41 | -- Returns 'True' if the temporal proposition is currently true. 42 | evalT :: TPred a -> SignalSampleStream a -> Bool 43 | evalT (SP sf) = \stream -> firstSample $ fst $ evalSF sf stream 44 | evalT (And t1 t2) = \stream -> evalT t1 stream && evalT t2 stream 45 | evalT (Or t1 t2) = \stream -> evalT t1 stream || evalT t2 stream 46 | evalT (Not t1) = \stream -> not (evalT t1 stream) 47 | evalT (Implies t1 t2) = \stream -> not (evalT t1 stream) || evalT t2 stream 48 | evalT (Always t1) = \stream -> 49 | evalT t1 stream && evalT (Next (Always t1)) stream 50 | 51 | evalT (Eventually t1) = \stream -> 52 | case stream of 53 | (a, []) -> evalT t1 stream 54 | (a1, (dt, a2) : as) -> evalT t1 stream 55 | || evalT (tauApp (Eventually t1) a1 dt) (a2, as) 56 | 57 | evalT (Until t1 t2) = \stream -> 58 | (evalT t1 stream && evalT (Next (Until t1 t2)) stream) 59 | || evalT t2 stream 60 | 61 | evalT (Next t1) = \stream -> 62 | case stream of 63 | (a, []) -> True -- This is important. It determines how 64 | -- always and next behave at the end of the 65 | -- stream, which affects that is and isn't a 66 | -- tautology. It should be reviewed very 67 | -- carefully. 68 | (a1, (dt, a2) : as) -> evalT (tauApp t1 a1 dt) (a2, as) 69 | 70 | -- | Tau-application (transportation to the future) 71 | tauApp :: TPred a -> a -> DTime -> TPred a 72 | tauApp pred sample dtime = 73 | tPredMap (\sf -> snd (evalFuture sf sample dtime)) pred 74 | 75 | -- | Apply a transformation to the leaves (to the SFs) 76 | tPredMap :: (SF a Bool -> SF a Bool) -> TPred a -> TPred a 77 | tPredMap f (SP sf) = SP (f sf) 78 | tPredMap f (And t1 t2) = And (tPredMap f t1) (tPredMap f t2) 79 | tPredMap f (Or t1 t2) = Or (tPredMap f t1) (tPredMap f t2) 80 | tPredMap f (Not t1) = Not (tPredMap f t1) 81 | tPredMap f (Implies t1 t2) = Implies (tPredMap f t1) (tPredMap f t2) 82 | tPredMap f (Always t1) = Always (tPredMap f t1) 83 | tPredMap f (Eventually t1) = Eventually (tPredMap f t1) 84 | tPredMap f (Next t1) = Next (tPredMap f t1) 85 | tPredMap f (Until t1 t2) = Until (tPredMap f t1) (tPredMap f t2) 86 | -------------------------------------------------------------------------------- /yampa-test/src/FRP/Yampa/LTLPast.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Copyright : (c) Ivan Perez, 2017-2022 3 | -- License : BSD-style (see the LICENSE file in the distribution) 4 | -- Maintainer : ivan.perez@keera.co.uk 5 | -- 6 | -- Past-time Linear Temporal Logics based on SFs. 7 | -- 8 | -- This module contains a definition of ptLTL with prev/last on top of Signal 9 | -- Functions. 10 | -- 11 | -- The difference between the future time and the past time LTL is that the 12 | -- former needs a trace for evaluation, and the latter can be embedded into a 13 | -- signal function network without additional support for evaluation. 14 | module FRP.Yampa.LTLPast where 15 | 16 | -- External imports 17 | import FRP.Yampa (Event (..), SF, arr, iPre, loopPre, switch, (>>>)) 18 | 19 | -- | True if both inputs are True. 20 | andSF :: SF (Bool, Bool) Bool 21 | andSF = arr (uncurry (&&)) 22 | 23 | -- | True if either or both inputs are True. 24 | orSF :: SF (Bool, Bool) Bool 25 | orSF = arr (uncurry (||)) 26 | 27 | -- | True if the input signal is False. 28 | notSF :: SF Bool Bool 29 | notSF = arr not 30 | 31 | -- | True if the first signal is False or the second one is True. 32 | impliesSF :: SF (Bool, Bool) Bool 33 | impliesSF = arr $ \(i, p) -> not i || p 34 | 35 | -- | True a a time if the input signal has been always True so far. 36 | sofarSF :: SF Bool Bool 37 | sofarSF = loopPre True $ arr $ \(n, o) -> let n' = o && n in (n', n') 38 | 39 | -- | True at a time if the input signal has ever been True before. 40 | everSF :: SF Bool Bool 41 | everSF = loopPre False $ arr $ \(n, o) -> let n' = o || n in (n', n') 42 | 43 | -- | True if the signal was True in the last sample. False at time zero. 44 | lastSF :: SF Bool Bool 45 | lastSF = iPre False 46 | 47 | -- | Weak Until. True if the first signal is True until the second becomes 48 | -- True, if ever. 49 | untilSF :: SF (Bool, Bool) Bool 50 | untilSF = switch 51 | (loopPre True $ arr (\((i, u), o) -> 52 | let n = o && i 53 | in ((n, if o && u then Event () else NoEvent), n))) 54 | (\_ -> arr snd >>> sofarSF) 55 | -------------------------------------------------------------------------------- /yampa-test/src/FRP/Yampa/QuickCheck.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | -- | 3 | -- Copyright : (c) Ivan Perez, 2017-2022 4 | -- License : BSD-style (see the LICENSE file in the distribution) 5 | -- Maintainer : ivan.perez@keera.co.uk 6 | -- 7 | -- QuickCheck generators for input streams. 8 | -- 9 | -- Random stream generation can be customized usin three parameters: 10 | -- 11 | -- - The distribution for the random time deltas ('Distribution'). 12 | -- - The maximum and minimum bounds for the time deltas ('Range'). 13 | -- - The maximum stream length ('Length'). 14 | -- 15 | -- The main function to generate streams is 'generateStream'. The specific time 16 | -- deltas can be customized further using 'generateStreamWith'. Some helper 17 | -- functions are provided to facilitate testing. 18 | module FRP.Yampa.QuickCheck 19 | ( 20 | -- * Random stream generation 21 | generateStream 22 | , generateStreamWith 23 | 24 | -- ** Parameters used to generate random input streams 25 | , Distribution(..) 26 | , Range 27 | , Length 28 | 29 | -- ** Helpers for common cases 30 | , uniDistStream 31 | , uniDistStreamMaxDT 32 | , fixedDelayStream 33 | , fixedDelayStreamWith 34 | ) 35 | where 36 | 37 | -- External imports 38 | import Control.Applicative (pure, (<$>)) 39 | import Data.Random.Normal (normal') 40 | import FRP.Yampa (DTime) 41 | import Test.QuickCheck (Arbitrary (arbitrary), choose, getPositive, 42 | suchThat) 43 | import Test.QuickCheck.Gen (Gen (MkGen)) 44 | 45 | -- Internal imports 46 | import FRP.Yampa.Stream (SignalSampleStream, groupDeltas) 47 | 48 | -- * Random stream generation 49 | 50 | -- | Generate random stream. 51 | generateStream :: Arbitrary a 52 | => Distribution -> Range -> Length -> Gen (SignalSampleStream a) 53 | generateStream = generateStreamWith (\_ _ -> arbitrary) 54 | 55 | -- | Generate random stream, parameterized by the value generator. 56 | generateStreamWith :: Arbitrary a 57 | => (Int -> DTime -> Gen a) 58 | -> Distribution 59 | -> Range 60 | -> Length 61 | -> Gen (SignalSampleStream a) 62 | generateStreamWith arb DistConstant range len = 63 | generateConstantStream arb =<< generateStreamLenDT range len 64 | generateStreamWith arb dist (m, n) len = do 65 | ds <- generateDeltas len 66 | let l = length ds 67 | let f n = arb n (ds !! (n - 1)) 68 | xs <- vectorOfWith l f 69 | 70 | x <- arb 0 0 71 | return $ groupDeltas (x:xs) ds 72 | 73 | where 74 | 75 | deltaF :: Gen DTime 76 | deltaF = case dist of 77 | DistRandom -> generateDelta m n 78 | DistNormal (avg, stddev) -> generateDSNormal avg stddev m n 79 | _ -> error "yampa-test: generateStreamWith" 80 | 81 | generateDeltas :: Length -> Gen [DTime] 82 | generateDeltas Nothing = do l <- arbitrary 83 | vectorOfWith l (\_ -> deltaF) 84 | generateDeltas (Just (Left l)) = vectorOfWith l (\_ -> deltaF) 85 | generateDeltas (Just (Right maxds)) = timeStampsUntilWith deltaF maxds 86 | 87 | -- | Generate arbitrary stream with fixed length and constant delta. 88 | generateConstantStream :: (Int -> DTime -> Gen a) 89 | -> (DTime, Int) 90 | -> Gen (SignalSampleStream a) 91 | generateConstantStream arb (x, length) = do 92 | ys <- vectorOfWith length (\n -> arb n x) 93 | return $ groupDeltas ys ds 94 | where 95 | ds = repeat x 96 | 97 | -- | Generate arbitrary stream 98 | generateStreamLenDT :: (Maybe DTime, Maybe DTime) 99 | -> Maybe (Either Int DTime) 100 | -> Gen (DTime, Int) 101 | generateStreamLenDT range len = do 102 | x <- uncurry generateDelta range 103 | l <- case len of 104 | Nothing -> (1 +) . getPositive <$> arbitrary 105 | Just (Left l) -> pure l 106 | Just (Right ds) -> max 1 <$> pure (floor (ds / x)) 107 | return (x, l) 108 | 109 | -- | Generate one random delta, possibly within a range. 110 | generateDelta :: Maybe DTime -> Maybe DTime -> Gen DTime 111 | generateDelta (Just x) (Just y) = choose (x, y) 112 | generateDelta (Just x) Nothing = (x +) <$> arbitrary 113 | generateDelta Nothing (Just y) = choose (2.2251e-308, y) 114 | generateDelta Nothing Nothing = getPositive <$> arbitrary 115 | 116 | -- | Generate a random delta following a normal distribution, and possibly 117 | -- within a given range. 118 | generateDSNormal :: DTime -> DTime -> Maybe DTime -> Maybe DTime -> Gen DTime 119 | generateDSNormal avg stddev m n = suchThat gen (\x -> mx x && mn x) 120 | where 121 | gen = MkGen (\r _ -> fst $ normal' (avg, stddev) r) 122 | mn = maybe (\_ -> True) (<=) m 123 | mx = maybe (\_ -> True) (>=) n 124 | 125 | -- | Generate random samples up until a max time, with a given time delta 126 | -- generation function. 127 | timeStampsUntilWith :: Gen DTime -> DTime -> Gen [DTime] 128 | timeStampsUntilWith arb ds = timeStampsUntilWith' arb [] ds 129 | where 130 | -- | Generate random samples up until a max time, with a given time delta 131 | -- generation function, and an initial suffix of time deltas. 132 | timeStampsUntilWith' :: Gen DTime -> [DTime] -> DTime -> Gen [DTime] 133 | timeStampsUntilWith' arb acc ds 134 | | ds < 0 = return acc 135 | | otherwise = do d <- arb 136 | let acc' = acc `seq` (d:acc) 137 | acc' `seq` timeStampsUntilWith' arb acc' (ds - d) 138 | 139 | -- ** Parameters used to generate random input streams 140 | 141 | -- | Distributions used for time delta (DT) generation. 142 | data Distribution 143 | = DistConstant -- ^ Constant DT for the whole stream. 144 | | DistNormal (DTime, DTime) -- ^ Variable DT following normal distribution, 145 | -- with an average and a standard deviation. 146 | | DistRandom -- ^ Completely random (positive) DT. 147 | 148 | -- | Upper and lower bounds of time deltas for random DT generation. 149 | type Range = (Maybe DTime, Maybe DTime) 150 | 151 | -- | Optional maximum length for a stream, given as a time, or a number of 152 | -- samples. 153 | type Length = Maybe (Either Int DTime) 154 | 155 | -- ** Helpers for common cases 156 | 157 | -- | Generate a stream of values with uniformly distributed time deltas. 158 | uniDistStream :: Arbitrary a => Gen (SignalSampleStream a) 159 | uniDistStream = generateStream DistRandom (Nothing, Nothing) Nothing 160 | 161 | -- | Generate a stream of values with uniformly distributed time deltas, with a 162 | -- max DT. 163 | uniDistStreamMaxDT :: Arbitrary a => DTime -> Gen (SignalSampleStream a) 164 | uniDistStreamMaxDT maxDT = 165 | generateStream DistRandom (Nothing, Just maxDT ) Nothing 166 | 167 | -- | Generate a stream of values with a fixed time delta. 168 | fixedDelayStream :: Arbitrary a => DTime -> Gen (SignalSampleStream a) 169 | fixedDelayStream dt = generateStream DistConstant (Just dt, Just dt) Nothing 170 | 171 | -- | Generate a stream of values with a fixed time delta. 172 | fixedDelayStreamWith :: Arbitrary a 173 | => (DTime -> a) 174 | -> DTime 175 | -> Gen (SignalSampleStream a) 176 | fixedDelayStreamWith f dt = 177 | generateStreamWith f' DistConstant (Just dt, Just dt) Nothing 178 | where 179 | f' n t = return $ f (fromIntegral n * t) 180 | 181 | -- * Extended quickcheck generator 182 | 183 | -- | Generates a list of the given length. 184 | vectorOfWith :: Int -> (Int -> Gen a) -> Gen [a] 185 | vectorOfWith k genF = sequence [ genF i | i <- [1..k] ] 186 | -------------------------------------------------------------------------------- /yampa-test/src/FRP/Yampa/Stream.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Copyright : (c) Ivan Perez, 2017-2022 3 | -- License : BSD-style (see the LICENSE file in the distribution) 4 | -- Maintainer : ivan.perez@keera.co.uk 5 | -- 6 | -- Streams and stream manipulation API. 7 | -- 8 | -- The evaluation of Yampa SFs, especially for testing purposes, needs the 9 | -- generation of suitable input streams. 10 | -- 11 | -- While some streams can be generated randomly using QuickCheck, it is 12 | -- sometimes useful to be able to preprend or adapt an input stream. It is also 13 | -- useful to debug programs when you have recorded input streams using Haskell 14 | -- Titan. 15 | -- 16 | -- This module defines types for input streams, as well as an API to create, 17 | -- examine and combine streams. It also provides evaluation functions that are 18 | -- needed to apply an SF to a stream and obtain an output stream and a 19 | -- continuation SF. 20 | module FRP.Yampa.Stream where 21 | 22 | -- External imports 23 | import FRP.Yampa (DTime, FutureSF, SF, evalAt, evalAtZero) 24 | 25 | -- * Types 26 | 27 | -- | A stream of samples, with their sampling times. 28 | type SignalSampleStream a = (a, FutureSampleStream a) 29 | 30 | -- | A stream of future samples, with their sampling times. The difference 31 | -- between 'SignalSampleStream' and 'FutureSampleStream' is that all elements 32 | -- in the latter have a non-zero time delta. 33 | type FutureSampleStream a = [(DTime, a)] 34 | 35 | -- * Creation 36 | 37 | -- | Group a series of samples with a series of time deltas. 38 | -- 39 | -- The first sample will have no delta. Unused samples and deltas will be 40 | -- dropped. 41 | groupDeltas :: [a] -> [DTime] -> SignalSampleStream a 42 | groupDeltas (x:xs) ds = (x, zip ds xs) 43 | groupDeltas xs ds = 44 | error $ "groupDeltas: called me with lists with lengths" 45 | ++ show (length xs) ++ " and " ++ show (length ds) 46 | 47 | -- * Examination 48 | 49 | -- | Turn a stream with sampling times into a list of values. 50 | samples :: SignalSampleStream a -> [a] 51 | samples (a, as) = a : map snd as 52 | 53 | -- | Return the first sample in a sample stream. 54 | firstSample :: SignalSampleStream a -> a 55 | firstSample = head . samples 56 | 57 | -- | Return the last sample in a sample stream. 58 | lastSample :: SignalSampleStream a -> a 59 | lastSample = last . samples 60 | 61 | -- * Manipulation 62 | 63 | -- | Merge two streams, using an auxilary function to merge samples that fall 64 | -- at the exact same sampling time. 65 | sMerge :: (a -> a -> a) 66 | -> SignalSampleStream a 67 | -> SignalSampleStream a 68 | -> SignalSampleStream a 69 | sMerge f (x1, xs1) (x2, xs2) = (f x1 x2, sMergeTail f xs1 xs2) 70 | where 71 | sMergeTail :: (a -> a -> a) 72 | -> FutureSampleStream a 73 | -> FutureSampleStream a 74 | -> FutureSampleStream a 75 | sMergeTail f [] xs2 = xs2 76 | sMergeTail f xs1 [] = xs1 77 | sMergeTail f ((dt1, x1) : xs1) ((dt2, x2) : xs2) 78 | | dt1 == dt2 = (dt1, f x1 x2) : sMergeTail f xs1 xs2 79 | | dt1 < dt2 = (dt1, x1) : sMergeTail f xs1 ((dt2 - dt1, x2) : xs2) 80 | | otherwise = (dt2, x2) : sMergeTail f ((dt1 - dt2, x1) : xs1) xs2 81 | 82 | -- | Concatenate two sample streams, separating them by a given time delta. 83 | sConcat :: SignalSampleStream a 84 | -> DTime 85 | -> SignalSampleStream a 86 | -> SignalSampleStream a 87 | sConcat (x1, xs1) dt (x2, xs2) = (x1, xs1 ++ ((dt, x2) : xs2)) 88 | 89 | -- | Refine a stream by establishing the maximum time delta. 90 | -- 91 | -- If two samples are separated by a time delta bigger than the given max DT, 92 | -- the former is replicated as many times as necessary. 93 | sRefine :: DTime -> SignalSampleStream a -> SignalSampleStream a 94 | sRefine maxDT (a, as) = (a, sRefineFutureStream maxDT a as) 95 | where 96 | sRefineFutureStream :: DTime 97 | -> a 98 | -> FutureSampleStream a 99 | -> FutureSampleStream a 100 | sRefineFutureStream maxDT _ [] = [] 101 | sRefineFutureStream maxDT a0 ((dt, a) : as) 102 | | dt > maxDT = 103 | (maxDT, a0) : sRefineFutureStream maxDT a0 ((dt - maxDT, a) : as) 104 | | otherwise = (dt, a) : sRefineFutureStream maxDT a as 105 | 106 | -- | Refine a stream by establishing the maximum time delta. 107 | -- 108 | -- If two samples are separated by a time delta bigger than the given max DT, 109 | -- the auxiliary interpolation function is used to determine the intermendiate 110 | -- sample. 111 | sRefineWith :: (a -> a -> a) 112 | -> DTime 113 | -> SignalSampleStream a 114 | -> SignalSampleStream a 115 | sRefineWith interpolate maxDT (a, as) = 116 | (a, refineFutureStreamWith interpolate maxDT a as) 117 | where 118 | refineFutureStreamWith :: (a -> a -> a) 119 | -> DTime 120 | -> a 121 | -> FutureSampleStream a 122 | -> FutureSampleStream a 123 | refineFutureStreamWith interpolate maxDT _ [] = [] 124 | refineFutureStreamWith interpolate maxDT a0 ((dt, a) : as) 125 | | dt > maxDT 126 | = (maxDT, a') 127 | : refineFutureStreamWith interpolate maxDT a' ((dt - maxDT, a) : as) 128 | | otherwise 129 | = (dt, a) : refineFutureStreamWith interpolate maxDT a as 130 | where 131 | a' = interpolate a0 a 132 | 133 | -- | Clip a sample stream at a given number of samples. 134 | sClipAfterFrame :: Int -> SignalSampleStream a -> SignalSampleStream a 135 | sClipAfterFrame 0 (x, _) = (x, []) 136 | sClipAfterFrame n (x, xs) = (x, xs') 137 | where 138 | xs' = take (n - 1) xs 139 | 140 | -- | Clip a sample stream after a certain (non-zero) time. 141 | sClipAfterTime :: DTime -> SignalSampleStream a -> SignalSampleStream a 142 | sClipAfterTime dt (x, xs) = (x, sClipAfterTime' dt xs) 143 | where 144 | sClipAfterTime' dt [] = [] 145 | sClipAfterTime' dt ((dt', x) : xs) 146 | | dt < dt' = [] 147 | | otherwise = (dt', x) : sClipAfterTime' (dt - dt') xs 148 | 149 | -- | Drop the first n samples of a signal stream. The time 150 | -- deltas are not re-calculated. 151 | sClipBeforeFrame :: Int -> SignalSampleStream a -> SignalSampleStream a 152 | sClipBeforeFrame 0 (x, xs) = (x, xs) 153 | sClipBeforeFrame n (x, []) = (x, []) 154 | sClipBeforeFrame n (_, (dt, x) : xs) = sClipBeforeFrame (n - 1) (x, xs) 155 | 156 | -- | Drop the first samples of a signal stream up to a given time. The time 157 | -- deltas are not re-calculated to match the original stream. 158 | sClipBeforeTime :: DTime -> SignalSampleStream a -> SignalSampleStream a 159 | sClipBeforeTime dt xs 160 | | dt <= 0 = xs 161 | | null (snd xs) = xs 162 | | dt < dt' = (x', xs') 163 | | otherwise = sClipBeforeTime (dt - dt') (x', xs') 164 | where 165 | (_fstSample, ((dt', x') : xs')) = xs 166 | 167 | -- ** Stream-based evaluation 168 | 169 | -- | Evaluate an SF with a 'SignalSampleStream', obtaining an output 170 | -- stream and a continuation. 171 | -- 172 | -- You should never use this for actual execution in your applications, 173 | -- only for testing. 174 | evalSF :: SF a b 175 | -> SignalSampleStream a 176 | -> (SignalSampleStream b, FutureSF a b) 177 | evalSF sf (a, as) = (outputStrm, fsf') 178 | where 179 | (b, fsf) = evalAtZero sf a 180 | (bs, fsf') = evalFutureSF fsf as 181 | outputStrm = (b, bs) 182 | 183 | -- | Evaluate an initialised SF with a 'FutureSampleStream', obtaining 184 | -- an output stream and a continuation. 185 | -- 186 | -- You should never use this for actual execution in your applications, 187 | -- only for testing. 188 | evalFutureSF :: FutureSF a b 189 | -> FutureSampleStream a 190 | -> (FutureSampleStream b, FutureSF a b) 191 | evalFutureSF fsf [] = ([], fsf) 192 | evalFutureSF fsf ((dt, a) : as) = (outputStrm, fsf'') 193 | where 194 | (b, fsf') = evalAt fsf dt a 195 | (bs, fsf'') = evalFutureSF fsf' as 196 | outputStrm = (dt, b) : bs 197 | -------------------------------------------------------------------------------- /yampa-test/tests/Main.hs: -------------------------------------------------------------------------------- 1 | -- VectorSpace has caused some ambiguity problems. See e.g. looplaws_t2, 2 | -- switch_t1a. 3 | -- 4 | -- 2005-11-26: A simple way of making many test cases more robust would 5 | -- be to have a version of deltaEncode that adds a little extra time 6 | -- to the very first delta time. That way sampling would always be slightly 7 | -- "late". 8 | -- 9 | -- But since we often compare time stamps, we'd also either have 10 | -- to adjust the "~=" relation to tolerate "jitter" of that magnitute, 11 | -- or we'd have to formulate many tests more carefully to allow a 12 | -- certain "fuzziness". 13 | module Main where 14 | 15 | import Test.Tasty (TestTree, defaultMain, testGroup) 16 | 17 | import qualified Test.FRP.Yampa.Arrow as Arrow 18 | import qualified Test.FRP.Yampa.Basic as Basic 19 | import qualified Test.FRP.Yampa.Conditional as Conditional 20 | import qualified Test.FRP.Yampa.Delays as Delays 21 | import qualified Test.FRP.Yampa.Event as Event 22 | import qualified Test.FRP.Yampa.EventS as EventS 23 | import qualified Test.FRP.Yampa.Hybrid as Hybrid 24 | import qualified Test.FRP.Yampa.Integration as Integration 25 | import qualified Test.FRP.Yampa.InternalCore as InternalCore 26 | import qualified Test.FRP.Yampa.Loop as Loop 27 | import qualified Test.FRP.Yampa.Random as Random 28 | import qualified Test.FRP.Yampa.Scan as Scan 29 | import qualified Test.FRP.Yampa.Simulation as Simulation 30 | import qualified Test.FRP.Yampa.Switches as Switches 31 | import qualified Test.FRP.Yampa.Task as Task 32 | import qualified Test.FRP.Yampa.Time as Time 33 | 34 | main :: IO () 35 | main = defaultMain tests 36 | 37 | tests :: TestTree 38 | tests = testGroup "Yampa QC properties" 39 | [ Arrow.tests 40 | , Basic.tests 41 | , Conditional.tests 42 | , Delays.tests 43 | , Event.tests 44 | , EventS.tests 45 | , Hybrid.tests 46 | , Integration.tests 47 | , InternalCore.tests 48 | , Loop.tests 49 | , Random.tests 50 | , Scan.tests 51 | , Simulation.tests 52 | , Switches.tests 53 | , Task.tests 54 | , Time.tests 55 | ] 56 | -------------------------------------------------------------------------------- /yampa-test/tests/Space.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Space 3 | -- Description : Space tests. 4 | -- Copyright : Yale University, 2003 5 | -- Authors : Henrik Nilsson and Antony Courtney 6 | module Main where 7 | 8 | import FRP.Yampa 9 | import Data.List (findIndex) 10 | import System.IO.Unsafe (unsafePerformIO) 11 | import Data.IORef (newIORef, writeIORef, readIORef) 12 | 13 | import TestsCommon (REq(..)) 14 | 15 | main :: IO () 16 | main = do 17 | putStrLn "" 18 | putStrLn "Running the Yampa space tests ..." 19 | putStrLn "Testing the space behaviour. This may take a LONG time." 20 | putStrLn "Observe the process size using some tool like top." 21 | putStrLn "The process should not grow significantly." 22 | putStrLn "Emitted success/failure indications signify termination" 23 | putStrLn "and whether or not the right result was obtained. They do" 24 | putStrLn "not necessarily indicate that the space behaviour is correct" 25 | putStrLn "(i.e., absence of leaks)." 26 | putStrLn "" 27 | rst "arr" 0 arr_st0 arr_st0r 28 | rst "arr" 1 arr_st1 arr_st1r 29 | rst "loop" 0 loop_st0 loop_st0r 30 | rst "loop" 1 loop_st1 loop_st1r 31 | rst "rswitch" 0 rswitch_st0 rswitch_st0r 32 | rst "pswitch" 0 pswitch_st0 pswitch_st0r 33 | rst "pswitch" 1 pswitch_st1 pswitch_st1r 34 | rst "rpswitch" 0 rpswitch_st0 rpswitch_st0r 35 | rst "accum" 0 accum_st0 accum_st0r 36 | rst "accum" 1 accum_st1 accum_st1r 37 | where 38 | rst n i st str = do 39 | putStrLn ("Running " ++ n ++ "_st" ++ show i ++ " ...") 40 | if st ~= str then 41 | putStrLn "Success!" 42 | else 43 | -- We probably won't get here in case of a (space) failure ... 44 | putStrLn "Failure!" 45 | 46 | -- AC: here because I had trouble running ghci: 47 | -- fixTest :: IO () 48 | -- fixTest = 49 | -- let vs = loop_t17 50 | -- in putStrLn ("loop_t17 output: " ++ show vs) 51 | 52 | -- * Test cases for arr 53 | 54 | arr_st0 = testSFSpaceLeak 2000000 (arr (+1)) 55 | arr_st0r = 1000000.5 56 | 57 | arr_st1 = testSFSpaceLeak 2000000 identity 58 | arr_st1r = 999999.5 59 | 60 | -- * Test cases for loop 61 | 62 | loop_acc :: SF (Double, Double) (Double, Double) 63 | loop_acc = arr (\(x, y)->(x+y, x+y)) 64 | 65 | loop_st0 = testSFSpaceLeak 2000000 66 | (loop (second (iPre 0) >>> loop_acc)) 67 | loop_st0r = 9.999995e11 68 | 69 | -- A simple loop test taken from MiniYampa: 70 | -- This results in pulling on the fed-back output during evaluation, because 71 | -- switch is strict in its input sample: 72 | loop_st1 :: Double 73 | loop_st1 = testSFSpaceLeak 2000000 74 | (loop $ second $ (switch identity (const (arr fst))) >>> arr (\x -> (x + x + x + x + x + x + x,noEvent)) >>> (iPre (25, noEvent))) 75 | loop_st1r = 999999.5 76 | 77 | -- * Test cases for rSwitch and drSwitch 78 | 79 | rswitch_sawTooth :: SF a Double 80 | rswitch_sawTooth = 81 | loop (second (arr (>=5.0) 82 | >>> edge 83 | >>> arr (`tag` ramp)) 84 | >>> drSwitch ramp 85 | >>> arr dup) 86 | where 87 | ramp :: SF a Double 88 | ramp = constant 1.0 >>> integral 89 | 90 | rswitch_st0 = testSFSpaceLeak 2000000 rswitch_sawTooth 91 | rswitch_st0r = 4.75 92 | 93 | -- * Test cases for pSwitchB and dpSwitchB 94 | 95 | -- Starts three "ramps" with different phase. As soon as one exceeds a 96 | -- threshold, it's restarted, while the others are left alone. The 97 | -- observaton of the output is done via the loop (rather than the directly 98 | -- from the outputs of the signal functions in the collection), thus the 99 | -- use of a delayed switch is essential. 100 | pswitch_ramp :: Double -> SF a Double 101 | pswitch_ramp phase = constant 2.0 >>> integral >>> arr (+phase) 102 | 103 | -- We assume that only one signal function will reach the limit at a time. 104 | pswitch_limit :: Double -> SF ((a, [Double]), b) (Event Int) 105 | pswitch_limit x = arr (snd . fst) >>> arr (findIndex (>=x)) >>> edgeJust 106 | 107 | pswitch_t4rec :: [SF (a, [Double]) Double] 108 | -> Int 109 | -> SF (a, [Double]) [Double] 110 | pswitch_t4rec sfs n = 111 | dpSwitchB (take n sfs ++ [pswitch_ramp 0.0] ++ drop (n+1) sfs) 112 | (pswitch_limit 2.99) 113 | pswitch_t4rec 114 | 115 | -- Variation of the test above, with direct observation (not via loop) and 116 | -- immediate switch. 117 | -- 118 | -- We assume that only one signal function will reach the limit at a time. 119 | pswitch_limit2 :: Double -> SF (a, [Double]) (Event Int) 120 | pswitch_limit2 x = arr snd >>> arr (findIndex (>=x)) >>> edgeJust 121 | 122 | pswitch_t5rec :: [SF (a, [Double]) Double] 123 | -> Int 124 | -> SF (a, [Double]) [Double] 125 | pswitch_t5rec sfs n = 126 | pSwitchB (take n sfs ++ [pswitch_ramp 0.0] ++ drop (n+1) sfs) 127 | (pswitch_limit2 2.99) 128 | pswitch_t5rec 129 | 130 | pswitch_st0 = testSFSpaceLeak 1000000 (loop sf) 131 | where 132 | sf :: SF (a, [Double]) ([Double],[Double]) 133 | sf = dpSwitchB [pswitch_ramp 0.0, pswitch_ramp 1.0, pswitch_ramp 2.0] 134 | (pswitch_limit 2.99) 135 | pswitch_t4rec 136 | >>> arr dup 137 | 138 | pswitch_st0r = [1.5,2.5,0.5] 139 | 140 | pswitch_st1 = testSFSpaceLeak 1000000 (loop sf) 141 | where 142 | sf :: SF (a, [Double]) (([Double], Double), [Double]) 143 | sf = ((pSwitchB [pswitch_ramp 0.0, pswitch_ramp 1.0, pswitch_ramp 2.0] 144 | (pswitch_limit2 2.99) 145 | pswitch_t5rec) 146 | &&& (arr snd >>> arr sum)) 147 | >>> arr (\(xs, y) -> ((xs, y), xs)) 148 | 149 | pswitch_st1r = ([1.5,2.5,0.5],4.5) 150 | 151 | -- * Test cases for rpSwitchB and drpSwitchB 152 | 153 | -- Starts three "ramps" with different phase. As soon as one exceeds a 154 | -- threshold, it's restarted, while the others are left alone. The observaton 155 | -- of the output is done via a loop, thus the use of a delayed switch is 156 | -- essential. 157 | 158 | rpswitch_ramp :: Double -> SF a Double 159 | rpswitch_ramp phase = constant 2.0 >>> integral >>> arr (+phase) 160 | 161 | -- We assume that only one signal function will reach the limit at a time. 162 | rpswitch_limit :: Double -> SF [Double] (Event ([SF a Double]->[SF a Double])) 163 | rpswitch_limit x = arr (findIndex (>=x)) >>> edgeJust >>> arr (fmap restart) 164 | where 165 | restart n = \sfs -> take n sfs ++ [rpswitch_ramp 0.0] ++ drop (n+1) sfs 166 | 167 | rpswitch_st0 = testSFSpaceLeak 1000000 (loop sf) 168 | where 169 | sf :: SF (a, [Double]) ([Double],[Double]) 170 | sf = (second (rpswitch_limit 2.99) 171 | >>> drpSwitchB [ rpswitch_ramp 0.0 172 | , rpswitch_ramp 1.0 173 | , rpswitch_ramp 2.0 174 | ] 175 | ) >>> arr dup 176 | 177 | rpswitch_st0r = [1.5,2.5,0.5] 178 | 179 | -- * Test cases for accumulators 180 | 181 | accum_st0 :: Double 182 | accum_st0 = testSFSpaceLeak 1000000 183 | (repeatedly 1.0 1.0 184 | >>> accumBy (+) 0.0 185 | >>> hold (-99.99)) 186 | 187 | accum_st0r = 249999.0 188 | 189 | accum_st1 :: Double 190 | accum_st1 = testSFSpaceLeak 1000000 191 | (arr dup 192 | >>> first (repeatedly 1.0 1.0) 193 | >>> arr (\(e,a) -> tag e a) 194 | >>> accumFilter accumFun 0.0 195 | >>> hold (-99.99)) 196 | where 197 | accumFun c a | even (floor a) = (c+a, Just (c+a)) 198 | | otherwise = (c, Nothing) 199 | 200 | accum_st1r = 6.249975e10 201 | 202 | ------------------------------------------------------------------------------ 203 | -- Test harness for space behaviour 204 | ------------------------------------------------------------------------------ 205 | 206 | {- 207 | -- Test for space leaks. 208 | -- Carefully defined in an attempt to defeat fully lazy lambda lifting. 209 | -- Seems to work, but may be unsafe if the compiler decides to optimize 210 | -- aggressively. 211 | testSFSpaceLeak :: Int -> SF Double a -> a 212 | testSFSpaceLeak n sf = embed sf (deltaEncodeBy (~=) 0.25 [(seq n 0.0)..]) !! n 213 | -} 214 | 215 | -- Using embed/deltaEncode seems to be a bad idea since fully lazy 216 | -- lambda lifting often results in lifting a big input list to the top 217 | -- level in the form of a CAF. Using reactimate and avoiding constructing 218 | -- input/output lists should be more robust. 219 | 220 | testSFSpaceLeak :: Int -> SF Double a -> a 221 | testSFSpaceLeak n sf = unsafePerformIO $ do 222 | countr <- newIORef 0 223 | inputr <- newIORef undefined 224 | outputr <- newIORef undefined 225 | let init = do 226 | let input0 = 0.0 227 | writeIORef inputr input0 228 | count <- readIORef countr 229 | writeIORef countr (count + 1) 230 | return input0 231 | 232 | sense _ = do 233 | input <- readIORef inputr 234 | let input' = input + 0.5 235 | writeIORef inputr input' 236 | count <- readIORef countr 237 | writeIORef countr (count + 1) 238 | return (0.25, Just input') 239 | 240 | actuate _ output = do 241 | writeIORef outputr output 242 | _input <- readIORef inputr 243 | count <- readIORef countr 244 | return (count >= n) 245 | 246 | reactimate init sense actuate sf 247 | 248 | -- return output 249 | readIORef outputr 250 | -------------------------------------------------------------------------------- /yampa-test/tests/Test/FRP/Yampa/Arrow.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Description : Test cases for arrow helper functions. 3 | -- Copyright : (c) Ivan Perez, 2022 4 | -- Authors : Ivan Perez 5 | module Test.FRP.Yampa.Arrow 6 | ( tests 7 | ) 8 | where 9 | 10 | -- External modules 11 | import Test.QuickCheck (Gen, Property, arbitrary, forAll, forAllBlind) 12 | import Test.Tasty (TestTree, testGroup) 13 | import Test.Tasty.QuickCheck (testProperty) 14 | 15 | -- External modules: Yampa 16 | import FRP.Yampa as Yampa 17 | 18 | tests :: TestTree 19 | tests = testGroup "Regression tests for FRP.Yampa.Arrow" 20 | [ testProperty "dup (qc)" testDup 21 | , testProperty "arr2 (qc)" testArr2 22 | , testProperty "arr3 (qc)" testArr3 23 | , testProperty "arr4 (qc)" testArr4 24 | , testProperty "arr5 (qc)" testArr5 25 | ] 26 | 27 | -- * Arrow plumbing aids 28 | 29 | testDup :: Property 30 | testDup = 31 | forAll input $ \x -> 32 | (fst (dup x) == x) && (snd (dup x) == x) 33 | where 34 | input :: Gen Integer 35 | input = arbitrary 36 | 37 | -- * Liftings 38 | 39 | testArr2 :: Property 40 | testArr2 = 41 | forAll input $ \x@(x1, x2) -> 42 | forAllBlind inputF $ \f -> 43 | arr2 f x == f x1 x2 44 | where 45 | input :: Gen (Integer, Integer) 46 | input = arbitrary 47 | 48 | inputF :: Gen (Integer -> Integer -> Integer) 49 | inputF = arbitrary 50 | 51 | testArr3 :: Property 52 | testArr3 = 53 | forAll input $ \x@(x1, x2, x3) -> 54 | forAllBlind inputF $ \f -> 55 | arr3 f x == f x1 x2 x3 56 | where 57 | input :: Gen (Integer, Integer, Integer) 58 | input = arbitrary 59 | 60 | inputF :: Gen (Integer -> Integer -> Integer -> Integer) 61 | inputF = arbitrary 62 | 63 | testArr4 :: Property 64 | testArr4 = 65 | forAll input $ \x@(x1, x2, x3, x4) -> 66 | forAllBlind inputF $ \f -> 67 | arr4 f x == f x1 x2 x3 x4 68 | where 69 | input :: Gen (Integer, Integer, Integer, Integer) 70 | input = arbitrary 71 | 72 | inputF :: Gen (Integer -> Integer -> Integer -> Integer -> Integer) 73 | inputF = arbitrary 74 | 75 | testArr5 :: Property 76 | testArr5 = 77 | forAll input $ \x@(x1, x2, x3, x4, x5) -> 78 | forAllBlind inputF $ \f -> 79 | arr5 f x == f x1 x2 x3 x4 x5 80 | where 81 | input :: Gen (Integer, Integer, Integer, Integer, Integer) 82 | input = arbitrary 83 | 84 | inputF :: Gen ( Integer 85 | -> Integer 86 | -> Integer 87 | -> Integer 88 | -> Integer 89 | -> Integer 90 | ) 91 | inputF = arbitrary 92 | -------------------------------------------------------------------------------- /yampa-test/tests/Test/FRP/Yampa/Basic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- | 3 | -- Description : Test cases for basic signal functions 4 | -- Copyright : (c) Ivan Perez, 2014-2022 5 | -- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 6 | -- Authors : Antony Courtney, Henrik Nilsson, Ivan Perez 7 | module Test.FRP.Yampa.Basic 8 | ( tests 9 | ) 10 | where 11 | 12 | #if __GLASGOW_HASKELL__ < 710 13 | import Control.Applicative ((<*>)) 14 | import Data.Functor ((<$>)) 15 | #endif 16 | import Test.QuickCheck 17 | import Test.Tasty (TestTree, testGroup) 18 | import Test.Tasty.QuickCheck (testProperty) 19 | 20 | import FRP.Yampa as Yampa 21 | import FRP.Yampa.Stream 22 | import FRP.Yampa.QuickCheck 23 | import FRP.Yampa.LTLFuture 24 | 25 | import TestsCommon 26 | 27 | tests :: TestTree 28 | tests = testGroup "Regression tests for FRP.Yampa.Basic" 29 | [ testProperty "identity (fixed)" (property $ basicsf_t0 ~= basicsf_t0r) 30 | , testProperty "identity (qc)" prop_basic_identity_1 31 | , testProperty "identity (qc)" prop_basic_identity_2 32 | , testProperty "constant (fixed)" (property $ basicsf_t1 ~= basicsf_t1r) 33 | , testProperty "constant (qc)" prop_basic_constant 34 | , testProperty "--> (qc)" propInsert 35 | , testProperty "-:> (qc)" propAlterFirstOutput 36 | , testProperty ">-- (qc)" propInputInit 37 | , testProperty "-=> (qc)" propModFirstOutput 38 | , testProperty ">=- (qc)" propModFirstInput 39 | , testProperty "initially (fixed)" (property $ basicsf_t4 ~= basicsf_t4r) 40 | , testProperty "initially (qc)" prop_basic_initially 41 | ] 42 | 43 | -- * Basic signal functions 44 | 45 | -- ** identity 46 | 47 | basicsf_t0 :: [Double] 48 | basicsf_t0 = testSF1 identity 49 | basicsf_t0r = 50 | [ 0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 8.0, 9.0 51 | , 10.0, 11.0, 12.0, 13.0, 14.0, 15.0, 16.0, 17.0, 18.0, 19.0 52 | , 20.0, 21.0, 22.0, 23.0, 24.0 53 | ] 54 | 55 | -- Yampa's Basic SF builders 56 | prop_basic_identity_1 = 57 | forAll myStream $ evalT $ Always $ prop (sf, pred) 58 | where 59 | myStream :: Gen (SignalSampleStream Float) 60 | myStream = uniDistStream 61 | sf = identity 62 | pred = (==) 63 | 64 | prop_basic_identity_2 = 65 | forAll myStream (evalT $ prop_always_equal identity (arr id)) 66 | where 67 | myStream :: Gen (SignalSampleStream Float) 68 | myStream = uniDistStream 69 | 70 | -- ** constant 71 | 72 | basicsf_t1 :: [Double] 73 | basicsf_t1 = testSF1 (constant 42.0) 74 | basicsf_t1r = 75 | [ 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0 76 | , 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0, 42.0 77 | , 42.0, 42.0, 42.0, 42.0, 42.0 78 | ] 79 | 80 | prop_basic_constant = 81 | forAll myStream $ evalT $ Always $ prop (sf, pred) 82 | where 83 | myStream :: Gen (SignalSampleStream Float) 84 | myStream = uniDistStream 85 | 86 | sf = constant 42.0 87 | pred = const (== 42.0) 88 | 89 | -- * Initialization 90 | 91 | -- ** @(-->)@ 92 | 93 | -- | Test that @initialValue --> integral@, when applied to any signal, is 94 | -- initially equal to @constant initialValue@, and, in the future, always equal 95 | -- to @integral@. 96 | -- 97 | -- Note that it is important to understand that integral is "turned on" at time 98 | -- zero, and its value discarded. This is not the same as using the constant SF 99 | -- at time zero and turning @integral@ on at the next time (e.g., with 100 | -- @switch@). 101 | propInsert :: Property 102 | propInsert = 103 | forAll initialValueG $ \initialValue -> 104 | forAll myStream $ evalT $ 105 | 106 | -- SF that uses the actual function being tested 107 | let sfStep :: SF Float Float 108 | sfStep = initialValue --> integral 109 | 110 | -- Expected behavior 111 | in And 112 | -- Currently equal to initialValue 113 | (SP $ (==) <$> sfStep <*> constant initialValue) 114 | 115 | -- In the future, always equal to integral 116 | (Next $ Always $ SP $ (==) <$> sfStep <*> integral) 117 | 118 | where 119 | myStream :: Gen (SignalSampleStream Float) 120 | myStream = uniDistStream 121 | 122 | initialValueG :: Gen Float 123 | initialValueG = arbitrary 124 | 125 | -- ** @(-:>)@ 126 | 127 | -- | Test that @initialValue -:> sf@, when applied to any signal, is initially 128 | -- equal to @constant initialValue@, and, after that, the output is the same as 129 | -- @sf@ (starting from that point). 130 | propAlterFirstOutput :: Property 131 | propAlterFirstOutput = 132 | forAll initialValueG $ \initialValue -> 133 | forAll myStream $ evalT $ 134 | 135 | -- SF that uses the actual function being tested. 136 | -- 137 | -- We pick a point-wise function for the test because we have no (easy) 138 | -- way of dropping a sample when we "turn of" the second sf in the 139 | -- comparison for future samples. For example, if we had picked integral, 140 | -- then the integral would start from the second sample (with the delay 141 | -- applied), but the temporal Next operator starts the SF now and waits 142 | -- until the next sample to check the property. 143 | let sfStep :: SF Float Float 144 | sfStep = (initialValue -:> arr (* 2)) >>> arr (^ 2) 145 | 146 | -- Expected behavior 147 | in And 148 | -- Currently equal to initialValue. In tis case it is safe to 149 | -- compare floating point numbers with (==) because the output HAS 150 | -- to be exactly the same. Note that, in the efinition of sfStep, 151 | -- the number initialValue should reach (arr (^ 2)) unchanged, and 152 | -- arr is just function application. 153 | (SP $ (==) <$> sfStep <*> constant (initialValue ^ 2)) 154 | 155 | -- In the future, always equal to (arr ((^ 2) . (* 2)))). Note that 156 | -- we ignore initialValue completely. 157 | (Next $ Always $ SP $ (==) <$> sfStep <*> arr ((^ 2) . (* 2))) 158 | 159 | where 160 | myStream :: Gen (SignalSampleStream Float) 161 | myStream = uniDistStream 162 | 163 | initialValueG :: Gen Float 164 | initialValueG = arbitrary 165 | 166 | -- ** @(>--)@ 167 | 168 | -- | Test that @initialValue >-- sf@, when applied to any signal, is initially 169 | -- equal to @initialValue@, and, in the future, always equal to @sf@. 170 | propInputInit :: Property 171 | propInputInit = 172 | forAll initialValueG $ \initialValue -> 173 | forAll myStream $ evalT $ 174 | 175 | -- SF that uses the actual function being tested 176 | let sfStep :: SF Float Float 177 | sfStep = initialValue --> arr (* 2) 178 | 179 | -- Expected behavior 180 | in And 181 | -- Currently equal to initialValue 182 | (SP $ (==) <$> sfStep <*> constant initialValue) 183 | 184 | -- In the future, always equal to arr (* 2) 185 | (Next $ Always $ SP $ (==) <$> sfStep <*> arr (* 2)) 186 | 187 | where 188 | myStream :: Gen (SignalSampleStream Float) 189 | myStream = uniDistStream 190 | 191 | initialValueG :: Gen Float 192 | initialValueG = arbitrary 193 | 194 | -- ** (-=>) 195 | 196 | -- | Test that @(-=>)@ applies a transformation to the first output. 197 | -- 198 | -- We test with the specific function @(* 4) -=> arr (^ 2)@. 199 | propModFirstOutput :: Property 200 | propModFirstOutput = 201 | forAll myStream $ evalT $ 202 | 203 | -- SF that uses the actual function being tested. 204 | -- 205 | -- We specifically pick transformations that do not commute, so that we 206 | -- test that transformations are applied in the expected order. 207 | let sfStep :: SF Float Float 208 | sfStep = (* 4) -=> arr (^ 2) 209 | 210 | -- Expected behavior 211 | in And 212 | -- Initially, both transformations are applied. Note that the 213 | -- difference between this comparison and the one for (>=-) is the 214 | -- order in which the two transformations are applied. 215 | (SP $ (==) <$> sfStep <*> arr ((* 4) . (^ 2))) 216 | 217 | -- In the future, only the second transformation is applied 218 | (Next $ Always $ SP $ (==) <$> sfStep <*> arr (^ 2)) 219 | 220 | where 221 | myStream :: Gen (SignalSampleStream Float) 222 | myStream = uniDistStream 223 | 224 | -- ** @(>=-)@ 225 | 226 | -- | Test that @f -=> arr (^ 2)@, when applied to any signal, is initially 227 | -- equal to initialValue, and, in the future, always equal to @arr (^ 2)@. 228 | propModFirstInput :: Property 229 | propModFirstInput = 230 | forAll myStream $ evalT $ 231 | 232 | -- SF that uses the actual function being tested. 233 | -- 234 | -- We specifically pick transformations that do not commute, so that we 235 | -- test that transformations are applied in the expected order. 236 | let sfStep :: SF Float Float 237 | sfStep = (* 2) >=- arr (^ 2) 238 | 239 | -- Expected behavior 240 | in And 241 | -- Initially, both transformations are applied. Note that the 242 | -- difference between this comparison and the one for (-=>) is the 243 | -- order in which the two transformations are applied. 244 | (SP $ (==) <$> sfStep <*> arr ((^ 2) . (* 2))) 245 | 246 | -- In the future, only the second transformation is applied 247 | (Next $ Always $ SP $ (==) <$> sfStep <*> arr (^ 2)) 248 | 249 | where 250 | myStream :: Gen (SignalSampleStream Float) 251 | myStream = uniDistStream 252 | 253 | -- ** initially 254 | 255 | basicsf_t4 :: [Double] 256 | basicsf_t4 = testSF1 (initially 42.0) 257 | basicsf_t4r = 258 | [ 42.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 8.0, 9.0 259 | , 10.0, 11.0, 12.0, 13.0, 14.0, 15.0, 16.0, 17.0, 18.0, 19.0 260 | , 20.0, 21.0, 22.0, 23.0, 24.0 261 | ] 262 | 263 | prop_basic_initially = 264 | forAll myStream $ evalT $ prop (sf, pred) 265 | where 266 | myStream :: Gen (SignalSampleStream Float) 267 | myStream = uniDistStream 268 | 269 | sf = initially 42.0 270 | pred = const (== 42.0) 271 | 272 | -- * Auxiliary 273 | 274 | -- prop :: SF a b -> (a -> b -> 275 | prop (a,b) = SP ((identity &&& a) >>^ uncurry b) 276 | 277 | -- | Compares two SFs, resulting in true if they are always equal 278 | prop_always_equal sf1 sf2 = 279 | Always $ SP ((sf1 &&& sf2) >>> arr sameResult) 280 | where 281 | sameResult = uncurry (==) 282 | -------------------------------------------------------------------------------- /yampa-test/tests/Test/FRP/Yampa/Conditional.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | {-# LANGUAGE CPP #-} 3 | -- | 4 | -- Description : Test cases for FRP.Yampa.Conditional 5 | -- Copyright : (c) Ivan Perez, 2014-2022 6 | -- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 7 | -- Authors : Antony Courtney, Henrik Nilsson, Ivan Perez 8 | module Test.FRP.Yampa.Conditional 9 | ( tests 10 | ) 11 | where 12 | 13 | #if __GLASGOW_HASKELL__ < 710 14 | import Control.Applicative ((<*>)) 15 | import Data.Functor ((<$>)) 16 | #endif 17 | import Test.QuickCheck 18 | import Test.Tasty (TestTree, testGroup) 19 | import Test.Tasty.QuickCheck (testProperty) 20 | 21 | import FRP.Yampa as Yampa 22 | import FRP.Yampa.LTLFuture (TPred (Always, SP), evalT) 23 | import FRP.Yampa.QuickCheck (uniDistStream) 24 | import FRP.Yampa.Stream (SignalSampleStream) 25 | 26 | import TestsCommon 27 | 28 | tests :: TestTree 29 | tests = testGroup "Regression tests for FRP.Yampa.Conditional" 30 | [ testProperty "provided (1, fixed)" (property $ utils_t8 ~= utils_t8r) 31 | , testProperty "provided (2, fixed)" (property $ utils_t9 ~= utils_t9r) 32 | , testProperty "pause (qc)" propPause 33 | ] 34 | 35 | -- * Guards and automata-oriented combinators 36 | 37 | utils_t8 :: [Double] 38 | utils_t8 = take 50 $ embed (provided (even . floor) integral (constant (-1))) 39 | (deltaEncode 0.1 input) 40 | where 41 | input = replicate 10 1 42 | ++ replicate 10 2 43 | ++ replicate 10 3 44 | ++ replicate 10 4 45 | ++ input 46 | 47 | utils_t8r = 48 | [ -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0 49 | , 0.0, 0.2, 0.4, 0.6, 0.8, 1.0, 1.2, 1.4, 1.6, 1.8 50 | , -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0 51 | , 0.0, 0.4, 0.8, 1.2, 1.6, 2.0, 2.4, 2.8, 3.2, 3.6 52 | , -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0 53 | ] 54 | 55 | utils_t9 :: [Double] 56 | utils_t9 = take 50 $ embed (provided (odd . floor) integral (constant (-1))) 57 | (deltaEncode 0.1 input) 58 | where 59 | input = replicate 10 1 60 | ++ replicate 10 2 61 | ++ replicate 10 3 62 | ++ replicate 10 4 63 | ++ input 64 | 65 | utils_t9r = 66 | [ 0.0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9 67 | , -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0 68 | , 0.0, 0.3, 0.6, 0.9, 1.2, 1.5, 1.8, 2.1, 2.4, 2.7 69 | , -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0, -1.0 70 | , 0.0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9 71 | ] 72 | 73 | propPause :: Property 74 | propPause = 75 | forAll initialValueG $ \initialValue -> 76 | forAll myStream $ evalT $ 77 | -- The behavior of pause is always the same as some ideal behavior 78 | -- implemented by modelPause below. We give these auxiliary definitions 79 | -- names and pass initialValue as argument to facilitate debugging. 80 | Always $ SP $ (==) <$> sfPause initialValue <*> sfModelPause initialValue 81 | where 82 | myStream :: Gen (SignalSampleStream Float) 83 | myStream = uniDistStream 84 | 85 | initialValueG :: Gen Float 86 | initialValueG = arbitrary 87 | 88 | -- SF that uses the actual function being tested 89 | sfPause :: Float -> SF Float Float 90 | sfPause initialValue = pause initialValue (arr (odd . round)) integral 91 | 92 | -- Model SF that uses the actual function being tested 93 | sfModelPause :: Float -> SF Float Float 94 | sfModelPause initialValue = 95 | modelPause initialValue (arr (odd . round)) integral 96 | 97 | -- Model implementation of pause. 98 | modelPause :: b -> SF a Bool -> SF a b -> SF a b 99 | modelPause acc0 sf1 sf2 = proc (a) -> do 100 | rec c <- sf1 -< a 101 | 102 | -- Accumulator that is updated only when then condition is false. 103 | acc <- hold acc0 -< e 104 | 105 | -- When the condition is false, sf2 is turned on and executed, 106 | -- producing a new Event. Note that we need to put this in an 107 | -- ArrowCase block, we can't just run both and the decide whether we 108 | -- want to output the value or not based on the condition, because, 109 | -- in that case, the argument sf2 would still be executed and 110 | -- accumulate state. 111 | e <- if c then returnA -< NoEvent 112 | else Event ^<< sf2 -< a 113 | 114 | returnA -< acc 115 | -------------------------------------------------------------------------------- /yampa-test/tests/Test/FRP/Yampa/Loop.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Description : Test cases for SFs with loops 3 | -- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 4 | -- Authors : Antony Courtney, Henrik Nilsson 5 | module Test.FRP.Yampa.Loop 6 | ( tests 7 | ) 8 | where 9 | 10 | import Test.QuickCheck 11 | import Test.Tasty (TestTree, testGroup) 12 | import Test.Tasty.QuickCheck (testProperty) 13 | 14 | import FRP.Yampa as Yampa 15 | 16 | import TestsCommon 17 | 18 | tests :: TestTree 19 | tests = testGroup "Regression tests for FRP.Yampa.Loop" 20 | [ testProperty "loopPre (0, fixed)" (property $ loopPre_t0 ~= loopPre_t0r) 21 | , testProperty "loopPre (1, fixed)" (property $ loopPre_t1 ~= loopPre_t1r) 22 | , testProperty "loopPre (2, fixed)" (property $ loopPre_t2 ~= loopPre_t2r) 23 | , testProperty "loopPre (3, fixed)" (property $ loopPre_t3 ~= loopPre_t3r) 24 | , testProperty "loopPre (4, fixed)" (property $ loopPre_t4 ~= loopPre_t4r) 25 | , testProperty "loopIntegral (0, fixed)" (property $ loopIntegral_t0 ~= loopIntegral_t0r) 26 | , testProperty "loopIntegral (1, fixed)" (property $ loopIntegral_t1 ~= loopIntegral_t1r) 27 | ] 28 | 29 | -- * Loops with guaranteed well-defined feedback 30 | 31 | loop_acc :: SF (Double, Double) (Double, Double) 32 | loop_acc = arr (\(x, y)->(x+y, x+y)) 33 | 34 | -- This kind of test will fail for infinitesimal delay! 35 | loopPre_t0 = testSF1 (loopPre 0 loop_acc) 36 | loopPre_t0r = 37 | [ 0.0,1.0,3.0,6.0,10.0,15.0,21.0,28.0,36.0,45.0,55.0,66.0,78.0,91.0 38 | , 105.0,120.0,136.0,153.0,171.0,190.0,210.0,231.0,253.0,276.0,300.0 39 | ] 40 | 41 | loopPre_t1 = testSF2 (loopPre 0 loop_acc) 42 | loopPre_t1r = 43 | [ 0.0,0.0,0.0,0.0,0.0,1.0,2.0,3.0,4.0,5.0,7.0,9.0,11.0,13.0,15.0,18.0 44 | , 21.0,24.0,27.0,30.0,34.0,38.0,42.0,46.0,50.0 45 | ] 46 | 47 | -- This kind of test will fail for infinitesimal delay! 48 | loopPre_t2 = testSF1 (loopPre False (arr (dup . not . snd))) 49 | loopPre_t2r = 50 | [ True,False,True,False,True,False,True,False,True,False,True,False 51 | , True,False,True,False,True,False,True,False,True,False,True,False,True 52 | ] 53 | 54 | loopPre_t3 = testSF1 (loopPre 0 (first localTime)) 55 | loopPre_t3r = 56 | [ 0.0,0.25,0.5,0.75,1.0,1.25,1.5,1.75,2.0,2.25,2.5,2.75,3.0,3.25,3.5,3.75 57 | , 4.0,4.25,4.5,4.75,5.0,5.25,5.5,5.75,6.0 58 | ] 59 | 60 | loopPre_t4 = testSF1 (loopPre 0 (first localTime >>> loop_acc)) 61 | loopPre_t4r = 62 | [ 0.0,0.25,0.75,1.5,2.5,3.75,5.25,7.0,9.0,11.25,13.75,16.5,19.5,22.75 63 | , 26.25,30.0,34.0,38.25,42.75,47.5,52.5,57.75,63.25,69.0,75.0 64 | ] 65 | 66 | -- Computation of approximation to exp 0, exp 1, ..., exp 5 by integration. 67 | -- Values as given by using exp directly: 68 | -- 1.0, 2.71828, 7.38906, 20.0855, 54.5981, 148.413 69 | loopIntegral_t0 = 70 | let es = embed (loopIntegral (arr (\(_, x) -> (x + 1, x + 1)))) 71 | (deltaEncode 0.001 (repeat ())) 72 | in [es!!0, es!!1000, es!!2000, es!!3000, es!!4000, es!!5000] 73 | loopIntegral_t0r :: [Double] 74 | loopIntegral_t0r = [1.0,2.71692,7.38167,20.05544,54.48911,148.04276] 75 | 76 | -- Test case with a time varying signal transformer inside the loop. 77 | -- Starting at position 0 [m], accelerate by 1.0 [m/s^2] until position 78 | -- exceeds 2.0 [m]. Then accelerate by -1.0 [m/s^2] until position gets 79 | -- below 0.0 [m]. Then accelerate at 1.0 [m/s^2] again. And so on. 80 | 81 | type Position = Double 82 | type Velocity = Double 83 | type Acceleration = Double 84 | 85 | posCntrl :: SF b Position 86 | posCntrl = loopIntegral posCntrlNR 87 | where 88 | posCntrlNR :: SF (b, Velocity) (Position, Acceleration) 89 | posCntrlNR = 90 | arr snd -- Get the velocity. 91 | >>> integral -- This integral gives us the position. 92 | >>> arr (\x -> (x,x)) 93 | >>> 94 | (second $ 95 | arr (\x -> (x,x)) 96 | >>> 97 | (first $ 98 | arr (>=2.0) 99 | >>> edge 100 | >>> (arr (fmap (const (constant (-1.0)))))) 101 | >>> 102 | (second $ 103 | arr (< 0.0) 104 | >>> edge 105 | >>> (arr (fmap (const (constant 1.0))))) 106 | >>> arr (\(e1,e2) -> e1 `lMerge` e2) 107 | >>> arr (\e -> ((), e)) 108 | >>> rSwitch (constant 1.0)) 109 | 110 | loopIntegral_t1 = take 250 (embed posCntrl (deltaEncode 0.1 (repeat ()))) 111 | 112 | -- Result only partially verified. But the sign of the acceleration changes 113 | -- at roughly the right points. 114 | loopIntegral_t1r :: [Double] 115 | loopIntegral_t1r = 116 | [ 0.0,0.0,0.01,0.03,0.06,0.1,0.15,0.21,0.28,0.36,0.45,0.55,0.66,0.78,0.91 117 | , 1.05,1.2,1.36,1.53,1.71,1.9,2.1,2.31,2.51,2.7,2.88,3.05,3.21,3.36,3.5 118 | , 3.63,3.75,3.86,3.96,4.05,4.13,4.2,4.26,4.31,4.35,4.38,4.4,4.41,4.41,4.4 119 | , 4.38,4.35,4.31,4.26,4.2,4.13,4.05,3.96,3.86,3.75,3.63,3.5,3.36,3.21,3.05 120 | , 2.88,2.7,2.51,2.31,2.1,1.88,1.65,1.41,1.16,0.9,0.63,0.35,0.06,-0.24 121 | , -0.55,-0.85,-1.14,-1.42,-1.69,-1.95,-2.2,-2.44,-2.67,-2.89,-3.1,-3.3 122 | , -3.49,-3.67,-3.84,-4.0,-4.15,-4.29,-4.42,-4.54,-4.65,-4.75,-4.84,-4.92 123 | , -4.99,-5.05,-5.1,-5.14,-5.17,-5.19,-5.2,-5.2,-5.19,-5.17,-5.14,-5.1 124 | , -5.05,-4.99,-4.92,-4.84,-4.75,-4.65,-4.54,-4.42,-4.29,-4.15,-4.0,-3.84 125 | , -3.67,-3.49,-3.3,-3.1,-2.89,-2.67,-2.44,-2.2,-1.95,-1.69,-1.42,-1.14 126 | , -0.85,-0.55,-0.24,0.08,0.41,0.75,1.1,1.46,1.83,2.21,2.6,2.98,3.35,3.71 127 | , 4.06,4.4,4.73,5.05,5.36,5.66,5.95,6.23,6.5,6.76,7.01,7.25,7.48,7.7,7.91 128 | , 8.11,8.3,8.48,8.65,8.81,8.96,9.1,9.23,9.35,9.46,9.56,9.65,9.73,9.8,9.86 129 | , 9.91,9.95,9.98,10.0,10.01,10.01,10.0,9.98,9.95,9.91,9.86,9.8,9.73,9.65 130 | , 9.56,9.46,9.35,9.23,9.1,8.96,8.81,8.65,8.48,8.3,8.11,7.91,7.7,7.48,7.25 131 | , 7.01,6.76,6.5,6.23,5.95,5.66,5.36,5.05,4.73,4.4,4.06,3.71,3.35,2.98,2.6 132 | , 2.21,1.81,1.4,0.98,0.55,0.11,-0.34,-0.80,-1.25,-1.69,-2.12,-2.54,-2.95 133 | , -3.35,-3.74,-4.12,-4.49,-4.85,-5.2,-5.54,-5.87,-6.19,-6.5,-6.8,-7.09 134 | , -7.37,-7.64,-7.9 135 | ] 136 | -------------------------------------------------------------------------------- /yampa-test/tests/Test/FRP/Yampa/Random.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | -- | 4 | -- Description : Test cases for signal functions working with random values. 5 | -- Copyright : (c) Ivan Perez, 2023 6 | -- Authors : Ivan Perez 7 | 8 | module Test.FRP.Yampa.Random 9 | ( tests 10 | ) 11 | where 12 | 13 | #if __GLASGOW_HASKELL__ < 708 14 | import Data.Bits (bitSize) 15 | #endif 16 | #if __GLASGOW_HASKELL__ >= 708 17 | import Data.Bits (bitSizeMaybe) 18 | #endif 19 | 20 | import Data.Bits (Bits, popCount) 21 | import Data.Maybe (fromMaybe) 22 | import Data.Word (Word32, Word64) 23 | import Foreign.C (CFloat(..)) 24 | import System.Random (mkStdGen) 25 | import Test.QuickCheck hiding (once, sample) 26 | import Test.Tasty (TestTree, testGroup) 27 | import Test.Tasty.QuickCheck (testProperty) 28 | 29 | import FRP.Yampa (DTime, Event (..), embed, isEvent, noise, noiseR, 30 | occasionally, second) 31 | import FRP.Yampa.QuickCheck (Distribution (DistRandom), generateStream) 32 | import FRP.Yampa.Stream (SignalSampleStream) 33 | 34 | tests :: TestTree 35 | tests = testGroup "Regression tests for FRP.Yampa.Random" 36 | [ testProperty "noise (0, qc)" propNoise 37 | , testProperty "noiseR (0, qc)" propNoiseR 38 | , testProperty "occasionally (0, qc)" propOccasionally 39 | ] 40 | 41 | -- * Noise (i.e. random signal generators) and stochastic processes 42 | 43 | propNoise :: Property 44 | propNoise = 45 | forAll genSeed $ \seed -> 46 | forAll myStream $ \stream -> 47 | isRandom (embed (noise (mkStdGen seed)) (structure stream) :: [Word32]) 48 | where 49 | -- Generator: Input stream. 50 | -- 51 | -- We provide a number of samples; otherwise, deviations might not indicate 52 | -- lack of randomness for the signal function. 53 | myStream :: Gen (SignalSampleStream ()) 54 | myStream = 55 | generateStream DistRandom (Nothing, Nothing) (Just (Left numSamples)) 56 | 57 | -- Generator: Random generator seed 58 | genSeed :: Gen Int 59 | genSeed = arbitrary 60 | 61 | -- Constant: Number of samples in the stream used for testing. 62 | -- 63 | -- This number has to be high; numbers 100 or below will likely not work. 64 | numSamples :: Int 65 | numSamples = 400 66 | 67 | propNoiseR :: Property 68 | propNoiseR = 69 | forAll genSeed $ \seed -> 70 | forAll myStream $ \stream -> 71 | -- True if the noise signal is within the given bounds, and it is random 72 | -- when constrained to that range. 73 | let output = embed (noiseR bounds (mkStdGen seed)) (structure stream) 74 | in all (`isInRange` bounds) output && isRandom (constrainTypes output) 75 | 76 | where 77 | 78 | -- Generator: Input stream. 79 | -- 80 | -- We provide a number of samples; otherwise, deviations might not indicate 81 | -- lack of randomness for the signal function. 82 | myStream :: Gen (SignalSampleStream ()) 83 | myStream = 84 | generateStream DistRandom (Nothing, Nothing) (Just (Left numSamples)) 85 | 86 | -- Generator: Random generator seed 87 | genSeed :: Gen Int 88 | genSeed = arbitrary 89 | 90 | -- Constant: Bounds used for the test. 91 | -- 92 | -- We bound the numbers generated to the 32-bit range, but express it 93 | -- using the type of Word64. 94 | bounds :: (Word64, Word64) 95 | bounds = (min32, max32) 96 | where 97 | min32 = fromIntegral (minBound :: Word32) 98 | max32 = fromIntegral (maxBound :: Word32) 99 | 100 | -- Constant: Number of samples in the stream used for testing. 101 | -- 102 | -- This number has to be high; numbers 100 or below will likely not work. 103 | numSamples :: Int 104 | numSamples = 400 105 | 106 | -- Constrain the types of the argument list to the output type. 107 | -- 108 | -- For this test to work, this type must be consistent with the bounds 109 | -- chosen in the constant 'bounds'. 110 | constrainTypes :: [Word64] -> [Word32] 111 | constrainTypes = map fromIntegral 112 | 113 | -- | True if the argument is within the given range, false otherwise. 114 | isInRange :: Ord a => a -> (a, a) -> Bool 115 | isInRange x (minB, maxB) = minB <= x && x <= maxB 116 | 117 | propOccasionally :: Property 118 | propOccasionally = 119 | forAll genDt $ \avgDt -> 120 | forAll genOutput $ \b -> 121 | forAll genSeed $ \seed -> 122 | 123 | -- We pass avgDt / 10 as max time delta to myStream to ensure that the 124 | -- stream produces frequent samples. 125 | forAll (myStream (avgDt / 10)) $ \stream -> 126 | 127 | -- True if all events in the output contain the value 'b', 128 | -- the number of events produced is roughtly as expected. 129 | let output = 130 | embed (occasionally (mkStdGen seed) avgDt b) (structure stream) 131 | 132 | -- Difference between the number of samples produced and expected 133 | diffNumSamples = abs (actualOcurrences - expectedOccurrences) 134 | actualOcurrences = length $ filter isEvent output 135 | expectedOccurrences = round (streamTime / avgDt) 136 | streamTime = sum $ map fst $ snd stream 137 | 138 | in all (== Event b) (filter isEvent output) && diffNumSamples < margin 139 | 140 | where 141 | 142 | -- Generator: Input stream. 143 | -- 144 | -- We provide a number of samples; otherwise, deviations might not indicate 145 | -- lack of randomness for the signal function. 146 | -- 147 | -- We also provide the max dt and ensure that samples are 148 | myStream :: DTime -> Gen (SignalSampleStream ()) 149 | myStream maxDT = 150 | generateStream 151 | DistRandom 152 | (Nothing, (Just maxDT)) 153 | (Just (Left numSamples)) 154 | 155 | -- Generator: Random generator seed 156 | genDt :: Gen Double 157 | genDt = fmap getPositive arbitrary 158 | 159 | -- Generator: Random generator seed 160 | genSeed :: Gen Int 161 | genSeed = arbitrary 162 | 163 | -- Generator: Random value generator 164 | genOutput :: Gen Int 165 | genOutput = arbitrary 166 | 167 | -- Constant: Number of samples in the stream used for testing. 168 | -- 169 | -- This number has to be high; numbers 100 or below will likely not work. 170 | numSamples :: Int 171 | numSamples = 400 172 | 173 | -- Constant: Max difference accepted between actual occurrences and 174 | -- expected occurrences 175 | margin :: Int 176 | margin = round (fromIntegral numSamples * 0.05) 177 | 178 | -- * Auxiliary definitions 179 | 180 | -- | Check whether a list of values exhibits randomness. 181 | -- 182 | -- This function implements the Frequence (Monobit) Test, as described in 183 | -- Section 2.1 of "A Statistical Test Suite for Random and Pseudorandom Number 184 | -- Generators for Cryptographic Applications", by Rukhin et al. 185 | isRandom :: Bits a => [a] -> Bool 186 | isRandom ls = pValue >= 0.01 187 | where 188 | pValue = erfc (sObs / sqrt 2) 189 | sObs = abs sn / sqrt n 190 | n = fromIntegral $ elemSize * length ls 191 | sn = sum $ map numConv ls 192 | 193 | -- Number of bits per element 194 | elemSize :: Int 195 | elemSize = 196 | -- bitSize' ignores the argument, so it's ok if the list is empty 197 | bitSize' $ head ls 198 | 199 | -- Substitute each digit e in the binary representation of the input value 200 | -- by 2e – 1, and add the results. 201 | numConv :: Bits a => a -> Float 202 | numConv x = fromIntegral $ numOnes - numZeroes 203 | where 204 | numOnes = popCount x 205 | numZeroes = elemSize - popCount x 206 | 207 | -- Number of bits per element 208 | elemSize = bitSize' x 209 | 210 | -- | Complementary Error Function, compliant with the definition of erfcf in 211 | -- ANSI C. 212 | erfc :: Float -> Float 213 | erfc = realToFrac . erfcf . realToFrac 214 | 215 | -- | ANSI C function erfcf defined in math.h 216 | foreign import ccall "erfcf" erfcf :: CFloat -> CFloat 217 | 218 | -- | Transform SignalSampleStreams into streams of differences. 219 | structure :: (a, [(b, a)]) -> (a, [(b, Maybe a)]) 220 | structure (x, xs) = (x, map (second Just) xs) 221 | 222 | -- | Implementation of bitSize that uses bitSize/bitSizeMaybe depending on the 223 | -- version of base available. 224 | bitSize' :: Bits a => a -> Int 225 | bitSize' = 226 | #if __GLASGOW_HASKELL__ < 708 227 | bitSize 228 | #else 229 | fromMaybe 0 . bitSizeMaybe 230 | #endif 231 | -------------------------------------------------------------------------------- /yampa-test/tests/Test/FRP/Yampa/Time.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Description : Test cases for FRP.Yampa.Time 3 | -- Copyright : (c) Ivan Perez, 2014-2022 4 | -- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 5 | -- Authors : Antony Courtney, Henrik Nilsson, Ivan Perez 6 | module Test.FRP.Yampa.Time 7 | ( tests 8 | ) 9 | where 10 | 11 | import Test.QuickCheck 12 | import Test.Tasty (TestTree, testGroup) 13 | import Test.Tasty.QuickCheck (testProperty) 14 | 15 | import FRP.Yampa as Yampa 16 | import FRP.Yampa.Stream 17 | import FRP.Yampa.QuickCheck 18 | import FRP.Yampa.LTLFuture 19 | 20 | import TestsCommon 21 | 22 | tests :: TestTree 23 | tests = testGroup "Regression tests for FRP.Yampa.Time" 24 | [ testProperty "localTime (fixed)" (property $ basicsf_t2 ~= basicsf_t2r) 25 | , testProperty "Basic > localTime" prop_basic_localtime_increasing 26 | , testProperty "time (fixed)" (property $ basicsf_t3 ~= basicsf_t3r) 27 | , testProperty "Basic > Time" prop_basic_time_increasing 28 | , testProperty "Basic > Time (fixed delay)" prop_basic_time_fixed_delay 29 | , testProperty "Basic > localTime (fixed delay)" prop_basic_localtime_fixed_delay 30 | ] 31 | 32 | basicsf_t2 :: [Double] 33 | basicsf_t2 = testSF1 localTime 34 | basicsf_t2r = 35 | [ 0.0, 0.25, 0.5, 0.75, 1.0, 1.25, 1.5, 1.75, 2.0, 2.25 36 | , 2.5, 2.75, 3.0, 3.25, 3.5, 3.75, 4.0, 4.25, 4.5, 4.75 37 | , 5.0, 5.25, 5.5, 5.75, 6.0 38 | ] 39 | 40 | prop_basic_localtime_increasing = 41 | forAll myStream $ evalT $ Always $ prop (sf, const (uncurry (>))) 42 | where 43 | myStream :: Gen (SignalSampleStream Float) 44 | myStream = uniDistStream 45 | 46 | sf :: SF a (Time, Time) 47 | sf = loopPre (-1 :: Time) sfI 48 | 49 | sfI :: SF (a,Time) ((Time, Time), Time) 50 | sfI = (localTime *** identity) >>> arr resort 51 | 52 | resort :: (Time, Time) -> ((Time,Time),Time) 53 | resort (newT, oldT) = ((newT, oldT), newT) 54 | 55 | basicsf_t3 :: [Double] 56 | basicsf_t3 = testSF1 time 57 | basicsf_t3r = 58 | [ 0.0, 0.25, 0.5, 0.75, 1.0, 1.25, 1.5, 1.75, 2.0, 2.25 59 | , 2.5, 2.75, 3.0, 3.25, 3.5, 3.75, 4.0, 4.25, 4.5, 4.75 60 | , 5.0, 5.25, 5.5, 5.75, 6.0 61 | ] 62 | 63 | -- | Starting with an accumulator of -1, it gets the local 64 | -- time and outputs the time and the accumulator, updating 65 | -- the latter with the local time at every iteration. 66 | -- The predicate checks whether the time is always strictly 67 | -- greater than the acc. 68 | prop_basic_time_increasing = 69 | forAll myStream $ evalT $ Always $ prop (sf, pred) 70 | where 71 | myStream :: Gen (SignalSampleStream Float) 72 | myStream = uniDistStream 73 | 74 | sf :: SF a (Time, Time) 75 | sf = loopPre (-1 :: Time) sfI 76 | 77 | sfI :: SF (a,Time) ((Time, Time), Time) 78 | sfI = (time *** identity) >>> arr resort 79 | 80 | resort :: (Time, Time) -> ((Time,Time),Time) 81 | resort (newT, oldT) = ((newT, oldT), newT) 82 | 83 | pred :: a -> (Time, Time) -> Bool 84 | pred _ (t,o) = (t > o) 85 | 86 | prop_basic_time_fixed_delay = 87 | forAll myStream $ evalT $ 88 | Always (prop (sf25msec, const (== d))) 89 | 90 | where 91 | myStream :: Gen (SignalSampleStream Float) 92 | myStream = fixedDelayStream d 93 | 94 | sf25msec = time >>> stepDiff (-d) 95 | 96 | d :: Time 97 | d = 0.25 98 | 99 | prop_basic_localtime_fixed_delay = 100 | forAll myStream $ evalT $ 101 | Always (prop (sf25msec, const (== d))) 102 | 103 | where 104 | myStream :: Gen (SignalSampleStream Float) 105 | myStream = fixedDelayStream d 106 | 107 | sf25msec = time >>> stepDiff (-d) 108 | 109 | d :: Time 110 | d = 0.25 111 | 112 | -- * Auxiliary 113 | 114 | -- prop :: SF a b -> (a -> b -> 115 | prop (a,b) = SP ((identity &&& a) >>^ uncurry b) 116 | 117 | stepDiff :: Num a => a -> SF a a 118 | stepDiff z = loopPre z (arr (\(x,y) -> (x - y, x))) 119 | -------------------------------------------------------------------------------- /yampa-test/tests/TestsCommon.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : TestsCommon 3 | -- Description : Common definitions for the regression test modules. 4 | -- Copyright : Yale University, 2003 5 | -- Authors : Antony Courtney and Henrik Nilsson 6 | module TestsCommon where 7 | 8 | import FRP.Yampa 9 | 10 | -- * Rough equality with instances 11 | 12 | -- Rough equality. Only intended to be good enough for test cases in this 13 | -- module. 14 | 15 | class REq a where 16 | (~=) :: a -> a -> Bool 17 | 18 | epsilon :: Fractional a => a 19 | epsilon = 0.0001 20 | 21 | instance REq Float where 22 | x ~= y = abs (x - y) < epsilon -- A relative measure should be used. 23 | 24 | instance REq Double where 25 | x ~= y = abs (x - y) < epsilon -- A relative measure should be used. 26 | 27 | instance REq Int where 28 | (~=) = (==) 29 | 30 | instance REq Integer where 31 | (~=) = (==) 32 | 33 | instance REq Bool where 34 | (~=) = (==) 35 | 36 | instance REq Char where 37 | (~=) = (==) 38 | 39 | instance REq () where 40 | () ~= () = True 41 | 42 | instance (REq a, REq b) => REq (a,b) where 43 | (x1,x2) ~= (y1,y2) = x1 ~= y1 && x2 ~= y2 44 | 45 | instance (REq a, REq b, REq c) => REq (a,b,c) where 46 | (x1,x2,x3) ~= (y1,y2,y3) = x1 ~= y1 && x2 ~= y2 && x3 ~= y3 47 | 48 | instance (REq a, REq b, REq c, REq d) => REq (a,b,c,d) where 49 | (x1,x2,x3,x4) ~= (y1,y2,y3,y4) = x1 ~= y1 50 | && x2 ~= y2 51 | && x3 ~= y3 52 | && x4 ~= y4 53 | 54 | instance (REq a, REq b, REq c, REq d, REq e) => REq (a,b,c,d,e) where 55 | (x1,x2,x3,x4,x5) ~= (y1,y2,y3,y4,y5) = x1 ~= y1 56 | && x2 ~= y2 57 | && x3 ~= y3 58 | && x4 ~= y4 59 | && x5 ~= y5 60 | 61 | instance REq a => REq (Maybe a) where 62 | Nothing ~= Nothing = True 63 | (Just x) ~= (Just y) = x ~= y 64 | _ ~= _ = False 65 | 66 | instance REq a => REq (Event a) where 67 | NoEvent ~= NoEvent = True 68 | (Event x) ~= (Event y) = x ~= y 69 | _ ~= _ = False 70 | 71 | instance (REq a, REq b) => REq (Either a b) where 72 | (Left x) ~= (Left y) = x ~= y 73 | (Right x) ~= (Right y) = x ~= y 74 | _ ~= _ = False 75 | 76 | instance REq a => REq [a] where 77 | [] ~= [] = True 78 | (x:xs) ~= (y:ys) = x ~= y && xs ~= ys 79 | _ ~= _ = False 80 | 81 | ------------------------------------------------------------------------------ 82 | -- Testing utilities 83 | ------------------------------------------------------------------------------ 84 | 85 | testSF1 :: SF Double a -> [a] 86 | testSF1 sf = take 25 (embed sf (deltaEncodeBy (~=) 0.25 [0.0..])) 87 | 88 | testSF2 :: SF Double a -> [a] 89 | testSF2 sf = take 25 (embed sf (deltaEncodeBy (~=) 0.25 input)) 90 | where 91 | -- The initial 0.0 is just for result compatibility with an older 92 | -- version. 93 | input = 0.0 : [ fromIntegral (b `div` freq) | b <- [1..] :: [Int] ] 94 | freq = 5 95 | 96 | ------------------------------------------------------------------------------ 97 | -- Some utilities used for testing laws 98 | ------------------------------------------------------------------------------ 99 | 100 | fun_prod f g = \(x,y) -> (f x, g y) 101 | 102 | assoc :: ((a,b),c) -> (a,(b,c)) 103 | assoc ((a,b),c) = (a,(b,c)) 104 | 105 | assocInv :: (a,(b,c)) -> ((a,b),c) 106 | assocInv (a,(b,c)) = ((a,b),c) 107 | -------------------------------------------------------------------------------- /yampa-test/yampa-test.cabal: -------------------------------------------------------------------------------- 1 | -- Copyright (c) 2017, Ivan Perez 2 | -- 3 | -- All rights reserved. 4 | -- 5 | -- Redistribution and use in source and binary forms, with or without 6 | -- modification, are permitted provided that the following conditions are met: 7 | -- 8 | -- * Redistributions of source code must retain the above copyright notice, 9 | -- this list of conditions and the following disclaimer. 10 | -- 11 | -- * Redistributions in binary form must reproduce the above copyright 12 | -- notice, this list of conditions and the following disclaimer in the 13 | -- documentation and/or other materials provided with the distribution. 14 | -- 15 | -- * Neither the name of Ivan Perez nor the names of other contributors may 16 | -- be used to endorse or promote products derived from this software 17 | -- without specific prior written permission. 18 | -- 19 | -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 20 | -- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 21 | -- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 22 | -- ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE 23 | -- LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 24 | -- CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 25 | -- SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 26 | -- INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 27 | -- CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 28 | -- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 29 | -- POSSIBILITY OF SUCH DAMAGE. 30 | cabal-version: >= 1.10 31 | build-type: Simple 32 | 33 | name: yampa-test 34 | version: 0.15 35 | author: Ivan Perez 36 | maintainer: ivan.perez@keera.co.uk 37 | homepage: http://github.com/ivanperez-keera/Yampa 38 | license: BSD3 39 | license-file: LICENSE 40 | -- copyright 41 | category: Testing 42 | synopsis: Testing library for Yampa. 43 | description: 44 | Testing and debugging library for Yampa. 45 | . 46 | It contains: 47 | . 48 | * Debugging signal functions using 49 | . 50 | * A definition of Temporal Predicates based on LTL. 51 | * Monitoring signal functions with ptLTL using Signal Predicates. 52 | * A definition of Streams, and a Stream manipulation API. 53 | * Signal/stream generators for QuickCheck. 54 | . 55 | A detailed explanation of these ideas is included in the ICFP 2017 paper 56 | . 57 | 58 | extra-source-files: 59 | CHANGELOG 60 | , examples/Testing.hs 61 | 62 | source-repository head 63 | type: git 64 | location: git://github.com/ivanperez-keera/Yampa.git 65 | subdir: yampa-test 66 | 67 | 68 | -- You can disable the regression test suite with -f-test-regression 69 | flag test-space 70 | description: Enable space usage test suite 71 | default: False 72 | manual: True 73 | 74 | 75 | library 76 | exposed-modules: 77 | FRP.Yampa.Debug 78 | FRP.Yampa.LTLFuture 79 | FRP.Yampa.LTLPast 80 | FRP.Yampa.QuickCheck 81 | FRP.Yampa.Stream 82 | 83 | build-depends: 84 | base >= 4 && < 5 85 | , normaldistribution >= 1.1.0.1 && < 1.2 86 | , QuickCheck >= 2.12 && < 2.16 87 | , Yampa >= 0.15 && < 0.16 88 | 89 | default-language: 90 | Haskell2010 91 | 92 | hs-source-dirs: 93 | src 94 | 95 | 96 | test-suite yampa-quicheck 97 | type: 98 | exitcode-stdio-1.0 99 | 100 | main-is: 101 | Main.hs 102 | 103 | other-modules: 104 | Test.FRP.Yampa.Arrow 105 | Test.FRP.Yampa.Basic 106 | Test.FRP.Yampa.Conditional 107 | Test.FRP.Yampa.Delays 108 | Test.FRP.Yampa.Event 109 | Test.FRP.Yampa.EventS 110 | Test.FRP.Yampa.Hybrid 111 | Test.FRP.Yampa.Integration 112 | Test.FRP.Yampa.InternalCore 113 | Test.FRP.Yampa.Loop 114 | Test.FRP.Yampa.Random 115 | Test.FRP.Yampa.Scan 116 | Test.FRP.Yampa.Simulation 117 | Test.FRP.Yampa.Switches 118 | Test.FRP.Yampa.Task 119 | Test.FRP.Yampa.Time 120 | TestsCommon 121 | 122 | build-depends: 123 | base < 5 124 | , Cabal >= 1.19 && < 3.9 125 | , QuickCheck >= 2.12 && < 2.16 126 | , random >= 1.1 && < 1.3 127 | , tasty >= 0.1 && < 1.6 128 | , tasty-quickcheck >= 0.1 && < 0.12 129 | , Yampa 130 | , yampa-test 131 | 132 | default-language: 133 | Haskell2010 134 | 135 | hs-source-dirs: 136 | tests 137 | 138 | ghc-options: 139 | -Wall 140 | 141 | 142 | test-suite space 143 | type: 144 | exitcode-stdio-1.0 145 | 146 | main-is: 147 | Space.hs 148 | 149 | other-modules: 150 | TestsCommon 151 | 152 | default-language: 153 | Haskell2010 154 | 155 | hs-source-dirs: 156 | tests 157 | 158 | ghc-options: 159 | -Wall 160 | 161 | if !flag(test-space) 162 | buildable: 163 | False 164 | else 165 | build-depends: 166 | base >= 4 && < 5 167 | , Yampa 168 | -------------------------------------------------------------------------------- /yampa/HLint.hs: -------------------------------------------------------------------------------- 1 | import "hint" HLint.HLint 2 | 3 | ignore "Redundant bracket" 4 | ignore "Use import/export shortcut" 5 | -------------------------------------------------------------------------------- /yampa/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014-2022, Ivan Perez 2 | Copyright (c) 2007-2012, George Griogidge 3 | Copyright (c) 2005-2006, Henrik Nilsson 4 | Copyright (c) 2003-2004, Henrik Nilsson, Antony Courtney and Yale University. 5 | All rights reserved. 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions 9 | are met: 10 | 11 | - Redistributions of source code must retain the above copyright notice, 12 | this list of conditions and the following disclaimer. 13 | 14 | - Redistributions in binary form must reproduce the above copyright 15 | notice, this list of conditions and the following disclaimer in the 16 | documentation and/or other materials provided with the distribution. 17 | 18 | - Neither name of the copyright holders nor the names of its 19 | contributors may be used to endorse or promote products derived from 20 | this software without specific prior written permission. 21 | 22 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE CONTRIBUTORS 23 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 24 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 25 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 26 | HOLDERS OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 27 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 28 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS 29 | OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 30 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR 31 | TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE 32 | USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 33 | -------------------------------------------------------------------------------- /yampa/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /yampa/Yampa.cabal: -------------------------------------------------------------------------------- 1 | -- Copyright (c) 2003, Henrik Nilsson, Antony Courtney and Yale University. 2 | -- All rights reserved. 3 | -- 4 | -- Redistribution and use in source and binary forms, with or without 5 | -- modification, are permitted provided that the following conditions are met: 6 | -- 7 | -- - Redistributions of source code must retain the above copyright notice, 8 | -- this list of conditions and the following disclaimer. 9 | -- 10 | -- - Redistributions in binary form must reproduce the above copyright notice, 11 | -- this list of conditions and the following disclaimer in the documentation 12 | -- and/or other materials provided with the distribution. 13 | -- 14 | -- - Neither name of the copyright holders nor the names of its contributors 15 | -- may be used to endorse or promote products derived from this software 16 | -- without specific prior written permission. 17 | -- 18 | -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE CONTRIBUTORS "AS 19 | -- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 20 | -- THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 21 | -- PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR THE 22 | -- CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 23 | -- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 24 | -- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; 25 | -- OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 26 | -- WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR 27 | -- OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF 28 | -- ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | cabal-version: >= 1.10 30 | build-type: Simple 31 | 32 | name: Yampa 33 | version: 0.15 34 | author: Henrik Nilsson, Antony Courtney 35 | maintainer: Ivan Perez (ivan.perez@keera.co.uk) 36 | homepage: https://github.com/ivanperez-keera/Yampa/ 37 | license: BSD3 38 | license-file: LICENSE 39 | category: Reactivity, FRP 40 | synopsis: 41 | Elegant Functional Reactive Programming Language for Hybrid Systems 42 | description: 43 | Domain-specific language embedded in Haskell for programming hybrid (mixed 44 | discrete-time and continuous-time) systems. Yampa is based on the concepts of 45 | Functional Reactive Programming (FRP). 46 | 47 | extra-source-files: 48 | CHANGELOG, 49 | 50 | examples/Diagrams.hs 51 | 52 | source-repository head 53 | type: git 54 | location: git://github.com/ivanperez-keera/Yampa.git 55 | subdir: yampa 56 | 57 | 58 | -- You can disable the hlint test suite with -f-test-hlint 59 | flag test-hlint 60 | description: Enable hlint test suite 61 | default: False 62 | manual: True 63 | 64 | -- You can disable the haddock coverage test suite with -f-test-doc-coverage 65 | flag test-doc-coverage 66 | description: Enable haddock coverage test suite 67 | default: False 68 | manual: True 69 | 70 | flag examples 71 | description: Enable examples 72 | default: False 73 | manual: True 74 | 75 | -- WARNING: The following flag exposes Yampa's core. You should avoid using 76 | -- this at all. The only reason to expose it is that we are using Yampa for 77 | -- research, and many extensions require that we expose the constructors. No 78 | -- released project should depend on this. In general, you should always 79 | -- install Yampa with this flag disabled. 80 | flag expose-core 81 | description: 82 | You can enable exposing some of Yampa's core constructs using 83 | -fexpose-core. 84 | . 85 | Enabling this is an unsupported configuration, but it may be useful if you 86 | are building an extension of Yampa for research and do not wish to fork 87 | Yampa completely. 88 | . 89 | No released project should ever depend on this. 90 | default: False 91 | manual: True 92 | 93 | 94 | library 95 | exposed-modules: 96 | FRP.Yampa 97 | FRP.Yampa.Arrow 98 | FRP.Yampa.Basic 99 | FRP.Yampa.Conditional 100 | FRP.Yampa.Delays 101 | FRP.Yampa.Event 102 | FRP.Yampa.EventS 103 | FRP.Yampa.Hybrid 104 | FRP.Yampa.Integration 105 | FRP.Yampa.Loop 106 | FRP.Yampa.Random 107 | FRP.Yampa.Scan 108 | FRP.Yampa.Simulation 109 | FRP.Yampa.Switches 110 | FRP.Yampa.Task 111 | FRP.Yampa.Time 112 | 113 | other-modules: 114 | -- Auxiliary (commonly used) types 115 | FRP.Yampa.Diagnostics 116 | 117 | build-depends: 118 | base < 6 119 | 120 | , deepseq >= 1.3.0.1 && < 1.6 121 | , random >= 1.1 && < 1.3 122 | , simple-affine-space >= 0.1 && < 0.3 123 | 124 | default-language: 125 | Haskell2010 126 | 127 | hs-source-dirs: 128 | src 129 | 130 | ghc-options: 131 | -O3 -Wall -fno-warn-name-shadowing 132 | 133 | if !impl(ghc >= 8.0) 134 | build-depends: 135 | fail == 4.9.* 136 | 137 | if flag(expose-core) 138 | exposed-modules: 139 | FRP.Yampa.InternalCore 140 | else 141 | other-modules: 142 | FRP.Yampa.InternalCore 143 | 144 | 145 | test-suite hlint 146 | type: 147 | exitcode-stdio-1.0 148 | 149 | main-is: 150 | hlint.hs 151 | 152 | default-language: 153 | Haskell2010 154 | 155 | hs-source-dirs: 156 | tests 157 | 158 | if !flag(test-hlint) 159 | buildable: 160 | False 161 | else 162 | build-depends: 163 | base >= 4 && < 5 164 | 165 | , hlint >= 1.7 166 | 167 | -- Verify that the code is thoroughly documented 168 | test-suite haddock-coverage 169 | type: 170 | exitcode-stdio-1.0 171 | 172 | main-is: 173 | HaddockCoverage.hs 174 | 175 | default-language: 176 | Haskell2010 177 | 178 | hs-source-dirs: 179 | tests 180 | 181 | ghc-options: 182 | -Wall 183 | 184 | if !flag(test-doc-coverage) 185 | buildable: 186 | False 187 | else 188 | build-depends: 189 | base >= 4 && < 5 190 | 191 | , directory >= 1.2 && < 1.4 192 | , filepath >= 1.3.0.1 && < 1.6 193 | , process >= 1.1.0.2 && < 1.7 194 | , regex-posix >= 0.95 && < 0.97 195 | 196 | 197 | executable yampa-examples-sdl-bouncingbox 198 | main-is: 199 | MainBouncingBox.hs 200 | 201 | other-modules: 202 | YampaSDL 203 | 204 | default-language: 205 | Haskell2010 206 | 207 | hs-source-dirs: 208 | examples/yampa-game/ 209 | 210 | ghc-options: 211 | -O3 -Wall -fno-warn-name-shadowing 212 | 213 | if flag(examples) 214 | buildable: 215 | True 216 | build-depends: 217 | base < 5 218 | 219 | , deepseq >= 1.3.0.1 && < 1.6 220 | , random >= 1.1 && < 1.3 221 | , SDL >= 0.6 && < 0.7 222 | , Yampa 223 | else 224 | buildable: 225 | False 226 | 227 | 228 | executable yampa-examples-sdl-circlingmouse 229 | main-is: 230 | MainCircleMouse.hs 231 | 232 | other-modules: 233 | YampaSDL 234 | 235 | default-language: 236 | Haskell2010 237 | 238 | hs-source-dirs: 239 | examples/yampa-game/ 240 | 241 | ghc-options: 242 | -O3 -Wall -fno-warn-name-shadowing 243 | 244 | if flag(examples) 245 | buildable: 246 | True 247 | build-depends: 248 | base < 5 249 | 250 | , deepseq >= 1.3.0.1 && < 1.6 251 | , random >= 1.1 && < 1.3 252 | , SDL >= 0.6 && < 0.7 253 | , Yampa 254 | else 255 | buildable: 256 | False 257 | 258 | 259 | executable yampa-examples-sdl-wiimote 260 | main-is: 261 | MainWiimote.hs 262 | 263 | other-modules: 264 | YampaSDL 265 | 266 | default-language: 267 | Haskell2010 268 | 269 | hs-source-dirs: 270 | examples/yampa-game/ 271 | 272 | ghc-options: 273 | -O3 -Wall -fno-warn-name-shadowing -rtsopts 274 | 275 | if flag(examples) 276 | buildable: 277 | True 278 | build-depends: 279 | base < 5 280 | 281 | , deepseq >= 1.3.0.1 && < 1.6 282 | , hcwiid >= 0.0.5 && < 0.1 283 | , random >= 1.1 && < 1.3 284 | , SDL >= 0.6 && < 0.7 285 | , Yampa 286 | else 287 | buildable: 288 | False 289 | 290 | 291 | executable yampa-examples-elevator 292 | main-is: 293 | TestElevatorMain.hs 294 | 295 | other-modules: 296 | Elevator 297 | 298 | default-language: 299 | Haskell2010 300 | 301 | hs-source-dirs: 302 | examples/Elevator 303 | 304 | ghc-options: 305 | -O3 -Wall -fno-warn-name-shadowing 306 | 307 | if flag(examples) 308 | buildable: 309 | True 310 | build-depends: 311 | base < 5 312 | , Yampa 313 | else 314 | buildable: 315 | False 316 | 317 | 318 | executable yampa-examples-tailgatingdetector 319 | main-is: 320 | TestTGMain.hs 321 | 322 | other-modules: 323 | TailgatingDetector 324 | 325 | default-language: 326 | Haskell2010 327 | 328 | hs-source-dirs: 329 | examples/TailgatingDetector 330 | 331 | ghc-options: 332 | -O3 -Wall -fno-warn-name-shadowing 333 | 334 | if flag(examples) 335 | buildable: 336 | True 337 | build-depends: 338 | base < 5 339 | , Yampa 340 | else 341 | buildable: 342 | False 343 | 344 | benchmark yampa-bench 345 | type: 346 | exitcode-stdio-1.0 347 | 348 | main-is: 349 | Bench.hs 350 | 351 | build-depends: 352 | base < 5 353 | , criterion >= 0.5.0.0 && < 1.7 354 | , filepath >= 1.3.0.1 && < 1.6 355 | , time >= 1.4 && < 1.15 356 | , Yampa 357 | 358 | default-language: 359 | Haskell2010 360 | 361 | hs-source-dirs: 362 | benchmarks 363 | -------------------------------------------------------------------------------- /yampa/benchmarks/Bench.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Description : A benchmark for Yampa. 3 | -- Copyright : (c) Ivan Perez, 2023 4 | -- Authors : Ivan Perez 5 | -- 6 | -- A benchmark for Yampa. 7 | module Main where 8 | 9 | import Criterion (bench, bgroup, nf) 10 | import Criterion.Main (defaultConfig, defaultMainWith) 11 | import Criterion.Types (Config(csvFile, resamples, verbosity) 12 | , Verbosity(Quiet)) 13 | import Data.Time.LocalTime (getZonedTime) 14 | import Data.Time.Format (formatTime, defaultTimeLocale) 15 | import System.Environment (getArgs, withArgs) 16 | import System.FilePath (()) 17 | 18 | import FRP.Yampa 19 | 20 | -- | Run all benchmarks. 21 | main :: IO () 22 | main = do 23 | config <- customConfig 24 | withArgs [] $ 25 | defaultMainWith config 26 | [ bgroup "basic" 27 | [ bench "identity" $ nf basicIdentity 10000 28 | , bench "id" $ nf basicId 10000 29 | ] 30 | , bgroup "compositions" 31 | [ bench "identity" $ nf composeIdentity 10000 32 | , bench "idid" $ nf composeIdId 10000 33 | , bench "plus" $ nf composePlus 10000 34 | , bench "plusplus" $ nf composePlusPlus 10000 35 | , bench "plusmult" $ nf composePlusMult 10000 36 | , bench "mult" $ nf composeMult 10000 37 | , bench "multmult" $ nf composeMultMult 10000 38 | ] 39 | , bgroup "counter" 40 | [ bench "counter1" $ nf counter1 10000 41 | , bench "counter2" $ nf counter2 10000 42 | ] 43 | ] 44 | 45 | -- * Benchmarks 46 | 47 | -- ** Basic 48 | 49 | -- | Yampa's specialized identity function. 50 | basicIdentity :: Int -> [Int] 51 | basicIdentity n = embed sf stream 52 | where 53 | sf = identity 54 | stream = deltaEncode 1.0 (replicate n 1) 55 | 56 | -- | Standard function identity lifted to SFs. 57 | basicId :: Int -> [Int] 58 | basicId n = embed sf stream 59 | where 60 | sf = arr id 61 | stream = deltaEncode 1.0 (replicate n 1) 62 | 63 | -- ** Compositions 64 | 65 | -- | Composition of Yampa's specialized identity function. 66 | composeIdentity :: Int -> [Int] 67 | composeIdentity n = embed sf stream 68 | where 69 | sf = identity >>> identity 70 | stream = deltaEncode 1.0 (replicate n 1) 71 | 72 | -- | Composition of standard function identity lifted to SFs. 73 | composeIdId :: Int -> [Int] 74 | composeIdId n = embed sf stream 75 | where 76 | sf = arr id >>> arr id 77 | stream = deltaEncode 1.0 (replicate n 1) 78 | 79 | -- | Plus operation. 80 | -- 81 | -- This is not a composition; it merely exists to serve as a comparison with 82 | -- composePlusPlus. 83 | composePlus :: Int -> [Int] 84 | composePlus n = embed sf stream 85 | where 86 | sf = arr (+3) 87 | stream = deltaEncode 1.0 $ take n [1..] 88 | 89 | -- | Composition of addition lifted to SFs. 90 | composePlusPlus :: Int -> [Int] 91 | composePlusPlus n = embed sf stream 92 | where 93 | sf = arr (+1) >>> arr (+2) 94 | stream = deltaEncode 1.0 $ take n [1..] 95 | 96 | -- | Composition of addition with multiplication, lifted to SFs. 97 | composePlusMult :: Int -> [Int] 98 | composePlusMult n = embed sf stream 99 | where 100 | sf = arr (+100) >>> arr (*2) 101 | stream = deltaEncode 1.0 $ take n [10..] 102 | 103 | -- | Multiplication operation. 104 | -- 105 | -- This is not a composition; it merely exists to serve as a comparison with 106 | -- composeMultMult. 107 | composeMult :: Int -> [Int] 108 | composeMult n = embed sf stream 109 | where 110 | sf = arr (*20) 111 | stream = deltaEncode 1.0 $ take n [10..] 112 | 113 | -- | Composition of multiplication lifted to SFs. 114 | composeMultMult :: Int -> [Int] 115 | composeMultMult n = embed sf stream 116 | where 117 | sf = arr (*10) >>> arr (*2) 118 | stream = deltaEncode 1.0 $ take n [10..] 119 | 120 | -- ** Counter 121 | 122 | -- | Counter without explicit seq. 123 | counter1 :: Int -> [Int] 124 | counter1 n = embed sf stream 125 | where 126 | sf = loopPre 0 (arr (dup . uncurry (+))) 127 | stream = deltaEncode 1.0 (replicate n 1) 128 | 129 | -- | Counter with explicit seq. 130 | counter2 :: Int -> [Int] 131 | counter2 n = embed sf stream 132 | where 133 | sf = loopPre 0 (arr ((\x -> x `seq` (x, x)). uncurry (+))) 134 | stream = deltaEncode 1.0 (replicate n 1) 135 | 136 | -- * Auxiliary functions 137 | 138 | -- Construct a config with increased number of sampling 139 | -- and a custom name for the report. 140 | customConfig :: IO Config 141 | customConfig = do 142 | args <- getArgs 143 | 144 | let dir = case args of 145 | [] -> "." 146 | (x:xs) -> x 147 | 148 | -- Custom filename using the current time 149 | timeString <- (formatTime defaultTimeLocale "%F-%H%M%S") <$> getZonedTime 150 | let filename = concat [ timeString, "-", "bench.csv" ] 151 | 152 | return $ defaultConfig { csvFile = Just $ dir filename 153 | , resamples = 100000 154 | , verbosity = Quiet 155 | } 156 | -------------------------------------------------------------------------------- /yampa/examples/Core.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Copyright : (c) Ivan Perez, 2015-2022 3 | -- License : BSD-style (see the LICENSE file in the distribution) 4 | -- Maintainer : ivan.perez@keera.co.uk 5 | -- 6 | -- Minimal FRP core. 7 | -- 8 | -- For documentation purposes only, to serve as a minimal FRP implementation. 9 | -- Based on Antony Courtney's thesis "Modeling User Interfaces in a Functional 10 | -- Language", page 48 11 | -- (see https://www.antonycourtney.com/pubs/ac-thesis.pdf, page 61). 12 | -- 13 | -- Notes: 14 | -- 15 | -- - While 'time' is defined as "core", it is not a primitive in Yampa, and it 16 | -- is actually defined as the 'integral' of @1@ over time. 17 | -- 18 | -- - This does not include 'derivative'. 19 | -- 20 | -- - This does not include parallel switching combinators (see 21 | -- 'FRP.Yampa.Switches'). 22 | -- 23 | module Core 24 | ( 25 | -- * Signal function 26 | SF 27 | 28 | -- * Stateless combinators 29 | , iPre 30 | , arr 31 | , (>>>) 32 | , first 33 | 34 | -- * Stateful combinators 35 | , loop 36 | -- | Instantly loops an SF, making the second output also the second 37 | -- input, using the fix combinator. This introduces a instant loop; 38 | -- without delays, that may lead to an infinite loop. 39 | , integral 40 | 41 | -- ** Switching upon certain events 42 | , Event(..) 43 | , switch 44 | 45 | -- ** Time 46 | -- | Note: The function 'time' is actually the 'integral' of @1@ over time. 47 | -- So, it's not really necessary. 48 | , Time 49 | , time 50 | ) 51 | where 52 | 53 | import FRP.Yampa 54 | -------------------------------------------------------------------------------- /yampa/examples/Diagrams.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE NoMonomorphismRestriction #-} 4 | -- | 5 | -- Copyright : (c) Ivan Perez, 2018-2022 6 | -- License : BSD-style (see the LICENSE file in the distribution) 7 | -- Maintainer : ivan.perez@keera.co.uk 8 | -- 9 | -- Example of connecting the diagrams drawing library with Yampa. 10 | -- 11 | -- Based on: 12 | -- https://archives.haskell.org/projects.haskell.org/diagrams/gallery/VectorField.html 13 | -- 14 | -- Install diagrams with Cairo support, together with Yampa: 15 | -- 16 | -- cabal v1-sandbox init 17 | -- cabal v1-install Yampa diagrams diagrams-cairo 18 | -- 19 | -- Compile in a sandbox with: 20 | -- 21 | -- cabal v1-exec -- ghc --make examples/Diagrams.hs 22 | -- 23 | -- And run with: 24 | -- 25 | -- ./examples/Diagrams -w 400 -h 400 -o output.gif 26 | 27 | import Diagrams.Backend.Cairo.CmdLine 28 | import Diagrams.Prelude hiding (Time) 29 | import FRP.Yampa hiding (norm, ( # ), (*^)) 30 | 31 | main :: IO () 32 | main = mainWith $ take 60 frames 33 | 34 | -- | Frames of the animation. 35 | frames :: [(Diagram B, Int)] 36 | frames = zip ((embed sfVF $ deltaEncode 1 $ repeat ())) (repeat 1) 37 | 38 | -- | Signal producing the diagram at a point in time. 39 | sfVF :: SF () (Diagram B) 40 | sfVF = proc () -> do 41 | t <- time -< () 42 | let diag = ( field t # translateY 0.05 # lc white 43 | <> ( square 3.5 # lw none # alignBL)) 44 | returnA -< diag 45 | 46 | -- | Field of arrows as it changes over time. 47 | field :: Time -> Diagram B 48 | field t = position $ zip points (arrows t) 49 | 50 | -- | Arrow points as they change over time. 51 | points :: [Point V2 Double] 52 | points = map p2 locs 53 | 54 | -- | Arrow locations as they change over time. 55 | locs :: [(Double, Double)] 56 | locs = [(x, y) | x <- [0.1, 0.3 .. 3.25], y <- [0.1, 0.3 .. 3.25]] 57 | 58 | -- | Arrows as they change over time. 59 | arrows :: Time -> [Diagram B] 60 | arrows t = map (arrowAtPoint t) locs 61 | 62 | -- | Diagram of a star at a given point in time and space. 63 | arrowAtPoint :: Time -> (Double, Double) -> Diagram B 64 | arrowAtPoint t (x, y) = arrowAt' opts (p2 (x, y)) (sL *^ vf) # alignTL 65 | where 66 | vf = vectorField t (x, y) 67 | m = norm $ vectorField t (x, y) 68 | 69 | -- Head size is a function of the length of the vector 70 | -- as are tail size and shaft length. 71 | 72 | hs = 0.02 * m 73 | sW = 0.004 * m 74 | sL = 0.05 + 0.1 * m 75 | opts = (with & arrowHead .~ spike 76 | & headLength .~ normalized hs 77 | & shaftStyle %~ lwN sW) 78 | 79 | -- | Direction vector depending on the time and the position in space. 80 | vectorField :: Time -> (Double, Double) -> V2 Double 81 | vectorField t (x, y) = r2 (sin (t + y + 1), sin (t + x + 1)) 82 | -------------------------------------------------------------------------------- /yampa/examples/Elevator/Elevator.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | -- | 3 | -- Module : Elevator 4 | -- Description : Elevator simulation based on the Fran version by Thompson. 5 | -- Copyright : (c) Ivan Perez, 2014-2022 6 | -- (c) George Giorgidze, 2007-2012 7 | -- (c) Henrik Nilsson, The University of Nottingham, 2004-2006 8 | -- License : BSD-style (see the LICENSE file in the distribution) 9 | -- 10 | -- Maintainer : ivan.perez@keera.co.uk 11 | -- Stability : provisional 12 | -- Portability : non-portable (GHC extensions) 13 | -- 14 | -- Elevator simulation based on the Fran version from Simon Thompson's paper "A 15 | -- functional reactive animation of a lift using Fran". 16 | module Elevator where 17 | 18 | import FRP.Yampa 19 | 20 | -- * Auxiliary definitions 21 | 22 | type Position = Double -- [m] 23 | type Distance = Double -- [m] 24 | type Velocity = Double -- [m/s] 25 | 26 | -- * Elevator simulator 27 | 28 | lower, upper :: Position 29 | lower = 0 30 | upper = 5 31 | 32 | upRate, downRate :: Velocity 33 | upRate = 1 34 | downRate = 1.1 35 | 36 | elevator :: SF (Event (), Event ()) Position 37 | elevator = proc (lbp,rbp) -> do 38 | rec 39 | -- This delayed hold can be thought of as modelling acceleration. 40 | -- It is not "physical" to expect a desire to travel at a certain 41 | -- velocity to be immediately reflected in the actual velocity. 42 | -- (The reason we get into trouble here is that the stop/go events 43 | -- depends instantaneously on "stopped" which in turn depends 44 | -- instantaneously on "v".) 45 | v <- dHold 0 -< stop `tag` 0 46 | `lMerge` goUp `tag` upRate 47 | `lMerge` goDown `tag` (-downRate) 48 | 49 | y <- (lower +) ^<< integral -< v 50 | 51 | let atBottom = y <= lower 52 | atTop = y >= upper 53 | stopped = v == 0 -- Somewhat dubious ... 54 | 55 | waitingBottom = atBottom && stopped 56 | waitingTop = atTop && stopped 57 | 58 | arriveBottom <- edge -< atBottom 59 | arriveTop <- edge -< atTop 60 | 61 | let setUp = lbp `tag` True 62 | setDown = rbp `tag` True 63 | 64 | -- This does not work. The reset events would be generated as soon 65 | -- as the corresponding go event was generated, but the latter 66 | -- depend instantaneusly on the reset signals. 67 | -- resetUp = goUp `tag` False 68 | -- resetDown = goDown `tag` False 69 | 70 | -- One approach would be to wait for "physical confiramtion" 71 | -- that the elevator actually is moving in the desired direction: 72 | -- resetUp <- (`tag` True) ^<< edge -< v > 0 73 | -- resetDown <- (`tag` False) ^<< edge -< v < 0 74 | 75 | -- Another approach is to simply delay the reset events to avoid 76 | -- suppressing the very event that generates the reset event. 77 | resetUp <- iPre noEvent -< goUp `tag` False 78 | resetDown <- iPre noEvent -< goDown `tag` False 79 | 80 | -- Of course, a third approach would be to just use dHold below. 81 | -- But that does not seem to be the right solution to me. 82 | upPending <- hold False -< setUp `lMerge` resetUp 83 | downPending <- hold False -< setDown `lMerge` resetDown 84 | 85 | let pending = upPending || downPending 86 | eitherButton = lbp `lMerge` rbp 87 | 88 | goDown = arriveTop `gate` pending 89 | `lMerge` eitherButton `gate` waitingTop 90 | 91 | goUp = arriveBottom `gate` pending 92 | `lMerge` eitherButton `gate` waitingBottom 93 | 94 | stop = (arriveTop `lMerge` arriveBottom) `gate` not pending 95 | 96 | returnA -< y 97 | -------------------------------------------------------------------------------- /yampa/examples/Elevator/TestElevatorMain.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Description : Testing of the Elevator simulator. 3 | -- Copyright : The University of Nottingham, 2004 4 | -- Authors : Henrik Nilsson 5 | -- 6 | -- Part of Elevator example. 7 | module Main where 8 | 9 | import Data.List (sortBy, intersperse) 10 | import Data.Maybe (catMaybes) 11 | 12 | import FRP.Yampa 13 | 14 | import Elevator 15 | 16 | smplPer = 0.01 17 | 18 | lbps :: SF a (Event ()) 19 | lbps = afterEach [(3.0, ()), (2.0, ()), (50.0, ())] 20 | 21 | rbps :: SF a (Event ()) 22 | rbps = afterEach [(20.0, ()), (2.0, ()), (18.0, ()), (15.001, ())] 23 | 24 | -- Looks for interesting events by inspecting the input events 25 | -- and the elevator position over the interval [0, t_max]. 26 | 27 | data State = Stopped | GoingUp | GoingDown deriving Eq 28 | 29 | testElevator :: Time -> [(Time, ((Event (), Event ()), Position))] 30 | testElevator t_max = takeWhile ((<= t_max) . fst) tios 31 | where 32 | -- Time, Input, and Output 33 | tios = embed (localTime &&& ((lbps &&& rbps >>^ dup) >>> second elevator)) 34 | (deltaEncode smplPer (repeat ())) 35 | 36 | findEvents :: [(Time, ((Event (), Event ()), Position))] 37 | -> [(Time, Position, String)] 38 | findEvents [] = [] 39 | findEvents tios@((_, (_, y)) : _) = feAux Stopped y tios 40 | where 41 | feAux _ _ [] = [] 42 | feAux sPre yPre ((t, ((lbp, rbp), y)) : tios') = 43 | if not (null message) 44 | then (t, y, message) : feAux s y tios' 45 | else feAux s y tios' 46 | where 47 | s = if y == yPre 48 | then Stopped 49 | else if yPre < y 50 | then GoingUp 51 | else 52 | GoingDown 53 | 54 | ms = if s /= sPre 55 | then 56 | case s of 57 | Stopped -> Just "elevator stopped" 58 | GoingUp -> Just "elevator started going up" 59 | GoingDown -> Just "elevator started going down" 60 | else 61 | Nothing 62 | 63 | mu = if isEvent lbp 64 | then Just "up button pressed" 65 | else Nothing 66 | 67 | md = if isEvent rbp 68 | then Just "down button pressed" 69 | else Nothing 70 | 71 | message = concat (intersperse ", " (catMaybes [ms, mu, md])) 72 | 73 | formatEvent :: (Time, Position, String) -> String 74 | formatEvent (t, y, m) = "t = " ++ t' ++ ",\ty = " ++ y' ++ ":\t" ++ m 75 | where 76 | t' = show (fromIntegral (round (t * 100)) / 100) 77 | y' = show (fromIntegral (round (y * 100)) / 100) 78 | 79 | ppEvents [] = return () 80 | ppEvents (e : es) = putStrLn (formatEvent e) >> ppEvents es 81 | 82 | main = ppEvents (findEvents (testElevator 100)) 83 | -------------------------------------------------------------------------------- /yampa/examples/TailgatingDetector/TestTGMain.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | -- | 3 | -- Description : Testing of the tailgating detector. 4 | -- Copyright : Yale University, 2003 5 | -- Authors : Henrik Nilsson 6 | -- 7 | -- Part of the TailgatingDetector example. 8 | module Main where 9 | 10 | import Data.List (sortBy) 11 | 12 | import FRP.Yampa 13 | 14 | import TailgatingDetector 15 | 16 | -- Looks for interesting events in the video stream (cars entering, 17 | -- leaving, overtaking) in the interval [0, t]. 18 | testVideo :: Time -> [(Time, Event Video)] 19 | testVideo t_max = filter (isEvent . snd) $ 20 | takeWhile (\(t, _) -> t <= t_max) $ 21 | embed (localTime &&& (videoAndTrackers >>^ fst) 22 | >>> filterVideo) 23 | (deltaEncode smplPer (repeat ())) 24 | where 25 | filterVideo = second (edgeBy change []) 26 | where 27 | change v_prev v = 28 | if (map fst (sortBy comparePos v_prev)) 29 | /= (map fst (sortBy comparePos v)) 30 | then Just v 31 | else Nothing 32 | 33 | comparePos (_, (p1, _)) (_, (p2, _)) = compare p1 p2 34 | 35 | ppTestVideo t = mapM_ (putStrLn . show) (testVideo t) 36 | 37 | testTailgating t_max = filter (isEvent . snd) $ 38 | takeWhile (\(t, _) -> t <= t_max) $ 39 | embed (localTime 40 | &&& (mkCar3 (-1000) 40 95 30 200 30.9 41 | &&& mkCar1 0 30 42 | >>> tailgating)) 43 | (deltaEncode smplPer (repeat ())) 44 | 45 | testMCT :: Time -> [(Time, Event [(Id, Car)])] 46 | testMCT t_max = filter (isEvent . snd) $ 47 | takeWhile (\(t, _) -> t <= t_max) $ 48 | embed (localTime 49 | &&& (uavStatus 50 | >>> (highway &&& identity >>> mkVideoAndTrackers) 51 | &&& identity 52 | >>> arr (\((v, ect), s) -> (v, s, ect)) 53 | >>> mct) 54 | >>> filterMCTOutput) 55 | (deltaEncode smplPer (repeat ())) 56 | where 57 | filterMCTOutput = second (edgeBy change []) 58 | where 59 | change v_prev v = 60 | if (map fst (sortBy comparePos v_prev)) 61 | /= (map fst (sortBy comparePos v)) 62 | then Just v 63 | else Nothing 64 | 65 | comparePos (_, (p1, _)) (_, (p2, _)) = compare p1 p2 66 | 67 | ppTestMCT t = mapM_ (putStrLn . show) (testMCT t) 68 | 69 | testMTGD :: Time -> [(Time, (Event [(Id,Id)], [(Id, Car)]))] 70 | testMTGD t_max = 71 | filter (isEvent . fst . snd) $ 72 | takeWhile (\(t, _) -> t <= t_max) $ 73 | embed (localTime 74 | &&& (proc _ -> do s <- uavStatus -< () 75 | h <- highway -< () 76 | (v, ect) <- mkVideoAndTrackers -< (h, s) 77 | (ics, etgs) <- findTailgaters -< (v,s,ect) 78 | etgs <- mtgd -< ics 79 | returnA -< (etgs, ics))) 80 | (deltaEncode smplPer (repeat ())) 81 | 82 | ppTestMTGD t = mapM_ (putStrLn . show) (testMTGD t) 83 | 84 | -- We could read the car specification from standard input. 85 | main = ppTestMTGD 2000 86 | -------------------------------------------------------------------------------- /yampa/examples/yampa-game/IdentityList.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Copyright : (c) Ivan Perez, 2014-2022 3 | -- (c) George Giorgidze, 2007-2012 4 | -- (c) Henrik Nilsson, 2005-2006 5 | -- (c) Henrik Nilsson, Yale University, 2003-2004 6 | -- License : BSD-style (see the LICENSE file in the distribution) 7 | -- Maintainer : ivan.perez@keera.co.uk 8 | -- 9 | -- Association list with automatic key assignment and identity-preserving map 10 | -- and filter operations. 11 | module IdentityList 12 | ( ILKey 13 | , IL 14 | , emptyIL 15 | , insertIL_ 16 | , insertIL 17 | , listToIL 18 | , keysIL 19 | , elemsIL 20 | , assocsIL 21 | , deleteIL 22 | , updateIL 23 | , updateILWith 24 | , mapIL 25 | , filterIL 26 | , mapFilterIL 27 | , lookupIL 28 | , findIL 29 | , mapFindIL 30 | , findAllIL 31 | , mapFindAllIL 32 | ) 33 | where 34 | 35 | import Data.List (find) 36 | 37 | -- * Data type definitions 38 | 39 | -- | Identity-list key type 40 | type ILKey = Int 41 | 42 | -- | Identity-list, abstract. Instance of functor. 43 | 44 | -- Invariants: 45 | -- * Sorted in descending key order. (We don't worry about 46 | -- key wrap around). 47 | -- * Keys are NOT reused 48 | data IL a = IL { ilNextKey :: ILKey, ilAssocs :: [(ILKey, a)] } 49 | 50 | -- * Class instances 51 | 52 | instance Functor IL where 53 | fmap f (IL {ilNextKey = nk, ilAssocs = kas}) = 54 | IL {ilNextKey = nk, ilAssocs = [ (i, f a) | (i, a) <- kas ]} 55 | 56 | -- * Constructors 57 | 58 | emptyIL :: IL a 59 | emptyIL = IL {ilNextKey = 0, ilAssocs = []} 60 | 61 | insertIL_ :: a -> IL a -> IL a 62 | insertIL_ a il = snd (insertIL a il) 63 | 64 | insertIL :: a -> IL a -> (ILKey, IL a) 65 | insertIL a (IL {ilNextKey = k, ilAssocs = kas}) = (k, il') where 66 | il' = IL {ilNextKey = k + 1, ilAssocs = (k, a) : kas} 67 | 68 | listToIL :: [a] -> IL a 69 | listToIL as = IL { ilNextKey = length as 70 | , ilAssocs = reverse (zip [0..] as) -- Maintain invariant! 71 | } 72 | 73 | -- * Additional selectors 74 | 75 | assocsIL :: IL a -> [(ILKey, a)] 76 | assocsIL = ilAssocs 77 | 78 | keysIL :: IL a -> [ILKey] 79 | keysIL = map fst . ilAssocs 80 | 81 | elemsIL :: IL a -> [a] 82 | elemsIL = map snd . ilAssocs 83 | 84 | -- * Mutators 85 | 86 | deleteIL :: ILKey -> IL a -> IL a 87 | deleteIL k (IL {ilNextKey = nk, ilAssocs = kas}) = 88 | IL {ilNextKey = nk, ilAssocs = deleteHlp kas} 89 | where 90 | deleteHlp [] = [] 91 | deleteHlp kakas@(ka@(k', _) : kas) | k > k' = kakas 92 | | k == k' = kas 93 | | otherwise = ka : deleteHlp kas 94 | 95 | updateIL :: ILKey -> a -> IL a -> IL a 96 | updateIL k v l = updateILWith k (const v) l 97 | 98 | updateILWith :: ILKey -> (a -> a) -> IL a -> IL a 99 | updateILWith k f l = mapIL g l 100 | where g (k',v') | k == k' = f v' 101 | | otherwise = v' 102 | 103 | -- * Filter and map operations 104 | 105 | -- These are "identity-preserving", i.e. the key associated with an element 106 | -- in the result is the same as the key of the element from which the 107 | -- result element was derived. 108 | 109 | mapIL :: ((ILKey, a) -> b) -> IL a -> IL b 110 | mapIL f (IL {ilNextKey = nk, ilAssocs = kas}) = 111 | IL {ilNextKey = nk, ilAssocs = [(k, f ka) | ka@(k,_) <- kas]} 112 | 113 | filterIL :: ((ILKey, a) -> Bool) -> IL a -> IL a 114 | filterIL p (IL {ilNextKey = nk, ilAssocs = kas}) = 115 | IL {ilNextKey = nk, ilAssocs = filter p kas} 116 | 117 | mapFilterIL :: ((ILKey, a) -> Maybe b) -> IL a -> IL b 118 | mapFilterIL p (IL {ilNextKey = nk, ilAssocs = kas}) = 119 | IL { ilNextKey = nk 120 | , ilAssocs = [(k, b) | ka@(k, _) <- kas, Just b <- [p ka]] 121 | } 122 | 123 | -- * Lookup operations 124 | 125 | lookupIL :: ILKey -> IL a -> Maybe a 126 | lookupIL k il = lookup k (ilAssocs il) 127 | 128 | findIL :: ((ILKey, a) -> Bool) -> IL a -> Maybe a 129 | findIL p (IL {ilAssocs = kas}) = findHlp kas 130 | where 131 | findHlp [] = Nothing 132 | findHlp (ka@(_, a) : kas) = if p ka then Just a else findHlp kas 133 | 134 | mapFindIL :: ((ILKey, a) -> Maybe b) -> IL a -> Maybe b 135 | mapFindIL p (IL {ilAssocs = kas}) = mapFindHlp kas 136 | where 137 | mapFindHlp [] = Nothing 138 | mapFindHlp (ka : kas) = case p ka of 139 | Nothing -> mapFindHlp kas 140 | jb@(Just _) -> jb 141 | 142 | findAllIL :: ((ILKey, a) -> Bool) -> IL a -> [a] 143 | findAllIL p (IL {ilAssocs = kas}) = [ a | ka@(_, a) <- kas, p ka ] 144 | 145 | mapFindAllIL:: ((ILKey, a) -> Maybe b) -> IL a -> [b] 146 | mapFindAllIL p (IL {ilAssocs = kas}) = [ b | ka <- kas, Just b <- [p ka] ] 147 | -------------------------------------------------------------------------------- /yampa/examples/yampa-game/MainBouncingBox.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | import FRP.Yampa as Yampa 3 | import Graphics.UI.SDL as SDL 4 | 5 | -- Helper functions 6 | import YampaSDL 7 | 8 | width :: Num a => a 9 | width = 640 10 | height :: Num a => a 11 | height = 480 12 | 13 | -- | Reactimation. 14 | -- 15 | -- This main function runs an FRP system by producing a signal, passing it 16 | -- through a signal function, and consuming it. 17 | -- 18 | -- The first two arguments to reactimate are the value of the input signal 19 | -- at time zero and at subsequent times, together with the times between 20 | -- samples. 21 | -- 22 | -- The third argument to reactimate is the output consumer that renders 23 | -- the signal. 24 | -- 25 | -- The last argument is the actual signal function. 26 | -- 27 | main = do 28 | timeRef <- yampaSDLTimeInit 29 | reactimate initGraphs 30 | (\_ -> do 31 | dtSecs <- yampaSDLTimeSense timeRef 32 | return (dtSecs, Nothing)) 33 | (\_ e -> display e >> return False) 34 | (bounce (fromIntegral height / 2) 0) 35 | 36 | -- * FRP stuff 37 | 38 | -- | Vertical coordinate and velocity of a falling mass starting 39 | -- at a height with an initial velocity. 40 | falling :: Double -> Double -> SF () (Double, Double) 41 | falling y0 v0 = proc () -> do 42 | vy <- (v0+) ^<< integral -< gravity 43 | py <- (y0+) ^<< integral -< vy 44 | returnA -< (py, vy) 45 | 46 | -- | Vertical coordinate and velocity of a bouncing mass starting 47 | -- at a height with an initial velicity. 48 | bounce :: Double -> Double -> SF () (Double, Double) 49 | bounce y vy = switch (falling y vy >>> (Yampa.identity &&& hitBottom)) 50 | (\(y, vy) -> bounce y (-vy)) 51 | 52 | -- | Fire an event when the input height and velocity indicate 53 | -- that the object has hit the bottom (so it's falling and the 54 | -- vertical position is under the floor). 55 | hitBottom :: SF (Double, Double) (Yampa.Event (Double, Double)) 56 | hitBottom = arr (\(y,vy) -> 57 | let boxTop = y + fromIntegral boxSide 58 | in if (boxTop > fromIntegral height) && (vy > 0) 59 | then Yampa.Event (y, vy) 60 | else Yampa.NoEvent) 61 | 62 | -- * Graphics 63 | 64 | -- | Initialise rendering system. 65 | initGraphs :: IO () 66 | initGraphs = do 67 | -- Initialise SDL 68 | SDL.init [InitVideo] 69 | 70 | -- Create window 71 | screen <- setVideoMode width height 16 [SWSurface] 72 | setCaption "Test" "" 73 | 74 | -- | Display a box at a position. 75 | display :: (Double, Double) -> IO() 76 | display (boxY,_) = do 77 | -- Obtain surface 78 | screen <- getVideoSurface 79 | 80 | -- Paint screen green 81 | let format = surfaceGetPixelFormat screen 82 | bgColor <- mapRGB format 55 60 64 83 | fillRect screen Nothing bgColor 84 | 85 | -- Paint small red square, at an angle 'angle' with respect to the center 86 | foreC <- mapRGB format 212 108 73 87 | let x = (width - boxSide) `div` 2 88 | y = round boxY 89 | fillRect screen (Just (Rect x y boxSide boxSide)) foreC 90 | 91 | -- Double buffering 92 | SDL.flip screen 93 | 94 | gravity :: Double 95 | gravity = 6.2 96 | 97 | boxSide :: Int 98 | boxSide = 30 99 | -------------------------------------------------------------------------------- /yampa/examples/yampa-game/MainCircleMouse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | import Data.IORef 3 | import FRP.Yampa as Yampa 4 | import Graphics.UI.SDL as SDL 5 | 6 | -- Helper functions 7 | import YampaSDL 8 | 9 | width :: Num a => a 10 | width = 640 11 | height :: Num a => a 12 | height = 480 13 | 14 | -- | Reactimation. 15 | -- 16 | -- This main function runs an FRP system by producing a signal, passing it 17 | -- through a signal function, and consuming it. 18 | -- 19 | -- The first two arguments to reactimate are the value of the input signal 20 | -- at time zero and at subsequent times, together with the times between 21 | -- samples. 22 | -- 23 | -- The third argument to reactimate is the output consumer that renders 24 | -- the signal. 25 | -- 26 | -- The last argument is the actual signal function. 27 | -- 28 | main = do 29 | timeRef <- newIORef (0 :: Int) 30 | controllerRef <- newIORef $ Controller (0,0) 31 | reactimate (initGraphs >> readIORef controllerRef) 32 | (\_ -> do 33 | dtSecs <- yampaSDLTimeSense timeRef 34 | mInput <- sdlGetController controllerRef 35 | -- print (mInput) 36 | return (dtSecs, Just mInput) 37 | ) 38 | (\_ e -> display (e) >> return False) 39 | player 40 | 41 | -- * FRP stuff 42 | 43 | -- | Player is going in circles around the input controller position 44 | player :: SF Controller (Double, Double) 45 | player = arr controllerPos >>> inCircles 46 | 47 | -- | Coordinate of a body going in circles around another body. 48 | inCircles :: SF (Double, Double) (Double, Double) 49 | inCircles = proc (centerX, centerY) -> do 50 | t <- time -< () 51 | let x = centerX + cos t * radius 52 | y = centerY + sin t * radius 53 | radius = 30 54 | returnA -< (x,y) 55 | 56 | -- * SDL stuff 57 | 58 | -- ** Input subsystem 59 | 60 | -- | Input controller 61 | data Controller = Controller 62 | { controllerPos :: (Double, Double) 63 | } 64 | 65 | -- | Give a controller, refresh its state and return the latest value. 66 | -- We need a non-blocking controller-polling function. 67 | sdlGetController :: IORef Controller -> IO Controller 68 | sdlGetController controllerState = do 69 | state <- readIORef controllerState 70 | e <- pollEvent 71 | case e of 72 | MouseMotion x y _ _ -> do writeIORef 73 | controllerState 74 | (Controller (fromIntegral x, fromIntegral y)) 75 | sdlGetController controllerState 76 | _ -> return state 77 | 78 | -- * Graphics 79 | 80 | -- | Initialise rendering system. 81 | initGraphs :: IO () 82 | initGraphs = do 83 | -- Initialise SDL 84 | SDL.init [InitVideo] 85 | 86 | -- Create window 87 | screen <- SDL.setVideoMode width height 16 [SWSurface] 88 | SDL.setCaption "Test" "" 89 | 90 | -- | Display a box at a position. 91 | display :: (Double, Double) -> IO() 92 | display (playerX, playerY) = do 93 | -- Obtain surface 94 | screen <- getVideoSurface 95 | 96 | -- Paint screen green 97 | let format = surfaceGetPixelFormat screen 98 | bgColor <- mapRGB format 55 60 64 99 | fillRect screen Nothing bgColor 100 | 101 | -- Paint small red square, at an angle 'angle' with respect to the center 102 | foreC <- mapRGB format 212 108 73 103 | let side = 10 104 | x = round playerX 105 | y = round playerY 106 | fillRect screen (Just (Rect x y side side)) foreC 107 | 108 | -- Double buffering 109 | SDL.flip screen 110 | -------------------------------------------------------------------------------- /yampa/examples/yampa-game/MainWiimote.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | import Control.Monad 3 | import Data.IORef 4 | import Data.Maybe 5 | import FRP.Yampa as Yampa 6 | import Graphics.UI.SDL as SDL 7 | import System.CWiid 8 | 9 | -- Helper functions 10 | import YampaSDL 11 | 12 | width :: Num a => a 13 | width = 640 14 | height :: Num a => a 15 | height = 480 16 | 17 | -- | Reactimation. 18 | -- 19 | -- This main function runs an FRP system by producing a signal, passing it 20 | -- through a signal function, and consuming it. 21 | -- 22 | -- The first two arguments to reactimate are the value of the input signal 23 | -- at time zero and at subsequent times, together with the times between 24 | -- samples. 25 | -- 26 | -- The third argument to reactimate is the output consumer that renders 27 | -- the signal. 28 | -- 29 | -- The last argument is the actual signal function. 30 | -- 31 | main = do 32 | mWiimote <- initializeWiimote 33 | timeRef <- newIORef (0 :: Int) 34 | if isNothing mWiimote 35 | then putStrLn "Couldn't find wiimote" 36 | else do let wiimote = fromJust mWiimote 37 | reactimate (initGraphs >> senseWiimote wiimote) 38 | (\_ -> do 39 | dtSecs <- yampaSDLTimeSense timeRef 40 | mInput <- senseWiimote wiimote 41 | return (dtSecs, Just mInput) 42 | ) 43 | (\_ e -> display (e) >> return False) 44 | player 45 | 46 | -- Pure SF 47 | inCircles :: SF (Double, Double) (Double, Double) 48 | inCircles = proc (centerX, centerY) -> do 49 | t <- time -< () 50 | let x = centerX + cos t * radius 51 | y = centerY + sin t * radius 52 | radius = 30 53 | returnA -< (x,y) 54 | 55 | -- * Graphics 56 | 57 | -- | Initialise rendering system. 58 | initGraphs :: IO () 59 | initGraphs = do 60 | -- Initialise SDL 61 | SDL.init [InitVideo] 62 | 63 | -- Create window 64 | screen <- SDL.setVideoMode width height 16 [SWSurface] 65 | SDL.setCaption "Test" "" 66 | 67 | -- | Display a box at a position. 68 | display :: (Double, Double) -> IO() 69 | display (playerX, playerY) = do 70 | -- Obtain surface 71 | screen <- getVideoSurface 72 | 73 | -- Paint screen green 74 | let format = surfaceGetPixelFormat screen 75 | bgColor <- mapRGB format 55 60 64 76 | fillRect screen Nothing bgColor 77 | 78 | -- Paint small red square, at an angle 'angle' with respect to the center 79 | foreC <- mapRGB format 212 108 73 80 | let side = 30 81 | x = round playerX 82 | y = round playerY 83 | fillRect screen (Just (Rect x y side side)) foreC 84 | 85 | -- Double buffering 86 | SDL.flip screen 87 | 88 | player :: SF (Double, Double) (Double, Double) 89 | player = inCircles 90 | 91 | senseWiimote :: CWiidWiimote -> IO (Double, Double) 92 | senseWiimote wmdev = do 93 | irs <- cwiidGetIR wmdev 94 | 95 | -- Obtain positions of leds 1 and 2 (with a normal wii bar, those 96 | -- will be the ones we use). 97 | let led1 = irs!!0 98 | led2 = irs!!1 99 | 100 | -- Calculate mid point between sensor bar leds 101 | let posX = ((cwiidIRSrcPosX led1) + (cwiidIRSrcPosX led2)) `div` 2 102 | posY = ((cwiidIRSrcPosY led1) + (cwiidIRSrcPosY led2)) `div` 2 103 | 104 | -- Calculate proportional coordinates 105 | let propX = fromIntegral (1024 - posX) / width 106 | propY = fromIntegral (max 0 (posY - 384)) / 384.0 107 | 108 | -- Calculate game area coordinates 109 | let finX = width * propX 110 | finY = height * propY 111 | 112 | return (finX, finY) 113 | 114 | -- | Initializes the wiimote, optionally returning the sensing function. It 115 | -- returns Nothing if the Wiimote cannot be detected. Users should have a BT 116 | -- device and press 1+2 to connect to it. A message is shown on stdout. 117 | initializeWiimote :: IO (Maybe CWiidWiimote) 118 | initializeWiimote = do 119 | putStrLn "Initializing WiiMote. Please press 1+2 to connect." 120 | wm <- cwiidOpen 121 | case wm of 122 | Nothing -> return () 123 | Just wm' -> void $ cwiidSetRptMode wm' 15 -- Enable button reception, acc 124 | -- and IR 125 | return wm 126 | -------------------------------------------------------------------------------- /yampa/examples/yampa-game/YampaSDL.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Copyright : (c) Ivan Perez, 2017-2022 3 | -- License : BSD-style (see the LICENSE file in the distribution) 4 | -- Maintainer : ivan.perez@keera.co.uk 5 | module YampaSDL where 6 | 7 | import Data.IORef 8 | import FRP.Yampa as Yampa 9 | import Graphics.UI.SDL as SDL 10 | 11 | type TimeRef = IORef Int 12 | 13 | yampaSDLTimeInit :: IO TimeRef 14 | yampaSDLTimeInit = do 15 | timeRef <- newIORef (0 :: Int) 16 | _ <- yampaSDLTimeSense timeRef 17 | _ <- yampaSDLTimeSense timeRef 18 | _ <- yampaSDLTimeSense timeRef 19 | _ <- yampaSDLTimeSense timeRef 20 | return timeRef 21 | 22 | -- | Updates the time in an IO Ref and returns the time difference 23 | updateTime :: IORef Int -> Int -> IO Int 24 | updateTime timeRef newTime = do 25 | previousTime <- readIORef timeRef 26 | writeIORef timeRef newTime 27 | return (newTime - previousTime) 28 | 29 | yampaSDLTimeSense :: IORef Int -> IO Yampa.DTime 30 | yampaSDLTimeSense timeRef = do 31 | -- Get time passed since SDL init 32 | newTime <- fmap fromIntegral SDL.getTicks 33 | 34 | -- Obtain time difference 35 | dt <- updateTime timeRef newTime 36 | let dtSecs = fromIntegral dt / 100 37 | return dtSecs 38 | -------------------------------------------------------------------------------- /yampa/src/FRP/Yampa/Arrow.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : FRP.Yampa.Arrow 3 | -- Copyright : (c) Ivan Perez, 2014-2022 4 | -- (c) George Giorgidze, 2007-2012 5 | -- (c) Henrik Nilsson, 2005-2006 6 | -- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 7 | -- License : BSD-style (see the LICENSE file in the distribution) 8 | -- 9 | -- Maintainer : ivan.perez@keera.co.uk 10 | -- Stability : provisional 11 | -- Portability : portable 12 | -- 13 | -- Arrow helper functions. 14 | module FRP.Yampa.Arrow 15 | ( 16 | -- * Arrow plumbing aids 17 | dup 18 | 19 | -- * Liftings 20 | , arr2 21 | , arr3 22 | , arr4 23 | , arr5 24 | ) 25 | where 26 | 27 | -- External imports 28 | import Control.Arrow (Arrow, arr) 29 | 30 | -- * Arrow plumbing aids 31 | 32 | -- | Duplicate an input. 33 | dup :: a -> (a, a) 34 | dup x = (x, x) 35 | 36 | -- * Liftings 37 | 38 | -- | Lift a binary function onto an arrow. 39 | arr2 :: Arrow a => (b -> c -> d) -> a (b, c) d 40 | arr2 = arr . uncurry 41 | 42 | {-# DEPRECATED arr3 "The function arr3 is deprecated in Yampa 0.15 and will be removed in future versions." #-} 43 | -- | Lift a 3-ary function onto an arrow. 44 | arr3 :: Arrow a => (b -> c -> d -> e) -> a (b, c, d) e 45 | arr3 = arr . \h (b, c, d) -> h b c d 46 | 47 | {-# DEPRECATED arr4 "The function arr4 is deprecated in Yampa 0.15 and will be removed in future versions." #-} 48 | -- | Lift a 4-ary function onto an arrow. 49 | arr4 :: Arrow a => (b -> c -> d -> e -> f) -> a (b, c, d, e) f 50 | arr4 = arr . \h (b, c, d, e) -> h b c d e 51 | 52 | {-# DEPRECATED arr5 "The function arr5 is deprecated in Yampa 0.15 and will be removed in future versions." #-} 53 | -- | Lift a 5-ary function onto an arrow. 54 | arr5 :: Arrow a => (b -> c -> d -> e -> f -> g) -> a (b, c, d, e, f) g 55 | arr5 = arr . \h (b, c, d, e, f) -> h b c d e f 56 | -------------------------------------------------------------------------------- /yampa/src/FRP/Yampa/Basic.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : FRP.Yampa.Basic 3 | -- Copyright : (c) Ivan Perez, 2014-2022 4 | -- (c) George Giorgidze, 2007-2012 5 | -- (c) Henrik Nilsson, 2005-2006 6 | -- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 7 | -- License : BSD-style (see the LICENSE file in the distribution) 8 | -- 9 | -- Maintainer : ivan.perez@keera.co.uk 10 | -- Stability : provisional 11 | -- Portability : non-portable (GHC extensions) 12 | -- 13 | -- Defines basic signal functions, and elementary ways of altering them. 14 | -- 15 | -- This module defines very basic ways of creating and modifying signal 16 | -- functions. In particular, it defines ways of creating constant output 17 | -- producing SFs, and SFs that just pass the signal through unmodified. 18 | -- 19 | -- It also defines ways of altering the input and the output signal only by 20 | -- inserting one value in the signal, or by transforming it. 21 | module FRP.Yampa.Basic 22 | ( 23 | -- * Basic signal functions 24 | identity 25 | , constant 26 | 27 | -- ** Initialization 28 | , (-->) 29 | , (-:>) 30 | , (>--) 31 | , (-=>) 32 | , (>=-) 33 | , initially 34 | ) 35 | where 36 | 37 | -- Internal imports 38 | import FRP.Yampa.InternalCore (SF(..), SF'(..), sfConst, sfId) 39 | 40 | infixr 0 -->, -:>, >--, -=>, >=- 41 | 42 | -- * Basic signal functions 43 | 44 | -- | Identity: identity = arr id 45 | -- 46 | -- Using 'identity' is preferred over lifting id, since the arrow combinators 47 | -- know how to optimise certain networks based on the transformations being 48 | -- applied. 49 | identity :: SF a a 50 | identity = SF {sfTF = \a -> (sfId, a)} 51 | 52 | {-# ANN constant "HLint: ignore Use const" #-} 53 | -- | Identity: constant b = arr (const b) 54 | -- 55 | -- Using 'constant' is preferred over lifting const, since the arrow combinators 56 | -- know how to optimise certain networks based on the transformations being 57 | -- applied. 58 | constant :: b -> SF a b 59 | constant b = SF {sfTF = \_ -> (sfConst b, b)} 60 | 61 | -- * Initialization 62 | 63 | -- | Initialization operator (cf. Lustre/Lucid Synchrone). 64 | -- 65 | -- The output at time zero is the first argument, and from that point on it 66 | -- behaves like the signal function passed as second argument. 67 | (-->) :: b -> SF a b -> SF a b 68 | b0 --> (SF {sfTF = tf10}) = SF {sfTF = \a0 -> (fst (tf10 a0), b0)} 69 | 70 | -- | Output pre-insert operator. 71 | -- 72 | -- Insert a sample in the output, and from that point on, behave like the given 73 | -- sf. 74 | (-:>) :: b -> SF a b -> SF a b 75 | b0 -:> (SF {sfTF = tf10}) = SF {sfTF = \_a0 -> (ct, b0)} 76 | where 77 | ct = SF' $ \_dt a0 -> tf10 a0 78 | 79 | -- | Input initialization operator. 80 | -- 81 | -- The input at time zero is the first argument, and from that point on it 82 | -- behaves like the signal function passed as second argument. 83 | (>--) :: a -> SF a b -> SF a b 84 | a0 >-- (SF {sfTF = tf10}) = SF {sfTF = \_ -> tf10 a0} 85 | 86 | -- | Transform initial output value. 87 | -- 88 | -- Applies a transformation 'f' only to the first output value at time zero. 89 | (-=>) :: (b -> b) -> SF a b -> SF a b 90 | f -=> (SF {sfTF = tf10}) = 91 | SF {sfTF = \a0 -> let (sf1, b0) = tf10 a0 in (sf1, f b0)} 92 | 93 | -- | Transform initial input value. 94 | -- 95 | -- Applies a transformation 'f' only to the first input value at time zero. 96 | {-# ANN (>=-) "HLint: ignore Avoid lambda" #-} 97 | (>=-) :: (a -> a) -> SF a b -> SF a b 98 | f >=- (SF {sfTF = tf10}) = SF {sfTF = \a0 -> tf10 (f a0)} 99 | 100 | -- | Override initial value of input signal. 101 | initially :: a -> SF a a 102 | initially = (--> identity) 103 | -------------------------------------------------------------------------------- /yampa/src/FRP/Yampa/Conditional.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : FRP.Yampa 3 | -- Copyright : (c) Ivan Perez, 2014-2022 4 | -- (c) George Giorgidze, 2007-2012 5 | -- (c) Henrik Nilsson, 2005-2006 6 | -- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 7 | -- License : BSD-style (see the LICENSE file in the distribution) 8 | -- 9 | -- Maintainer : ivan.perez@keera.co.uk 10 | -- Stability : provisional 11 | -- Portability : non-portable (GHC extensions) 12 | -- 13 | -- Apply SFs only under certain conditions. 14 | module FRP.Yampa.Conditional 15 | ( 16 | -- * Guards and automata-oriented combinators 17 | provided 18 | 19 | -- * Variable pause 20 | , pause 21 | ) 22 | where 23 | 24 | -- External imports 25 | import Control.Arrow ((&&&), (^>>)) 26 | 27 | -- Internal imports 28 | import FRP.Yampa.Basic (constant) 29 | import FRP.Yampa.EventS (edge, snap) 30 | import FRP.Yampa.InternalCore (SF (..), SF' (..), Transition, sfTF') 31 | import FRP.Yampa.Switches (switch) 32 | 33 | -- * Guards and automata-oriented combinators 34 | 35 | -- | Runs a signal function only when a given predicate is satisfied, otherwise 36 | -- runs the other signal function. 37 | -- 38 | -- This is similar to 'ArrowChoice', except that this resets the SFs after each 39 | -- transition. 40 | -- 41 | -- For example, the following integrates the incoming input numbers, using one 42 | -- integral if the numbers are even, and another if the input numbers are odd. 43 | -- Note how, every time we "switch", the old value of the integral is discarded. 44 | -- 45 | -- >>> embed (provided (even . round) integral integral) (deltaEncode 1 [1, 1, 1, 2, 2, 2, 1, 1, 1, 2, 2, 2 :: Double]) 46 | -- [0.0,1.0,2.0,0.0,2.0,4.0,0.0,1.0,2.0,0.0,2.0,4.0] 47 | provided :: (a -> Bool) -> SF a b -> SF a b -> SF a b 48 | provided p sft sff = 49 | switch (constant undefined &&& snap) $ \a0 -> 50 | if p a0 then stt else stf 51 | where 52 | stt = switch (sft &&& (not . p ^>> edge)) (const stf) 53 | stf = switch (sff &&& (p ^>> edge)) (const stt) 54 | 55 | -- * Variable pause 56 | 57 | -- | Given a value in an accumulator (b), a predicate signal function (sfC), and 58 | -- a second signal function (sf), pause will produce the accumulator b if sfC 59 | -- input is True, and will transform the signal using sf otherwise. It acts as 60 | -- a pause with an accumulator for the moments when the transformation is 61 | -- paused. 62 | pause :: b -> SF a Bool -> SF a b -> SF a b 63 | pause bInit (SF { sfTF = tfP}) (SF {sfTF = tf10}) = SF {sfTF = tf0} 64 | where 65 | -- Initial transformation (no time delta): If the condition is True, return 66 | -- the accumulator bInit) Otherwise transform the input normally and 67 | -- recurse. 68 | tf0 a0 = case tfP a0 of 69 | (c, True) -> (pauseInit bInit tf10 c, bInit) 70 | (c, False) -> (pause' b0 k c, b0) 71 | where 72 | (k, b0) = tf10 a0 73 | 74 | -- Similar deal, but with a time delta 75 | pauseInit :: b -> (a -> Transition a b) -> SF' a Bool -> SF' a b 76 | pauseInit bInit' tf10' c = SF' tf0' 77 | where 78 | tf0' dt a = case (sfTF' c) dt a of 79 | (c', True) -> (pauseInit bInit' tf10' c', bInit') 80 | (c', False) -> (pause' b0 k c', b0) 81 | where 82 | (k, b0) = tf10' a 83 | 84 | -- Very same deal (almost alpha-renameable) 85 | pause' :: b -> SF' a b -> SF' a Bool -> SF' a b 86 | pause' bInit' tf10' tfP' = SF' tf0' 87 | where 88 | tf0' dt a = case (sfTF' tfP') dt a of 89 | (tfP'', True) -> (pause' bInit' tf10' tfP'', bInit') 90 | (tfP'', False) -> (pause' b0' tf10'' tfP'', b0') 91 | where 92 | (tf10'', b0') = (sfTF' tf10') dt a 93 | -------------------------------------------------------------------------------- /yampa/src/FRP/Yampa/Delays.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : FRP.Yampa.Delays 3 | -- Copyright : (c) Ivan Perez, 2014-2022 4 | -- (c) George Giorgidze, 2007-2012 5 | -- (c) Henrik Nilsson, 2005-2006 6 | -- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 7 | -- License : BSD-style (see the LICENSE file in the distribution) 8 | -- 9 | -- Maintainer : ivan.perez@keera.co.uk 10 | -- Stability : provisional 11 | -- Portability : non-portable (GHC extensions) 12 | -- 13 | -- SF primitives and combinators to delay signals, introducing new values in 14 | -- them. 15 | module FRP.Yampa.Delays 16 | ( 17 | -- * Basic delays 18 | pre 19 | , iPre 20 | , fby 21 | 22 | -- * Timed delays 23 | , delay 24 | ) 25 | where 26 | 27 | -- External imports 28 | import Control.Arrow ((>>>)) 29 | 30 | -- Internal imports 31 | import FRP.Yampa.Basic (identity, (-->)) 32 | import FRP.Yampa.Diagnostics (usrErr) 33 | import FRP.Yampa.InternalCore (SF (..), SF' (..), Time) 34 | import FRP.Yampa.Scan (sscanPrim) 35 | 36 | infixr 0 `fby` 37 | 38 | -- * Delays 39 | 40 | -- | Uninitialized delay operator. 41 | -- 42 | -- The output has an infinitesimal delay (1 sample), and the value at time zero 43 | -- is undefined. 44 | pre :: SF a a 45 | pre = sscanPrim f uninit uninit 46 | where 47 | f c a = Just (a, c) 48 | uninit = usrErr "Yampa" "pre" "Uninitialized pre operator." 49 | 50 | -- | Initialized delay operator. 51 | -- 52 | -- Creates an SF that delays the input signal, introducing an infinitesimal 53 | -- delay (one sample), using the given argument to fill in the initial output at 54 | -- time zero. 55 | iPre :: a -> SF a a 56 | iPre = (--> pre) 57 | 58 | -- | Lucid-Synchrone-like initialized delay (read "followed by"). 59 | -- 60 | -- Initialized delay combinator, introducing an infinitesimal delay (one sample) 61 | -- in given 'SF', using the given argument to fill in the initial output at time 62 | -- zero. 63 | -- 64 | -- The difference with 'iPre' is that 'fby' takes an 'SF' as argument. 65 | fby :: b -> SF a b -> SF a b 66 | b0 `fby` sf = b0 --> sf >>> pre 67 | 68 | -- * Timed delays 69 | 70 | -- | Delay a signal by a fixed time 't', using the second parameter to fill in 71 | -- the initial 't' seconds. 72 | delay :: Time -> a -> SF a a 73 | delay q aInit | q < 0 = usrErr "Yampa" "delay" "Negative delay." 74 | | q == 0 = identity 75 | | otherwise = SF {sfTF = tf0} 76 | where 77 | tf0 a0 = (delayAux [] [(q, a0)] 0 aInit, aInit) 78 | 79 | -- Invariants: 80 | -- tDiff measure the time since the latest output sample ideally should have 81 | -- been output. Whenever that equals or exceeds the time delta for the next 82 | -- buffered sample, it is time to output a new sample (although not 83 | -- necessarily the one first in the queue: it might be necessary to "catch 84 | -- up" by discarding samples. 0 <= tDiff < bdt, where bdt is the buffered 85 | -- time delta for the sample on the front of the buffer queue. 86 | -- 87 | -- Sum of time deltas in the queue >= q. 88 | delayAux _ [] _ _ = undefined 89 | delayAux rbuf buf@((bdt, ba) : buf') tDiff aPrev = SF' tf -- True 90 | where 91 | tf dt a | tDiff' < bdt = (delayAux rbuf' buf tDiff' aPrev, aPrev) 92 | | otherwise = nextSmpl rbuf' buf' (tDiff' - bdt) ba 93 | where 94 | tDiff' = tDiff + dt 95 | rbuf' = (dt, a) : rbuf 96 | 97 | nextSmpl rbuf [] tDiff a = 98 | nextSmpl [] (reverse rbuf) tDiff a 99 | nextSmpl rbuf buf@((bdt, ba) : buf') tDiff a 100 | | tDiff < bdt = (delayAux rbuf buf tDiff a, a) 101 | | otherwise = nextSmpl rbuf buf' (tDiff - bdt) ba 102 | -------------------------------------------------------------------------------- /yampa/src/FRP/Yampa/Diagnostics.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : FRP.Yampa.Diagnostics 3 | -- Copyright : (c) Ivan Perez, 2014-2022 4 | -- (c) George Giorgidze, 2007-2012 5 | -- (c) Henrik Nilsson, 2005-2006 6 | -- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 7 | -- License : BSD-style (see the LICENSE file in the distribution) 8 | -- 9 | -- Maintainer : ivan.perez@keera.co.uk 10 | -- Stability : provisional 11 | -- Portability : portable 12 | -- 13 | -- Standardized error-reporting for Yampa. 14 | module FRP.Yampa.Diagnostics 15 | ( usrErr 16 | , intErr 17 | ) 18 | where 19 | 20 | -- | Reports an error due to a violation of Yampa's preconditions/requirements. 21 | usrErr :: String -> String -> String -> a 22 | usrErr mn fn msg = error (mn ++ "." ++ fn ++ ": " ++ msg) 23 | 24 | -- | Reports an error in Yampa's implementation. 25 | intErr :: String -> String -> String -> a 26 | intErr mn fn msg = error ("[internal error] " ++ mn ++ "." ++ fn ++ ": " 27 | ++ msg) 28 | -------------------------------------------------------------------------------- /yampa/src/FRP/Yampa/Event.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} 3 | -- | 4 | -- Module : FRP.Yampa.Event 5 | -- Copyright : (c) Ivan Perez, 2014-2022 6 | -- (c) George Giorgidze, 2007-2012 7 | -- (c) Henrik Nilsson, 2005-2006 8 | -- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 9 | -- License : BSD-style (see the LICENSE file in the distribution) 10 | -- 11 | -- Maintainer : ivan.perez@keera.co.uk 12 | -- Stability : provisional 13 | -- Portability : portable 14 | -- 15 | -- Events in Yampa represent discrete time-signals, meaning those that do not 16 | -- change continuously. Examples of event-carrying signals would be mouse clicks 17 | -- (in between clicks it is assumed that there is no click), some keyboard 18 | -- events, button presses on wiimotes or window-manager events. 19 | -- 20 | -- The type 'Event' is isomorphic to 'Maybe' (@Event a = NoEvent | Event a@) 21 | -- but, semantically, a 'Maybe'-carrying signal could change continuously, 22 | -- whereas an 'Event'-carrying signal should not: for two events in subsequent 23 | -- samples, there should be an small enough sampling frequency such that we 24 | -- sample between those two samples and there are no 'Event's between them. 25 | -- Nevertheless, no mechanism in Yampa will check this or misbehave if this 26 | -- assumption is violated. 27 | -- 28 | -- Events are essential for many other Yampa constructs, like switches (see 29 | -- 'FRP.Yampa.Switches.switch' for details). 30 | module FRP.Yampa.Event 31 | ( 32 | -- * The Event type 33 | Event(..) 34 | , noEvent 35 | , noEventFst 36 | , noEventSnd 37 | 38 | -- * Utility functions similar to those available for Maybe 39 | , event 40 | , fromEvent 41 | , isEvent 42 | , isNoEvent 43 | 44 | -- * Event tagging 45 | , tag 46 | , tagWith 47 | , attach 48 | 49 | -- * Event merging (disjunction) and joining (conjunction) 50 | , lMerge 51 | , rMerge 52 | , merge 53 | , mergeBy 54 | , mapMerge 55 | , mergeEvents 56 | , catEvents 57 | , joinE 58 | , splitE 59 | 60 | -- * Event filtering 61 | , filterE 62 | , mapFilterE 63 | , gate 64 | 65 | -- * Utilities for easy event construction 66 | , maybeToEvent 67 | 68 | ) 69 | where 70 | 71 | -- External imports 72 | #if !MIN_VERSION_base(4,8,0) 73 | import Control.Applicative (Applicative (..), (<$>)) 74 | #endif 75 | import Control.Applicative (Alternative (..)) 76 | import Control.DeepSeq (NFData (..)) 77 | import qualified Control.Monad.Fail as Fail 78 | 79 | -- Internal imports 80 | import FRP.Yampa.Diagnostics (usrErr) 81 | 82 | infixl 8 `tag`, `attach`, `gate` 83 | infixl 7 `joinE` 84 | infixl 6 `lMerge`, `rMerge`, `merge` 85 | 86 | -- * The Event type 87 | 88 | -- | A single possible event occurrence, that is, a value that may or may not 89 | -- occur. Events are used to represent values that are not produced 90 | -- continuously, such as mouse clicks (only produced when the mouse is clicked, 91 | -- as opposed to mouse positions, which are always defined). 92 | data Event a = NoEvent | Event a deriving (Show) 93 | 94 | -- | Make the NoEvent constructor available. Useful e.g. for initialization, 95 | -- ((-->) & friends), and it's easily available anyway (e.g. mergeEvents []). 96 | noEvent :: Event a 97 | noEvent = NoEvent 98 | 99 | -- | Suppress any event in the first component of a pair. 100 | noEventFst :: (Event a, b) -> (Event c, b) 101 | noEventFst (_, b) = (NoEvent, b) 102 | 103 | -- | Suppress any event in the second component of a pair. 104 | noEventSnd :: (a, Event b) -> (a, Event c) 105 | noEventSnd (a, _) = (a, NoEvent) 106 | 107 | -- | Eq instance (equivalent to derived instance). 108 | instance Eq a => Eq (Event a) where 109 | -- | Equal if both NoEvent or both Event carrying equal values. 110 | NoEvent == NoEvent = True 111 | (Event x) == (Event y) = x == y 112 | _ == _ = False 113 | 114 | -- | Ord instance (equivalent to derived instance). 115 | instance Ord a => Ord (Event a) where 116 | -- | NoEvent is smaller than Event, Event x < Event y if x < y. 117 | compare NoEvent NoEvent = EQ 118 | compare NoEvent (Event _) = LT 119 | compare (Event _) NoEvent = GT 120 | compare (Event x) (Event y) = compare x y 121 | 122 | -- | Functor instance (could be derived). 123 | instance Functor Event where 124 | -- | Apply function to value carried by 'Event', if any. 125 | fmap _ NoEvent = NoEvent 126 | fmap f (Event a) = Event (f a) 127 | 128 | -- | Applicative instance (similar to 'Maybe'). 129 | instance Applicative Event where 130 | -- | Wrap a pure value in an 'Event'. 131 | pure = Event 132 | -- | If any value (function or arg) is 'NoEvent', everything is. 133 | NoEvent <*> _ = NoEvent 134 | Event f <*> x = f <$> x 135 | 136 | -- | Monad instance. 137 | instance Monad Event where 138 | -- | Combine events, return 'NoEvent' if any value in the sequence is 139 | -- 'NoEvent'. 140 | (Event x) >>= k = k x 141 | NoEvent >>= _ = NoEvent 142 | 143 | (>>) = (*>) 144 | 145 | -- | See 'pure'. 146 | return = pure 147 | 148 | #if !(MIN_VERSION_base(4,13,0)) 149 | -- | Fail with 'NoEvent'. 150 | fail = Fail.fail 151 | #endif 152 | 153 | instance Fail.MonadFail Event where 154 | -- | Fail with 'NoEvent'. 155 | fail _ = NoEvent 156 | 157 | -- | Alternative instance. 158 | instance Alternative Event where 159 | -- | An empty alternative carries no event, so it is ignored. 160 | empty = NoEvent 161 | -- | Merge favouring the left event ('NoEvent' only if both are 'NoEvent'). 162 | NoEvent <|> r = r 163 | l <|> _ = l 164 | 165 | -- | NFData instance. 166 | instance NFData a => NFData (Event a) where 167 | -- | Evaluate value carried by event. 168 | rnf NoEvent = () 169 | rnf (Event a) = rnf a `seq` () 170 | 171 | -- * Utility functions similar to those available for Maybe 172 | 173 | -- | An event-based version of the maybe function. 174 | event :: a -> (b -> a) -> Event b -> a 175 | event a _ NoEvent = a 176 | event _ f (Event b) = f b 177 | 178 | -- | Extract the value from an event. Fails if there is no event. 179 | fromEvent :: Event a -> a 180 | fromEvent (Event a) = a 181 | fromEvent NoEvent = usrErr "Yampa" "fromEvent" "Not an event." 182 | 183 | -- | Tests whether the input represents an actual event. 184 | isEvent :: Event a -> Bool 185 | isEvent NoEvent = False 186 | isEvent (Event _) = True 187 | 188 | -- | Negation of 'isEvent'. 189 | isNoEvent :: Event a -> Bool 190 | isNoEvent = not . isEvent 191 | 192 | -- * Event tagging 193 | 194 | -- | Tags an (occurring) event with a value ("replacing" the old value). 195 | -- 196 | -- Applicative-based definition: tag = ($>) 197 | tag :: Event a -> b -> Event b 198 | e `tag` b = fmap (const b) e 199 | 200 | -- | Tags an (occurring) event with a value ("replacing" the old value). Same as 201 | -- 'tag' with the arguments swapped. 202 | -- 203 | -- Applicative-based definition: tagWith = (<$) 204 | tagWith :: b -> Event a -> Event b 205 | tagWith = flip tag 206 | 207 | -- | Attaches an extra value to the value of an occurring event. 208 | attach :: Event a -> b -> Event (a, b) 209 | e `attach` b = fmap (\a -> (a, b)) e 210 | 211 | -- * Event merging (disjunction) and joining (conjunction) 212 | 213 | -- | Left-biased event merge (always prefer left event, if present). 214 | lMerge :: Event a -> Event a -> Event a 215 | lMerge = (<|>) 216 | 217 | -- | Right-biased event merge (always prefer right event, if present). 218 | rMerge :: Event a -> Event a -> Event a 219 | rMerge = flip (<|>) 220 | 221 | -- | Unbiased event merge: simultaneous occurrence is an error. 222 | merge :: Event a -> Event a -> Event a 223 | merge = mergeBy (usrErr "Yampa" "merge" "Simultaneous event occurrence.") 224 | 225 | -- | Event merge parameterized by a conflict resolution function. 226 | -- 227 | -- Applicative-based definition: 228 | -- mergeBy f le re = (f <$> le <*> re) <|> le <|> re 229 | mergeBy :: (a -> a -> a) -> Event a -> Event a -> Event a 230 | mergeBy _ NoEvent NoEvent = NoEvent 231 | mergeBy _ le@(Event _) NoEvent = le 232 | mergeBy _ NoEvent re@(Event _) = re 233 | mergeBy resolve (Event l) (Event r) = Event (resolve l r) 234 | 235 | -- | A generic event merge-map utility that maps event occurrences, merging the 236 | -- results. The first three arguments are mapping functions, the third of which 237 | -- will only be used when both events are present. Therefore, 'mergeBy' = 238 | -- 'mapMerge' 'id' 'id'. 239 | -- 240 | -- Applicative-based definition: 241 | -- mapMerge lf rf lrf le re = (f <$> le <*> re) <|> (lf <$> le) <|> (rf <$> re) 242 | mapMerge :: (a -> c) -> (b -> c) -> (a -> b -> c) 243 | -> Event a -> Event b -> Event c 244 | mapMerge _ _ _ NoEvent NoEvent = NoEvent 245 | mapMerge lf _ _ (Event l) NoEvent = Event (lf l) 246 | mapMerge _ rf _ NoEvent (Event r) = Event (rf r) 247 | mapMerge _ _ lrf (Event l) (Event r) = Event (lrf l r) 248 | 249 | -- | Merge a list of events; foremost event has priority. 250 | -- 251 | -- Foldable-based definition: 252 | -- mergeEvents :: Foldable t => t (Event a) -> Event a 253 | -- mergeEvents = asum 254 | mergeEvents :: [Event a] -> Event a 255 | mergeEvents = foldr lMerge NoEvent 256 | 257 | -- | Collect simultaneous event occurrences; no event if none. 258 | -- 259 | -- Traverable-based definition: 260 | -- catEvents :: Foldable t => t (Event a) -> Event (t a) 261 | -- catEvents e = if (null e) then NoEvent else (sequenceA e) 262 | catEvents :: [Event a] -> Event [a] 263 | catEvents eas = case [ a | Event a <- eas ] of 264 | [] -> NoEvent 265 | as -> Event as 266 | 267 | -- | Join (conjunction) of two events. Only produces an event if both events 268 | -- exist. 269 | -- 270 | -- Applicative-based definition: 271 | -- joinE = liftA2 (,) 272 | joinE :: Event a -> Event b -> Event (a, b) 273 | joinE (Event l) (Event r) = Event (l, r) 274 | joinE _ _ = NoEvent 275 | 276 | -- | Split event carrying pairs into two events. 277 | splitE :: Event (a, b) -> (Event a, Event b) 278 | splitE NoEvent = (NoEvent, NoEvent) 279 | splitE (Event (a, b)) = (Event a, Event b) 280 | 281 | -- * Event filtering 282 | 283 | -- | Filter out events that don't satisfy some predicate. 284 | filterE :: (a -> Bool) -> Event a -> Event a 285 | filterE p e@(Event a) = if p a then e else NoEvent 286 | filterE _ NoEvent = NoEvent 287 | 288 | -- | Combined event mapping and filtering. Note: since 'Event' is a 'Functor', 289 | -- see 'fmap' for a simpler version of this function with no filtering. 290 | mapFilterE :: (a -> Maybe b) -> Event a -> Event b 291 | mapFilterE f e = e >>= (maybeToEvent . f) 292 | 293 | -- | Enable/disable event occurrences based on an external condition. 294 | gate :: Event a -> Bool -> Event a 295 | _ `gate` False = NoEvent 296 | e `gate` True = e 297 | 298 | -- * Utilities for easy event construction 299 | 300 | -- | Convert a maybe value into a event ('Event' is isomorphic to 'Maybe'). 301 | maybeToEvent :: Maybe a -> Event a 302 | maybeToEvent Nothing = NoEvent 303 | maybeToEvent (Just a) = Event a 304 | -------------------------------------------------------------------------------- /yampa/src/FRP/Yampa/Hybrid.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : FRP.Yampa.Hybrid 3 | -- Copyright : (c) Ivan Perez, 2014-2022 4 | -- (c) George Giorgidze, 2007-2012 5 | -- (c) Henrik Nilsson, 2005-2006 6 | -- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 7 | -- License : BSD-style (see the LICENSE file in the distribution) 8 | -- 9 | -- Maintainer : ivan.perez@keera.co.uk 10 | -- Stability : provisional 11 | -- Portability : non-portable (GHC extensions) 12 | -- 13 | -- Discrete to continuous-time signal functions. 14 | module FRP.Yampa.Hybrid 15 | ( 16 | -- * Wave-form generation 17 | hold 18 | , dHold 19 | , trackAndHold 20 | , dTrackAndHold 21 | 22 | -- * Accumulators 23 | , accum 24 | , accumHold 25 | , dAccumHold 26 | , accumBy 27 | , accumHoldBy 28 | , dAccumHoldBy 29 | , accumFilter 30 | ) 31 | where 32 | 33 | -- External imports 34 | import Control.Arrow (arr, (>>>)) 35 | 36 | -- Internal imports 37 | import FRP.Yampa.Delays (iPre) 38 | import FRP.Yampa.Event (Event (..)) 39 | import FRP.Yampa.InternalCore (SF, epPrim) 40 | 41 | -- * Wave-form generation 42 | 43 | -- | Zero-order hold. 44 | -- 45 | -- Converts a discrete-time signal into a continuous-time signal, by holding the 46 | -- last value until it changes in the input signal. The given parameter may be 47 | -- used for time zero, and until the first event occurs in the input signal, so 48 | -- hold is always well-initialized. 49 | -- 50 | -- >>> embed (hold 1) (deltaEncode 0.1 [NoEvent, NoEvent, Event 2, NoEvent, Event 3, NoEvent]) 51 | -- [1,1,2,2,3,3] 52 | hold :: a -> SF (Event a) a 53 | hold aInit = epPrim f () aInit 54 | where 55 | f _ a = ((), a, a) 56 | 57 | -- | Zero-order hold with a delay. 58 | -- 59 | -- Converts a discrete-time signal into a continuous-time signal, by holding the 60 | -- last value until it changes in the input signal. The given parameter is used 61 | -- for time zero (until the first event occurs in the input signal), so 'dHold' 62 | -- shifts the discrete input by an infinitesimal delay. 63 | -- 64 | -- >>> embed (dHold 1) (deltaEncode 0.1 [NoEvent, NoEvent, Event 2, NoEvent, Event 3, NoEvent]) 65 | -- [1,1,1,2,2,3] 66 | dHold :: a -> SF (Event a) a 67 | dHold a0 = hold a0 >>> iPre a0 68 | 69 | -- | Tracks input signal when available, holding the last value when the input 70 | -- is 'Nothing'. 71 | -- 72 | -- This behaves similarly to 'hold', but there is a conceptual difference, as it 73 | -- takes a signal of input @Maybe a@ (for some @a@) and not @Event@. 74 | -- 75 | -- >>> embed (trackAndHold 1) (deltaEncode 0.1 [Nothing, Nothing, Just 2, Nothing, Just 3, Nothing]) 76 | -- [1,1,2,2,3,3] 77 | trackAndHold :: a -> SF (Maybe a) a 78 | trackAndHold aInit = arr (maybe NoEvent Event) >>> hold aInit 79 | 80 | -- | Tracks input signal when available, holding the last value when the input 81 | -- is 'Nothing', with a delay. 82 | -- 83 | -- This behaves similarly to 'hold', but there is a conceptual difference, as it 84 | -- takes a signal of input @Maybe a@ (for some @a@) and not @Event@. 85 | -- 86 | -- >>> embed (dTrackAndHold 1) (deltaEncode 0.1 [Nothing, Nothing, Just 2, Nothing, Just 3, Nothing]) 87 | -- [1,1,1,2,2,3] 88 | dTrackAndHold :: a -> SF (Maybe a) a 89 | dTrackAndHold aInit = trackAndHold aInit >>> iPre aInit 90 | 91 | -- * Accumulators 92 | 93 | -- | Given an initial value in an accumulator, it returns a signal function that 94 | -- processes an event carrying transformation functions. Every time an 'Event' 95 | -- is received, the function inside it is applied to the accumulator, whose new 96 | -- value is outputted in an 'Event'. 97 | accum :: a -> SF (Event (a -> a)) (Event a) 98 | accum aInit = epPrim f aInit NoEvent 99 | where 100 | f a g = (a', Event a', NoEvent) -- Accumulator, output if Event, output if 101 | -- no event 102 | where 103 | a' = g a 104 | 105 | -- | Zero-order hold accumulator (always produces the last outputted value until 106 | -- an event arrives). 107 | accumHold :: a -> SF (Event (a -> a)) a 108 | accumHold aInit = epPrim f aInit aInit 109 | where 110 | f a g = (a', a', a') -- Accumulator, output if Event, output if no event 111 | where 112 | a' = g a 113 | 114 | -- | Zero-order hold accumulator with delayed initialization (always produces 115 | -- the last outputted value until an event arrives, but the very initial output 116 | -- is always the given accumulator). 117 | dAccumHold :: a -> SF (Event (a -> a)) a 118 | dAccumHold aInit = accumHold aInit >>> iPre aInit 119 | 120 | -- | Accumulator parameterized by the accumulation function. 121 | accumBy :: (b -> a -> b) -> b -> SF (Event a) (Event b) 122 | accumBy g bInit = epPrim f bInit NoEvent 123 | where 124 | f b a = (b', Event b', NoEvent) 125 | where 126 | b' = g b a 127 | 128 | -- | Zero-order hold accumulator parameterized by the accumulation function. 129 | accumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b 130 | accumHoldBy g bInit = epPrim f bInit bInit 131 | where 132 | f b a = (b', b', b') 133 | where 134 | b' = g b a 135 | 136 | -- | Zero-order hold accumulator parameterized by the accumulation function with 137 | -- delayed initialization (initial output sample is always the given 138 | -- accumulator). 139 | dAccumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b 140 | dAccumHoldBy f aInit = accumHoldBy f aInit >>> iPre aInit 141 | 142 | -- | Accumulator parameterized by the accumulator function with filtering, 143 | -- possibly discarding some of the input events based on whether the second 144 | -- component of the result of applying the accumulation function is 'Nothing' or 145 | -- 'Just' x for some x. 146 | accumFilter :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b) 147 | accumFilter g cInit = epPrim f cInit NoEvent 148 | where 149 | f c a = case g c a of 150 | (c', Nothing) -> (c', NoEvent, NoEvent) 151 | (c', Just b) -> (c', Event b, NoEvent) 152 | -------------------------------------------------------------------------------- /yampa/src/FRP/Yampa/Integration.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : FRP.Yampa.Integration 3 | -- Copyright : (c) Ivan Perez, 2014-2022 4 | -- (c) George Giorgidze, 2007-2012 5 | -- (c) Henrik Nilsson, 2005-2006 6 | -- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 7 | -- License : BSD-style (see the LICENSE file in the distribution) 8 | -- 9 | -- Maintainer : ivan.perez@keera.co.uk 10 | -- Stability : provisional 11 | -- Portability : non-portable (GHC extensions) 12 | -- 13 | -- Integration and derivation of input signals. 14 | -- 15 | -- In continuous time, these primitives define SFs that integrate/derive the 16 | -- input signal. Since this is subject to the sampling resolution, simple 17 | -- versions are implemented (like the rectangle rule for the integral). 18 | -- 19 | -- In discrete time, all we do is count the number of events. 20 | -- 21 | -- The combinator 'iterFrom' gives enough flexibility to program your own 22 | -- leak-free integration and derivation SFs. 23 | -- 24 | -- Many primitives and combinators in this module require instances of 25 | -- simple-affine-spaces's 'VectorSpace'. Yampa does not enforce the use of a 26 | -- particular vector space implementation, meaning you could use 'integral' for 27 | -- example with other vector types like V2, V1, etc. from the library linear. 28 | -- For an example, see 29 | -- . 30 | module FRP.Yampa.Integration 31 | ( 32 | -- * Integration 33 | integral 34 | , imIntegral 35 | , trapezoidIntegral 36 | , impulseIntegral 37 | , count 38 | 39 | -- * Differentiation 40 | , derivative 41 | , iterFrom 42 | ) 43 | where 44 | 45 | -- External imports 46 | import Control.Arrow ((***), (>>^)) 47 | import Data.VectorSpace (VectorSpace, zeroVector, (*^), (^+^), (^-^), (^/)) 48 | 49 | -- Internal imports 50 | import FRP.Yampa.Event (Event) 51 | import FRP.Yampa.Hybrid (accumBy, accumHoldBy) 52 | import FRP.Yampa.InternalCore (DTime, SF (..), SF' (..)) 53 | 54 | -- * Integration 55 | 56 | -- | Integration using the rectangle rule. 57 | {-# INLINE integral #-} 58 | integral :: (Fractional s, VectorSpace a s) => SF a a 59 | integral = SF {sfTF = tf0} 60 | where 61 | tf0 a0 = (integralAux igrl0 a0, igrl0) 62 | 63 | igrl0 = zeroVector 64 | 65 | integralAux igrl aPrev = SF' tf -- True 66 | where 67 | tf dt a = (integralAux igrl' a, igrl') 68 | where 69 | igrl' = igrl ^+^ realToFrac dt *^ aPrev 70 | 71 | -- | \"Immediate\" integration (using the function's value at the current time). 72 | imIntegral :: (Fractional s, VectorSpace a s) => a -> SF a a 73 | imIntegral = ((\_ a' dt v -> v ^+^ realToFrac dt *^ a') `iterFrom`) 74 | 75 | -- | Trapezoid integral (using the average between the value at the last time 76 | -- and the value at the current time). 77 | trapezoidIntegral :: (Fractional s, VectorSpace a s) => SF a a 78 | trapezoidIntegral = 79 | iterFrom (\a a' dt v -> v ^+^ (realToFrac dt / 2) *^ (a ^+^ a')) zeroVector 80 | 81 | -- | Integrate the first input signal and add the /discrete/ accumulation (sum) 82 | -- of the second, discrete, input signal. 83 | impulseIntegral :: (Fractional k, VectorSpace a k) => SF (a, Event a) a 84 | impulseIntegral = (integral *** accumHoldBy (^+^) zeroVector) >>^ uncurry (^+^) 85 | 86 | -- | Count the occurrences of input events. 87 | -- 88 | -- >>> embed count (deltaEncode 1 [Event 'a', NoEvent, Event 'b']) 89 | -- [Event 1,NoEvent,Event 2] 90 | count :: Integral b => SF (Event a) (Event b) 91 | count = accumBy (\n _ -> n + 1) 0 92 | 93 | -- * Differentiation 94 | 95 | -- | A very crude version of a derivative. It simply divides the value 96 | -- difference by the time difference. Use at your own risk. 97 | derivative :: (Fractional s, VectorSpace a s) => SF a a 98 | derivative = SF {sfTF = tf0} 99 | where 100 | tf0 a0 = (derivativeAux a0, zeroVector) 101 | 102 | derivativeAux aPrev = SF' tf -- True 103 | where 104 | tf dt a = (derivativeAux a, (a ^-^ aPrev) ^/ realToFrac dt) 105 | 106 | -- | Integrate using an auxiliary function that takes the current and the last 107 | -- input, the time between those samples, and the last output, and returns a new 108 | -- output. 109 | iterFrom :: (a -> a -> DTime -> b -> b) -> b -> SF a b 110 | f `iterFrom` b = SF (iterAux b) 111 | where 112 | iterAux b a = (SF' (\dt a' -> iterAux (f a a' dt b) a'), b) 113 | -------------------------------------------------------------------------------- /yampa/src/FRP/Yampa/Loop.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : FRP.Yampa.Loop 3 | -- Copyright : (c) Ivan Perez, 2014-2022 4 | -- (c) George Giorgidze, 2007-2012 5 | -- (c) Henrik Nilsson, 2005-2006 6 | -- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 7 | -- License : BSD-style (see the LICENSE file in the distribution) 8 | -- 9 | -- Maintainer : ivan.perez@keera.co.uk 10 | -- Stability : provisional 11 | -- 12 | -- Portability : non-portable -GHC extensions- 13 | -- 14 | -- Well-initialised loops. 15 | module FRP.Yampa.Loop 16 | ( 17 | -- * Loops with guaranteed well-defined feedback 18 | loopPre 19 | , loopIntegral 20 | ) 21 | where 22 | 23 | -- External imports 24 | import Control.Arrow (loop, second, (>>>)) 25 | import Data.VectorSpace (VectorSpace) 26 | 27 | -- Internal imports 28 | import FRP.Yampa.Delays (iPre) 29 | import FRP.Yampa.Integration (integral) 30 | import FRP.Yampa.InternalCore (SF) 31 | 32 | -- * Loops with guaranteed well-defined feedback 33 | 34 | -- | Loop with an initial value for the signal being fed back. 35 | loopPre :: c -> SF (a, c) (b, c) -> SF a b 36 | loopPre cInit sf = loop (second (iPre cInit) >>> sf) 37 | 38 | -- | Loop by integrating the second value in the pair and feeding the result 39 | -- back. Because the integral at time 0 is zero, this is always well defined. 40 | loopIntegral :: (Fractional s, VectorSpace c s) => SF (a, c) (b, c) -> SF a b 41 | loopIntegral sf = loop (second integral >>> sf) 42 | -------------------------------------------------------------------------------- /yampa/src/FRP/Yampa/Random.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : FRP.Yampa.Random 3 | -- Copyright : (c) Ivan Perez, 2014-2022 4 | -- (c) George Giorgidze, 2007-2012 5 | -- (c) Henrik Nilsson, 2005-2006 6 | -- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 7 | -- License : BSD-style (see the LICENSE file in the distribution) 8 | -- 9 | -- Maintainer : ivan.perez@keera.co.uk 10 | -- Stability : provisional 11 | -- Portability : non-portable (GHC extensions) 12 | -- 13 | -- Signals and signal functions with noise and randomness. 14 | -- 15 | -- The Random number generators are re-exported from "System.Random". 16 | module FRP.Yampa.Random 17 | ( 18 | -- * Random number generators 19 | RandomGen(..) 20 | , Random(..) 21 | 22 | -- * Noise, random signals, and stochastic event sources 23 | , noise 24 | , noiseR 25 | , occasionally 26 | ) 27 | where 28 | 29 | -- External imports 30 | import System.Random (Random (..), RandomGen (..)) 31 | 32 | -- Internal imports 33 | import FRP.Yampa.Diagnostics (intErr, usrErr) 34 | import FRP.Yampa.Event (Event (..)) 35 | import FRP.Yampa.InternalCore (SF (..), SF' (..), Time) 36 | 37 | -- * Noise (i.e. random signal generators) and stochastic processes 38 | 39 | -- | Noise (random signal) with default range for type in question; based on 40 | -- "randoms". 41 | noise :: (RandomGen g, Random b) => g -> SF a b 42 | noise g0 = streamToSF (randoms g0) 43 | 44 | -- | Noise (random signal) with specified range; based on "randomRs". 45 | noiseR :: (RandomGen g, Random b) => (b, b) -> g -> SF a b 46 | noiseR range g0 = streamToSF (randomRs range g0) 47 | 48 | -- | Turn an infinite list of elements into an SF producing those elements. The 49 | -- SF ignores its input. 50 | streamToSF :: [b] -> SF a b 51 | streamToSF [] = intErr "Yampa" "streamToSF" "Empty list!" 52 | streamToSF (b:bs) = SF {sfTF = tf0} 53 | where 54 | tf0 _ = (stsfAux bs, b) 55 | 56 | stsfAux [] = intErr "Yampa" "streamToSF" "Empty list!" 57 | -- Invarying since stsfAux [] is an error. 58 | stsfAux (b:bs) = SF' tf -- True 59 | where 60 | tf _ _ = (stsfAux bs, b) 61 | 62 | -- | Stochastic event source with events occurring on average once every tAvg 63 | -- seconds. However, no more than one event results from any one sampling 64 | -- interval in the case of relatively sparse sampling, thus avoiding an "event 65 | -- backlog" should sampling become more frequent at some later point in time. 66 | occasionally :: RandomGen g => g -> Time -> b -> SF a (Event b) 67 | occasionally g tAvg x | tAvg > 0 = SF {sfTF = tf0} 68 | | otherwise = usrErr "Yampa" "occasionally" 69 | "Non-positive average interval." 70 | where 71 | -- Generally, if events occur with an average frequency of f, the 72 | -- probability of at least one event occurring in an interval of t is given 73 | -- by (1 - exp (-f*t)). The goal in the following is to decide whether at 74 | -- least one event occurred in the interval of size dt preceding the current 75 | -- sample point. For the first point, we can think of the preceding interval 76 | -- as being 0, implying no probability of an event occurring. 77 | 78 | tf0 _ = (occAux (randoms g :: [Time]), NoEvent) 79 | 80 | occAux [] = undefined 81 | occAux (r:rs) = SF' tf -- True 82 | where 83 | tf dt _ = (occAux rs, if r < p then Event x else NoEvent) 84 | where 85 | p = 1 - exp (- (dt / tAvg)) -- Probability for at least one event. 86 | -------------------------------------------------------------------------------- /yampa/src/FRP/Yampa/Scan.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : FRP.Yampa.Scan 3 | -- Copyright : (c) Ivan Perez, 2014-2022 4 | -- (c) George Giorgidze, 2007-2012 5 | -- (c) Henrik Nilsson, 2005-2006 6 | -- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 7 | -- License : BSD-style (see the LICENSE file in the distribution) 8 | -- 9 | -- Maintainer : ivan.perez@keera.co.uk 10 | -- Stability : provisional 11 | -- Portability : non-portable (GHC extensions) 12 | -- 13 | -- Simple, stateful signal processing. 14 | -- 15 | -- Scanning implements elementary, step-based accumulating over signal functions 16 | -- by means of an auxiliary function applied to each input and to an 17 | -- accumulator. For comparison with other FRP libraries and with stream 18 | -- processing abstractions, think of fold. 19 | module FRP.Yampa.Scan 20 | ( sscan 21 | , sscanPrim 22 | ) 23 | where 24 | 25 | -- Internal imports 26 | import FRP.Yampa.InternalCore (SF(..), sfSScan) 27 | 28 | -- ** Simple, stateful signal processing 29 | 30 | -- | Applies a function point-wise, using the last output as next input. This 31 | -- creates a well-formed loop based on a pure, auxiliary function. 32 | sscan :: (b -> a -> b) -> b -> SF a b 33 | sscan f bInit = sscanPrim f' bInit bInit 34 | where 35 | f' b a = Just (b', b') 36 | where 37 | b' = f b a 38 | 39 | -- | Generic version of 'sscan', in which the auxiliary function produces an 40 | -- internal accumulator and an "held" output. 41 | -- 42 | -- Applies a function point-wise, using the last known 'Just' output to form the 43 | -- output, and next input accumulator. If the output is 'Nothing', the last 44 | -- known accumulators are used. This creates a well-formed loop based on a pure, 45 | -- auxiliary function. 46 | sscanPrim :: (c -> a -> Maybe (c, b)) -> c -> b -> SF a b 47 | sscanPrim f cInit bInit = SF {sfTF = tf0} 48 | where 49 | tf0 a0 = case f cInit a0 of 50 | Nothing -> (sfSScan f cInit bInit, bInit) 51 | Just (c', b') -> (sfSScan f c' b', b') 52 | -------------------------------------------------------------------------------- /yampa/src/FRP/Yampa/Task.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | -- | 4 | -- Module : FRP.Yampa.Task 5 | -- Copyright : (c) Ivan Perez, 2014-2022 6 | -- (c) George Giorgidze, 2007-2012 7 | -- (c) Henrik Nilsson, 2005-2006 8 | -- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 9 | -- License : BSD-style (see the LICENSE file in the distribution) 10 | -- 11 | -- Maintainer : ivan.perez@keera.co.uk 12 | -- Stability : provisional 13 | -- Portability : non-portable (GHC extensions) 14 | -- 15 | -- Task abstraction on top of signal transformers. 16 | module FRP.Yampa.Task 17 | ( 18 | -- * The Task type 19 | Task 20 | , mkTask 21 | , runTask 22 | , runTask_ 23 | , taskToSF 24 | 25 | -- * Basic tasks 26 | , constT 27 | , sleepT 28 | , snapT 29 | 30 | -- * Basic tasks combinators 31 | , timeOut 32 | , abortWhen 33 | ) 34 | where 35 | 36 | -- External imports 37 | #if __GLASGOW_HASKELL__ < 710 38 | import Control.Applicative (Applicative(..)) 39 | #endif 40 | 41 | -- Internal imports 42 | import FRP.Yampa.Basic (constant) 43 | import FRP.Yampa.Diagnostics (intErr, usrErr) 44 | import FRP.Yampa.Event (Event, lMerge) 45 | import FRP.Yampa.EventS (after, edgeBy, never, snap) 46 | import FRP.Yampa.InternalCore (SF, Time, arr, first, (&&&), (>>>)) 47 | import FRP.Yampa.Switches (switch) 48 | 49 | infixl 0 `timeOut`, `abortWhen` 50 | 51 | -- * The Task type 52 | 53 | -- | A task is a partially SF that may terminate with a result. 54 | newtype Task a b c = 55 | -- CPS-based representation allowing termination to be detected. Note the 56 | -- rank 2 polymorphic type! The representation can be changed if necessary, 57 | -- but the Monad laws follow trivially in this case. 58 | Task (forall d . (c -> SF a (Either b d)) -> SF a (Either b d)) 59 | 60 | unTask :: Task a b c -> ((c -> SF a (Either b d)) -> SF a (Either b d)) 61 | unTask (Task f) = f 62 | 63 | -- | Creates a 'Task' from an SF that returns, as a second output, an 'Event' 64 | -- when the SF terminates. See 'switch'. 65 | mkTask :: SF a (b, Event c) -> Task a b c 66 | mkTask st = Task (switch (st >>> first (arr Left))) 67 | 68 | -- | Runs a task. 69 | -- 70 | -- The output from the resulting signal transformer is tagged with Left while 71 | -- the underlying task is running. Once the task has terminated, the output goes 72 | -- constant with the value Right x, where x is the value of the terminating 73 | -- event. 74 | 75 | -- Check name. 76 | runTask :: Task a b c -> SF a (Either b c) 77 | runTask tk = (unTask tk) (constant . Right) 78 | 79 | -- | Runs a task that never terminates. 80 | -- 81 | -- The output becomes undefined once the underlying task has terminated. 82 | -- 83 | -- Convenience function for tasks which are known not to terminate. 84 | runTask_ :: Task a b c -> SF a b 85 | runTask_ tk = runTask tk 86 | >>> arr (either id (usrErr "YampaTask" "runTask_" 87 | "Task terminated!")) 88 | 89 | -- | Creates an SF that represents an SF and produces an event when the task 90 | -- terminates, and otherwise produces just an output. 91 | taskToSF :: Task a b c -> SF a (b, Event c) 92 | taskToSF tk = runTask tk 93 | >>> (arr (either id (usrErr "YampaTask" "runTask_" 94 | "Task terminated!")) 95 | &&& edgeBy isEdge (Left undefined)) 96 | where 97 | isEdge (Left _) (Right c) = Just c 98 | isEdge _ _ = Nothing 99 | 100 | -- * Functor, Applicative and Monad instance 101 | 102 | instance Functor (Task a b) where 103 | fmap f tk = Task (\k -> unTask tk (k . f)) 104 | 105 | instance Applicative (Task a b) where 106 | pure x = Task (\k -> k x) 107 | f <*> v = Task (\k -> (unTask f) (\c -> unTask v (k . c))) 108 | 109 | instance Monad (Task a b) where 110 | tk >>= f = Task (\k -> unTask tk (\c -> unTask (f c) k)) 111 | return = pure 112 | 113 | -- Let's check the monad laws: 114 | -- 115 | -- t >>= return 116 | -- = \k -> t (\c -> return c k) 117 | -- = \k -> t (\c -> (\x -> \k -> k x) c k) 118 | -- = \k -> t (\c -> (\x -> \k' -> k' x) c k) 119 | -- = \k -> t (\c -> k c) 120 | -- = \k -> t k 121 | -- = t 122 | -- QED 123 | -- 124 | -- return x >>= f 125 | -- = \k -> (return x) (\c -> f c k) 126 | -- = \k -> (\k -> k x) (\c -> f c k) 127 | -- = \k -> (\k' -> k' x) (\c -> f c k) 128 | -- = \k -> (\c -> f c k) x 129 | -- = \k -> f x k 130 | -- = f x 131 | -- QED 132 | -- 133 | -- (t >>= f) >>= g 134 | -- = \k -> (t >>= f) (\c -> g c k) 135 | -- = \k -> (\k' -> t (\c' -> f c' k')) (\c -> g c k) 136 | -- = \k -> t (\c' -> f c' (\c -> g c k)) 137 | -- = \k -> t (\c' -> (\x -> \k' -> f x (\c -> g c k')) c' k) 138 | -- = \k -> t (\c' -> (\x -> f x >>= g) c' k) 139 | -- = t >>= (\x -> f x >>= g) 140 | -- QED 141 | -- 142 | -- No surprises (obviously, since this is essentially just the CPS monad). 143 | 144 | -- * Basic tasks 145 | 146 | -- | Non-terminating task with constant output b. 147 | constT :: b -> Task a b c 148 | constT b = mkTask (constant b &&& never) 149 | 150 | -- | "Sleeps" for t seconds with constant output b. 151 | sleepT :: Time -> b -> Task a b () 152 | sleepT t b = mkTask (constant b &&& after t ()) 153 | 154 | -- | Takes a "snapshot" of the input and terminates immediately with the input 155 | -- value as the result. 156 | -- 157 | -- No time passes; therefore, the following must hold: 158 | -- 159 | -- @snapT >> snapT = snapT@ 160 | snapT :: Task a b a 161 | snapT = mkTask (constant (intErr "YampaTask" "snapT" "Bad switch?") &&& snap) 162 | 163 | -- * Basic tasks combinators 164 | 165 | -- | Impose a time out on a task. 166 | timeOut :: Task a b c -> Time -> Task a b (Maybe c) 167 | tk `timeOut` t = mkTask ((taskToSF tk &&& after t ()) >>> arr aux) 168 | where 169 | aux ((b, ec), et) = (b, lMerge (fmap Just ec) (fmap (const Nothing) et)) 170 | 171 | -- | Run a "guarding" event source (SF a (Event b)) in parallel with a (possibly 172 | -- non-terminating) task. 173 | -- 174 | -- The task will be aborted at the first occurrence of the event source (if it 175 | -- has not terminated itself before that). 176 | -- 177 | -- Useful for separating sequencing and termination concerns. E.g. we can do 178 | -- something "useful", but in parallel watch for a (exceptional) condition which 179 | -- should terminate that activity, without having to check for that condition 180 | -- explicitly during each and every phase of the activity. 181 | -- 182 | -- Example: @tsk `abortWhen` lbp@ 183 | abortWhen :: Task a b c -> SF a (Event d) -> Task a b (Either c d) 184 | tk `abortWhen` est = mkTask ((taskToSF tk &&& est) >>> arr aux) 185 | where 186 | aux ((b, ec), ed) = (b, lMerge (fmap Left ec) (fmap Right ed)) 187 | -------------------------------------------------------------------------------- /yampa/src/FRP/Yampa/Time.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : FRP.Yampa.Time 3 | -- Copyright : (c) Ivan Perez, 2014-2022 4 | -- (c) George Giorgidze, 2007-2012 5 | -- (c) Henrik Nilsson, 2005-2006 6 | -- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 7 | -- License : BSD-style (see the LICENSE file in the distribution) 8 | -- 9 | -- Maintainer : ivan.perez@keera.co.uk 10 | -- Stability : provisional 11 | -- Portability : non-portable (GHC extensions) 12 | -- 13 | -- SF primitives that producing the current running time. 14 | -- 15 | -- Time is global for an 'SF', so, every constituent 'SF' will use the same 16 | -- global clock. However, when used in combination with 17 | -- 'FRP.Yampa.Switches.switch'ing, the SF switched into will be started at the 18 | -- time of switching, so any reference to 'localTime' or 'time' from that 'SF' 19 | -- will count using the time of switching as the start time. 20 | -- 21 | -- Take also into account that, because 'FRP.Yampa.Integration.derivative' is 22 | -- the derivative of a signal /over time/, differentiating 'localTime' will 23 | -- always produce the value one (@1@). If you really, really, really need to 24 | -- know the time delta, and need to abandon the hybrid\/FRP abstraction, see 25 | -- 'FRP.Yampa.Integration.iterFrom'. 26 | module FRP.Yampa.Time 27 | ( localTime 28 | , time 29 | ) 30 | where 31 | 32 | -- External imports 33 | import Control.Arrow ((>>>)) 34 | 35 | -- Internal imports 36 | import FRP.Yampa.Basic (constant) 37 | import FRP.Yampa.Integration (integral) 38 | import FRP.Yampa.InternalCore (SF, Time) 39 | 40 | -- | Outputs the time passed since the signal function instance was started. 41 | localTime :: SF a Time 42 | localTime = constant 1.0 >>> integral 43 | 44 | -- | Alternative name for localTime. 45 | time :: SF a Time 46 | time = localTime 47 | -------------------------------------------------------------------------------- /yampa/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-12.16 2 | 3 | extra-deps: 4 | - random-1.1 5 | - simple-affine-space-0.1 6 | 7 | nix: 8 | packages: [binutils] 9 | -------------------------------------------------------------------------------- /yampa/tests/HaddockCoverage.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Main (HaddockCoverage) 3 | -- Copyright : (C) 2015 Ivan Perez 4 | -- License : BSD-style (see the file LICENSE) 5 | -- Maintainer : Ivan Perez 6 | -- Stability : provisional 7 | -- Portability : portable 8 | -- 9 | -- Copyright notice: This file borrows code 10 | -- https://hackage.haskell.org/package/lens-4.7/src/tests/doctests.hsc 11 | -- which is itself licensed BSD-style as well. 12 | -- 13 | -- Run haddock on a source tree and report if anything in any 14 | -- module is not documented. 15 | module Main where 16 | 17 | import Control.Applicative 18 | import Control.Monad 19 | import Data.List 20 | import System.Directory 21 | import System.Exit 22 | import System.FilePath 23 | import System.IO 24 | import System.Process 25 | import Text.Regex.Posix 26 | 27 | main :: IO () 28 | main = do 29 | -- Find haskell modules 30 | -- TODO: Ideally cabal should do this (provide us with the 31 | -- list of modules). An alternative would be to use cabal haddock 32 | -- but that would need a --no-html argument or something like that. 33 | -- Alternatively, we could use cabal haddock with additional arguments. 34 | -- 35 | -- See: 36 | -- https://github.com/keera-studios/haddock/commit/d5d752943c4e5c6c9ffcdde4dc136fcee967c495 37 | -- https://github.com/haskell/haddock/issues/309#issuecomment-150811929 38 | files <- getSources 39 | 40 | let haddockArgs = [ "--no-warnings" ] ++ files 41 | let cabalArgs = [ "exec", "--", "haddock" ] ++ haddockArgs 42 | print cabalArgs 43 | (code, out, _err) <- readProcessWithExitCode "cabal" cabalArgs "" 44 | 45 | -- Filter out coverage lines, and find those that denote undocumented 46 | -- modules. 47 | -- 48 | -- TODO: is there a way to annotate a function as self-documenting, 49 | -- in the same way we do with ANN for hlint? 50 | let isIncompleteModule :: String -> Bool 51 | isIncompleteModule line = isCoverageLine line && not (line =~ "^ *100%") 52 | where isCoverageLine :: String -> Bool 53 | isCoverageLine line = line =~ "^ *[0-9]+%" 54 | 55 | let incompleteModules :: [String] 56 | incompleteModules = filter isIncompleteModule $ lines out 57 | 58 | -- Based on the result of haddock, report errors and exit. 59 | -- Note that, unline haddock, this script does not 60 | -- output anything to stdout. It uses stderr instead 61 | -- (as it should). 62 | case (code, incompleteModules) of 63 | (ExitSuccess , []) -> return () 64 | (ExitFailure _, _) -> exitFailure 65 | (_ , _) -> do 66 | hPutStrLn stderr "The following modules are not fully documented:" 67 | mapM_ (hPutStrLn stderr) incompleteModules 68 | exitFailure 69 | 70 | getSources :: IO [FilePath] 71 | getSources = filter isHaskellFile <$> go "src" 72 | where 73 | go dir = do 74 | (dirs, files) <- getFilesAndDirectories dir 75 | (files ++) . concat <$> mapM go dirs 76 | 77 | isHaskellFile fp = (isSuffixOf ".hs" fp || isSuffixOf ".lhs" fp) 78 | && not (any (`isSuffixOf` fp) excludedFiles) 79 | 80 | excludedFiles = [ "Yampa.hs", "Random.hs" ] 81 | 82 | getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) 83 | getFilesAndDirectories dir = do 84 | c <- map (dir ) . filter (`notElem` ["..", "."]) 85 | <$> getDirectoryContents dir 86 | 87 | (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c 88 | 89 | -- find-based implementation (not portable) 90 | -- 91 | -- getSources :: IO [FilePath] 92 | -- getSources = fmap lines $ readProcess "find" ["src/", "-iname", "*hs"] "" 93 | -------------------------------------------------------------------------------- /yampa/tests/hlint.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Main (hlint) 3 | -- Copyright : (C) 2013 Edward Kmett 4 | -- License : BSD-style (see the file LICENSE) 5 | -- Maintainer : Edward Kmett 6 | -- Stability : provisional 7 | -- Portability : portable 8 | -- 9 | -- This module runs HLint on the lens source tree. 10 | module Main where 11 | 12 | import Control.Monad 13 | import Language.Haskell.HLint 14 | import System.Environment 15 | import System.Exit 16 | 17 | main :: IO () 18 | main = do 19 | args <- getArgs 20 | hints <- hlint $ ["src", "--cross"] ++ args 21 | unless (null hints) exitFailure 22 | --------------------------------------------------------------------------------