diff options
| author | Stephane Glondu <steph@glondu.net> | 2015-10-28 15:12:00 +0100 |
|---|---|---|
| committer | Stephane Glondu <steph@glondu.net> | 2015-10-28 15:12:00 +0100 |
| commit | 4e3b2a5306e1907376cea509463253995f6d13da (patch) | |
| tree | b48339790deb38a29d561708a0591d27c99c62e1 | |
| parent | b7dc0e7b8a57e54cd1fe83f97c326632e5183cff (diff) | |
Imported Upstream version 1.2.0
| -rw-r--r-- | CHANGES.md | 19 | ||||
| -rw-r--r-- | README.md | 10 | ||||
| -rw-r--r-- | TODO.md | 50 | ||||
| -rw-r--r-- | _tags | 3 | ||||
| -rw-r--r-- | doc/React.E.Option.html | 2 | ||||
| -rw-r--r-- | doc/React.E.html | 72 | ||||
| -rw-r--r-- | doc/React.S.Bool.html | 26 | ||||
| -rw-r--r-- | doc/React.S.Option.html | 8 | ||||
| -rw-r--r-- | doc/React.S.Special.html | 2 | ||||
| -rw-r--r-- | doc/React.S.html | 64 | ||||
| -rw-r--r-- | doc/React.Step.html | 12 | ||||
| -rw-r--r-- | doc/React.html | 118 | ||||
| -rw-r--r-- | doc/index_values.html | 29 | ||||
| -rw-r--r-- | doc/style.css | 33 | ||||
| -rw-r--r-- | doc/type_React.S.Bool.html | 4 | ||||
| -rw-r--r-- | doc/type_React.S.html | 4 | ||||
| -rw-r--r-- | doc/type_React.html | 4 | ||||
| -rw-r--r-- | opam | 6 | ||||
| -rw-r--r-- | pkg/META | 16 | ||||
| -rwxr-xr-x | pkg/build.ml | 1 | ||||
| -rwxr-xr-x | pkg/git.ml | 5 | ||||
| -rw-r--r-- | pkg/topkg-ext.ml | 8 | ||||
| -rw-r--r-- | pkg/topkg.ml | 4 | ||||
| -rw-r--r-- | src/react.ml | 1133 | ||||
| -rw-r--r-- | src/react.mli | 499 | ||||
| -rw-r--r-- | src/react_top.ml | 48 | ||||
| -rw-r--r-- | test/breakout.ml | 214 | ||||
| -rw-r--r-- | test/clock.ml | 14 | ||||
| -rw-r--r-- | test/js_test.ml | 20 | ||||
| -rw-r--r-- | test/test.ml | 1036 |
30 files changed, 1899 insertions, 1565 deletions
@@ -1,19 +1,28 @@ + +v1.2.0 2014-08-24 Cambridge (UK) +-------------------------------- + +- Fix bug in dynamic creation of S.{diff,changes} (#8). +- Fix bug in dynamic creation of S.switch (#7). +- Add support for toplevel: automatically `open React` on `#require "react"`. +- Add `S.Bool.{flip,edge,fall,rise}`. + v1.1.0 2014-04-27 La Forclaz (VS) --------------------------------- - Fix `S.switch` rank's initialisation. - Add `E.l{1,2,3,4,5,6}`, lifting combinators on events. - Add `E.Option.{some,value}`. -- Add `S.{Float,Int}.{zero,one,minus_one}`. +- Add `S.{Float,Int}.{zero,one,minus_one}`. - Add `S.Bool.{zero,one}`. - Add `S.Option.{none,some,value}`. - Add `{S,E}.on` equivalent to `{S,E}.when_`. -- Deprecate `{S,E}.when_` (syntax error prone). +- Deprecate `{S,E}.when_` (syntax error prone). v1.0.1 2014-04-21 La Forclaz (VS) --------------------------------- -- Fix `S.bind`. +- Fix `S.bind`. - Use package builder topkg for distribution. v1.0.0 2014-04-02 La Forclaz (VS) @@ -32,7 +41,7 @@ The following changes are incompatible. arrays are not to prevent leaks. The function `{E,S}.stop` now have an optional `?strong` argument; if unused the previous semantics is preserved. -- Change signature of `S.switch`. Any existing call `S.switch ~eq s es` can +- Change signature of `S.switch`. Any existing call `S.switch ~eq s es` can be replaced by `S.(switch ~eq (hold ~eq:( == ) s es))`. @@ -59,7 +68,7 @@ v0.9.1 2010-04-15 Paris ----------------------- - Added `E.retain` and `S.retain`. -- A few `List.map` where replaced by `List.rev_map`. +- A few `List.map` where replaced by `List.rev_map`. - Fixes to `breakout.ml` to make it work on vte based terminals. @@ -1,6 +1,6 @@ React — Declarative events and signals for OCaml ------------------------------------------------------------------------------- -Release 1.1.0 +Release 1.2.0 React is an OCaml module for functional reactive programming (FRP). It provides support to program with time varying values : declarative @@ -28,8 +28,8 @@ instructions. The documentation and API reference is automatically generated by `ocamldoc` from the interfaces. It can be consulted [online][3] -and there is a generated version in the `doc` directory of the -distribution. +and there is a generated version in the `doc` directory of the +distribution. [3]: http://erratique.ch/software/react/doc/React @@ -47,7 +47,7 @@ directory of the distribution. They can be built with: The resulting binaries are in `_build/test`. - `test.native` tests the library, nothing should fail. -- `clock.native` is a command line program using ANSI escape sequences - and the Unix module to print the current local time. +- `clock.native` is a command line program using ANSI escape sequences + and the Unix module to print the current local time. - `breakout.native` is a command line program using ANSI escape sequences and the Unix module to implement a simple breakout game. @@ -1,28 +1,52 @@ +# Exceptions + +* Make steps resistant to exceptions ? There's more than one solution here + one is to discard the step and unschedule all nodes. Another would be + to catch them an trap them like in Fut. + + # New event combinators -* E.merge but only on simultanous occs ? +* E.merge but only on simultanous occs ? +* Review Bool.flip init. +* S.Bool.edge,rise,fall plural ? +* E.Bool.flip -# Signal init. +# Signal init. -Instead of having bare values why not always have signals ? +Instead of having bare values why not always have signals ? This would undermine the temptation of using S.value. -# New signal combinators. +# Stopped nodes -To avoid uses of S.value we need better ways to access a -signal's current value and inject it in an efficient -way in the graph. +Stopped nodes could be detected and considered as constant by +smart constructors. -```ocaml -S.freeze : 'a signal -> 'a signal -(** [freeze s]_{t} = [s]_{t'} where t' is freeze's creation time. *) -``` +# Multisample -See if we can return a const and if what happens when used with -bind and/or provide an alternative S.bind for bootstraping. +Current combinators are not good for sampling multiple signals, +which is generally useful in conjunction with accum. TODO +maybe not in fact see list selector. Just compute the as a signal. +But maybe not always natural ? +# Recursive defs +Investigate the case when dynamics can replace signals with constants +one which could make a direct dep on the delay noded (and hence +raise). Doesn't seem possible but I suspect I saw this once. +# New signal combinators. +To avoid uses of S.value we need better ways to access a +signal's current value and inject it in an efficient +way in the graph. + +```ocaml +S.freeze : 'a signal -> 'a signal +(** [freeze s]_{t} = [s]_{t'} where t' is freeze's creation time. *) +``` + +See if we can return a const and if what happens when used with +bind and/or provide an alternative S.bind for bootstraping. @@ -1,5 +1,8 @@ <**/*.{ml,mli}> : bin_annot, annot + <src> : include +<src/react_top.*> : package(compiler-libs.toplevel) + <test> : include <test/clock.{native,byte}> : use_unix <test/breakout.{native,byte}> : use_unix diff --git a/doc/React.E.Option.html b/doc/React.E.Option.html index b3a53d7..8d8098c 100644 --- a/doc/React.E.Option.html +++ b/doc/React.E.Option.html @@ -32,7 +32,7 @@ Events with option occurences.<br> <ul> <li>[<code class="code">value ~default e</code>]<sub class="subscript">t</sub><code class="code"> = v</code> if [<code class="code">e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> (<span class="constructor">Some</span> v)</code>.</li> <li>[<code class="code">value ?default:<span class="constructor">None</span> e</code>]<sub class="subscript">t</sub><code class="code"> = <span class="constructor">None</span></code> if [<code class="code">e</code>]<sub class="subscript">t</sub> = <code class="code"><span class="constructor">None</span></code>.</li> -<li>[<code class="code">value ?default:(<span class="constructor">Some</span> s) e</code>]<sub class="subscript">t</sub><code class="code"> = v</code> +<li>[<code class="code">value ?default:(<span class="constructor">Some</span> s) e</code>]<sub class="subscript">t</sub><code class="code"> = v</code> if [<code class="code">e</code>]<sub class="subscript">t</sub> = <code class="code"><span class="constructor">None</span></code> and [<code class="code">s</code>]<sub class="subscript">t</sub> <code class="code">= v</code>.</li> </ul> <br> diff --git a/doc/React.E.html b/doc/React.E.html index d5761da..219390d 100644 --- a/doc/React.E.html +++ b/doc/React.E.html @@ -25,7 +25,7 @@ <h1>Module <a href="type_React.E.html">React.E</a></h1> <pre><span class="keyword">module</span> E: <code class="code"><span class="keyword">sig</span></code> <a href="React.E.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info module top"> -Event combinators. +Event combinators. <p> Consult their <a href="React.html#evsem">semantics.</a><br> @@ -45,15 +45,15 @@ A never occuring event. For all t, [<code class="code">never</code>]<sub class=" </div> <pre><span id="VALcreate"><span class="keyword">val</span> create</span> : <code class="type">unit -> 'a <a href="React.html#TYPEevent">React.event</a> * (?step:<a href="React.html#TYPEstep">React.step</a> -> 'a -> unit)</code></pre><div class="info "> -<code class="code">create ()</code> is a primitive event <code class="code">e</code> and a <code class="code">send</code> function. The +<code class="code">create ()</code> is a primitive event <code class="code">e</code> and a <code class="code">send</code> function. The function <code class="code">send</code> is such that: <ul> -<li><code class="code">send v</code> generates an occurrence <code class="code">v</code> of <code class="code">e</code> at the time it is called +<li><code class="code">send v</code> generates an occurrence <code class="code">v</code> of <code class="code">e</code> at the time it is called and triggers an <a href="React.html#steps">update step</a>.</li> -<li><code class="code">send ~step v</code> generates an occurence <code class="code">v</code> of <code class="code">e</code> on the step <code class="code">step</code> +<li><code class="code">send ~step v</code> generates an occurence <code class="code">v</code> of <code class="code">e</code> on the step <code class="code">step</code> when <code class="code">step</code> is <a href="React.Step.html#VALexecute">executed</a>.</li> -<li><code class="code">send ~step v</code> raises <code class="code"><span class="constructor">Invalid_argument</span></code> if it was previously - called with a step and this step has not executed yet or if +<li><code class="code">send ~step v</code> raises <code class="code"><span class="constructor">Invalid_argument</span></code> if it was previously + called with a step and this step has not executed yet or if the given <code class="code">step</code> was already executed.</li> </ul> @@ -73,13 +73,13 @@ A never occuring event. For all t, [<code class="code">never</code>]<sub class=" <pre><span id="VALstop"><span class="keyword">val</span> stop</span> : <code class="type">?strong:bool -> 'a <a href="React.html#TYPEevent">React.event</a> -> unit</code></pre><div class="info "> <code class="code">stop e</code> stops <code class="code">e</code> from occuring. It conceptually becomes - <a href="React.E.html#VALnever"><code class="code"><span class="constructor">React</span>.<span class="constructor">E</span>.never</code></a> and cannot be restarted. Allows to - disable <a href="React.html#sideeffects">effectful</a> events. + <a href="React.E.html#VALnever"><code class="code"><span class="constructor">React</span>.<span class="constructor">E</span>.never</code></a> and cannot be restarted. Allows to + disable <a href="React.html#sideeffects">effectful</a> events. <p> The <code class="code">strong</code> argument should only be used on platforms - where weak arrays have a strong semantics (i.e. JavaScript). - See <a href="React.html#strongstop">details</a>. + where weak arrays have a strong semantics (i.e. JavaScript). + See <a href="React.html#strongstop">details</a>. <p> <b>Note.</b> If executed in an <a href="React.html#steps">update step</a> @@ -103,7 +103,7 @@ A never occuring event. For all t, [<code class="code">never</code>]<sub class=" <pre><span id="VALonce"><span class="keyword">val</span> once</span> : <code class="type">'a <a href="React.html#TYPEevent">React.event</a> -> 'a <a href="React.html#TYPEevent">React.event</a></code></pre><div class="info "> <code class="code">once e</code> is <code class="code">e</code> with only its next occurence. <ul> -<li>[<code class="code">once e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> v</code> if [<code class="code">e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> v</code> and +<li>[<code class="code">once e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> v</code> if [<code class="code">e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> v</code> and [<code class="code">e</code>]<sub class="subscript"><t</sub> <code class="code">= <span class="constructor">None</span></code>.</li> <li>[<code class="code">once e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">None</span></code> otherwise.</li> </ul> @@ -111,9 +111,9 @@ A never occuring event. For all t, [<code class="code">never</code>]<sub class=" </div> <pre><span id="VALdrop_once"><span class="keyword">val</span> drop_once</span> : <code class="type">'a <a href="React.html#TYPEevent">React.event</a> -> 'a <a href="React.html#TYPEevent">React.event</a></code></pre><div class="info "> -<code class="code">drop_once e</code> is <code class="code">e</code> without its next occurrence. +<code class="code">drop_once e</code> is <code class="code">e</code> without its next occurrence. <ul> -<li>[<code class="code">drop_once e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> v</code> if [<code class="code">e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> v</code> and +<li>[<code class="code">drop_once e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> v</code> if [<code class="code">e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> v</code> and [<code class="code">e</code>]<sub class="subscript"><t</sub> <code class="code">= <span class="constructor">Some</span> _</code>.</li> <li>[<code class="code">drop_once e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">None</span></code> otherwise.</li> </ul> @@ -125,7 +125,7 @@ A never occuring event. For all t, [<code class="code">never</code>]<sub class=" <a href="React.html#simultaneity">simultaneously</a>. The value is <code class="code">ef</code>'s occurence applied to <code class="code">e</code>'s one. <ul> -<li>[<code class="code">app ef e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> v'</code> if [<code class="code">ef</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> f</code> and +<li>[<code class="code">app ef e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> v'</code> if [<code class="code">ef</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> f</code> and [<code class="code">e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> v</code> and <code class="code">f v = v'</code>.</li> <li>[<code class="code">app ef e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">None</span></code> otherwise.</li> </ul> @@ -146,9 +146,9 @@ A never occuring event. For all t, [<code class="code">never</code>]<sub class=" </div> <pre><span id="VALfilter"><span class="keyword">val</span> filter</span> : <code class="type">('a -> bool) -> 'a <a href="React.html#TYPEevent">React.event</a> -> 'a <a href="React.html#TYPEevent">React.event</a></code></pre><div class="info "> -<code class="code">filter p e</code> are <code class="code">e</code>'s occurrences that satisfy <code class="code">p</code>. +<code class="code">filter p e</code> are <code class="code">e</code>'s occurrences that satisfy <code class="code">p</code>. <ul> -<li>[<code class="code">filter p e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> v</code> if [<code class="code">e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> v</code> and +<li>[<code class="code">filter p e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> v</code> if [<code class="code">e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> v</code> and <code class="code">p v = <span class="keyword">true</span></code></li> <li>[<code class="code">filter p e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">None</span></code> otherwise.</li> </ul> @@ -177,12 +177,12 @@ A never occuring event. For all t, [<code class="code">never</code>]<sub class=" </div> <pre><span id="VALchanges"><span class="keyword">val</span> changes</span> : <code class="type">?eq:('a -> 'a -> bool) -> 'a <a href="React.html#TYPEevent">React.event</a> -> 'a <a href="React.html#TYPEevent">React.event</a></code></pre><div class="info "> -<code class="code">changes eq e</code> is <code class="code">e</code>'s occurrences with occurences equal to +<code class="code">changes eq e</code> is <code class="code">e</code>'s occurrences with occurences equal to the previous one dropped. Equality is tested with <code class="code">eq</code> (defaults to structural equality). <ul> <li>[<code class="code">changes eq e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> v</code> if [<code class="code">e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> v</code> - and either [<code class="code">e</code>]<sub class="subscript"><t</sub> <code class="code">= <span class="constructor">None</span></code> or [<code class="code">e</code>]<sub class="subscript"><t</sub> <code class="code">= <span class="constructor">Some</span> v'</code> and + and either [<code class="code">e</code>]<sub class="subscript"><t</sub> <code class="code">= <span class="constructor">None</span></code> or [<code class="code">e</code>]<sub class="subscript"><t</sub> <code class="code">= <span class="constructor">Some</span> v'</code> and <code class="code">eq v v' = <span class="keyword">false</span></code>.</li> <li>[<code class="code">changes eq e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">None</span></code> otherwise.</li> </ul> @@ -190,9 +190,9 @@ A never occuring event. For all t, [<code class="code">never</code>]<sub class=" </div> <pre><span id="VALon"><span class="keyword">val</span> on</span> : <code class="type">bool <a href="React.html#TYPEsignal">React.signal</a> -> 'a <a href="React.html#TYPEevent">React.event</a> -> 'a <a href="React.html#TYPEevent">React.event</a></code></pre><div class="info "> -<code class="code">on c e</code> is the occurrences of <code class="code">e</code> when <code class="code">c</code> is <code class="code"><span class="keyword">true</span></code>. +<code class="code">on c e</code> is the occurrences of <code class="code">e</code> when <code class="code">c</code> is <code class="code"><span class="keyword">true</span></code>. <ul> -<li>[<code class="code">on c e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> v</code> +<li>[<code class="code">on c e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> v</code> if [<code class="code">c</code>]<sub class="subscript">t</sub> <code class="code">= <span class="keyword">true</span></code> and [<code class="code">e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> v</code>.</li> <li>[<code class="code">on c e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">None</span></code> otherwise.</li> </ul> @@ -204,9 +204,9 @@ A never occuring event. For all t, [<code class="code">never</code>]<sub class=" </div> <pre><span id="VALdismiss"><span class="keyword">val</span> dismiss</span> : <code class="type">'b <a href="React.html#TYPEevent">React.event</a> -> 'a <a href="React.html#TYPEevent">React.event</a> -> 'a <a href="React.html#TYPEevent">React.event</a></code></pre><div class="info "> -<code class="code">dismiss c e</code> is the occurences of <code class="code">e</code> except the ones when <code class="code">c</code> occurs. +<code class="code">dismiss c e</code> is the occurences of <code class="code">e</code> except the ones when <code class="code">c</code> occurs. <ul> -<li>[<code class="code">dimiss c e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> v</code> +<li>[<code class="code">dimiss c e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> v</code> if [<code class="code">c</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">None</span></code> and [<code class="code">e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> v</code>.</li> <li>[<code class="code">dimiss c e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">None</span></code> otherwise.</li> </ul> @@ -232,7 +232,7 @@ A never occuring event. For all t, [<code class="code">never</code>]<sub class=" <li>[<code class="code">accum ef i</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> (f i)</code> if [<code class="code">ef</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> f</code> and [<code class="code">ef</code>]<sub class="subscript"><t</sub> <code class="code">= <span class="constructor">None</span></code>. </li> -<li>[<code class="code">accum ef i</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> (f acc)</code> if [<code class="code">ef</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> f</code> +<li>[<code class="code">accum ef i</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> (f acc)</code> if [<code class="code">ef</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> f</code> and [<code class="code">accum ef i</code>]<sub class="subscript"><t</sub> <code class="code">= <span class="constructor">Some</span> acc</code>.</li> <li>[<code class="code">accum ef i</code>] <code class="code">= <span class="constructor">None</span></code> otherwise.</li> </ul> @@ -240,7 +240,7 @@ A never occuring event. For all t, [<code class="code">never</code>]<sub class=" </div> <pre><span id="VALfold"><span class="keyword">val</span> fold</span> : <code class="type">('a -> 'b -> 'a) -> 'a -> 'b <a href="React.html#TYPEevent">React.event</a> -> 'a <a href="React.html#TYPEevent">React.event</a></code></pre><div class="info "> -<code class="code">fold f i e</code> accumulates <code class="code">e</code>'s occurrences with <code class="code">f</code> starting with <code class="code">i</code>. +<code class="code">fold f i e</code> accumulates <code class="code">e</code>'s occurrences with <code class="code">f</code> starting with <code class="code">i</code>. <ul> <li>[<code class="code">fold f i e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> (f i v)</code> if [<code class="code">e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> v</code> and [<code class="code">e</code>]<sub class="subscript"><t</sub> <code class="code">= <span class="constructor">None</span></code>.</li> @@ -254,11 +254,11 @@ A never occuring event. For all t, [<code class="code">never</code>]<sub class=" <h1 id="combine">Combining</h1><br> <pre><span id="VALselect"><span class="keyword">val</span> select</span> : <code class="type">'a <a href="React.html#TYPEevent">React.event</a> list -> 'a <a href="React.html#TYPEevent">React.event</a></code></pre><div class="info "> -<code class="code">select el</code> is the occurrences of every event in <code class="code">el</code>. +<code class="code">select el</code> is the occurrences of every event in <code class="code">el</code>. If more than one event occurs <a href="React.html#simultaneity">simultaneously</a> the leftmost is taken and the others are lost. <ul> -<li>[<code class="code">select el</code>]<sub class="subscript">t</sub> <code class="code">=</code> [<code class="code"><span class="constructor">List</span>.find (<span class="keyword">fun</span> e <span class="keywordsign">-></span> </code>[<code class="code">e</code>]<sub class="subscript">t</sub> +<li>[<code class="code">select el</code>]<sub class="subscript">t</sub> <code class="code">=</code> [<code class="code"><span class="constructor">List</span>.find (<span class="keyword">fun</span> e <span class="keywordsign">-></span> </code>[<code class="code">e</code>]<sub class="subscript">t</sub> <code class="code"><> <span class="constructor">None</span>) el</code>]<sub class="subscript">t</sub></li> <li>[<code class="code">select el</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">None</span></code> otherwise.</li> </ul> @@ -270,18 +270,18 @@ A never occuring event. For all t, [<code class="code">never</code>]<sub class=" occurrences of every event in <code class="code">el</code> using <code class="code">f</code> and the accumulator <code class="code">a</code>. <p> - [<code class="code">merge f a el</code>]<sub class="subscript">t</sub> - <code class="code">= <span class="constructor">List</span>.fold_left f a (<span class="constructor">List</span>.filter (<span class="keyword">fun</span> o <span class="keywordsign">-></span> o <> <span class="constructor">None</span>) + [<code class="code">merge f a el</code>]<sub class="subscript">t</sub> + <code class="code">= <span class="constructor">List</span>.fold_left f a (<span class="constructor">List</span>.filter (<span class="keyword">fun</span> o <span class="keywordsign">-></span> o <> <span class="constructor">None</span>) (<span class="constructor">List</span>.map</code> []<sub class="subscript">t</sub><code class="code"> el))</code>.<br> </div> <pre><span id="VALswitch"><span class="keyword">val</span> switch</span> : <code class="type">'a <a href="React.html#TYPEevent">React.event</a> -> 'a <a href="React.html#TYPEevent">React.event</a> <a href="React.html#TYPEevent">React.event</a> -> 'a <a href="React.html#TYPEevent">React.event</a></code></pre><div class="info "> -<code class="code">switch e ee</code> is <code class="code">e</code>'s occurrences until there is an +<code class="code">switch e ee</code> is <code class="code">e</code>'s occurrences until there is an occurrence <code class="code">e'</code> on <code class="code">ee</code>, the occurrences of <code class="code">e'</code> are then used - until there is a new occurrence on <code class="code">ee</code>, etc.. + until there is a new occurrence on <code class="code">ee</code>, etc.. <ul> <li>[<code class="code">switch e ee</code>]<sub class="subscript">t</sub> <code class="code">=</code> [<code class="code">e</code>]<sub class="subscript">t</sub> if [<code class="code">ee</code>]<sub class="subscript"><=t</sub> <code class="code">= <span class="constructor">None</span></code>.</li> -<li>[<code class="code">switch e ee</code>]<sub class="subscript">t</sub> <code class="code">=</code> [<code class="code">e'</code>]<sub class="subscript">t</sub> if [<code class="code">ee</code>]<sub class="subscript"><=t</sub> +<li>[<code class="code">switch e ee</code>]<sub class="subscript">t</sub> <code class="code">=</code> [<code class="code">e'</code>]<sub class="subscript">t</sub> if [<code class="code">ee</code>]<sub class="subscript"><=t</sub> <code class="code">= <span class="constructor">Some</span> e'</code>.</li> </ul> <br> @@ -300,19 +300,19 @@ A never occuring event. For all t, [<code class="code">never</code>]<sub class=" <li>[<code class="code">e</code>]<sub class="subscript">t</sub> <code class="code">=</code> <code class="code"><span class="constructor">None</span></code> if t = 0 </li> <li>[<code class="code">e</code>]<sub class="subscript">t</sub> <code class="code">=</code> [<code class="code">e'</code>]<sub class="subscript">t-dt</sub> otherwise</li> </ul> - + <p> - <b>Raises.</b> <code class="code"><span class="constructor">Invalid_argument</span></code> if <code class="code">e'</code> is directly a delayed event (i.e. + <b>Raises.</b> <code class="code"><span class="constructor">Invalid_argument</span></code> if <code class="code">e'</code> is directly a delayed event (i.e. an event given to a fixing function).<br> </div> <br> -<h1 id="1_Lifting">Lifting</h1> +<h1 id="1_Lifting">Lifting</h1> <p> - Lifting combinators. For a given <code class="code">n</code> the semantics is: + Lifting combinators. For a given <code class="code">n</code> the semantics is: <ul> -<li>[<code class="code">ln f e1 ... en</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> (f v1 ... vn)</code> if for all +<li>[<code class="code">ln f e1 ... en</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> (f v1 ... vn)</code> if for all i : [<code class="code">ei</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> vi</code>.</li> <li>[<code class="code">ln f e1 ... en</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">None</span></code> otherwise.</li> </ul> diff --git a/doc/React.S.Bool.html b/doc/React.S.Bool.html index 425f102..2fc2801 100644 --- a/doc/React.S.Bool.html +++ b/doc/React.S.Bool.html @@ -24,4 +24,28 @@ <pre><span id="VALone"><span class="keyword">val</span> one</span> : <code class="type">bool <a href="React.html#TYPEsignal">React.signal</a></code></pre> <pre><span id="VALnot"><span class="keyword">val</span> not</span> : <code class="type">bool <a href="React.html#TYPEsignal">React.signal</a> -> bool <a href="React.html#TYPEsignal">React.signal</a></code></pre> <pre><span id="VAL(&&)"><span class="keyword">val</span> (&&)</span> : <code class="type">bool <a href="React.html#TYPEsignal">React.signal</a> -> bool <a href="React.html#TYPEsignal">React.signal</a> -> bool <a href="React.html#TYPEsignal">React.signal</a></code></pre> -<pre><span id="VAL(||)"><span class="keyword">val</span> (||)</span> : <code class="type">bool <a href="React.html#TYPEsignal">React.signal</a> -> bool <a href="React.html#TYPEsignal">React.signal</a> -> bool <a href="React.html#TYPEsignal">React.signal</a></code></pre></body></html>
\ No newline at end of file +<pre><span id="VAL(||)"><span class="keyword">val</span> (||)</span> : <code class="type">bool <a href="React.html#TYPEsignal">React.signal</a> -> bool <a href="React.html#TYPEsignal">React.signal</a> -> bool <a href="React.html#TYPEsignal">React.signal</a></code></pre> +<pre><span id="VALedge"><span class="keyword">val</span> edge</span> : <code class="type">bool <a href="React.html#TYPEsignal">React.signal</a> -> bool <a href="React.html#TYPEevent">React.event</a></code></pre><div class="info "> +<code class="code">edge s</code> is <code class="code">changes s</code>.<br> +</div> + +<pre><span id="VALrise"><span class="keyword">val</span> rise</span> : <code class="type">bool <a href="React.html#TYPEsignal">React.signal</a> -> unit <a href="React.html#TYPEevent">React.event</a></code></pre><div class="info "> +<code class="code">rise s</code> is <code class="code"><span class="constructor">E</span>.fmap (<span class="keyword">fun</span> b <span class="keywordsign">-></span> <span class="keyword">if</span> b <span class="keyword">then</span> <span class="constructor">Some</span> () <span class="keyword">else</span> <span class="constructor">None</span>) (edge s)</code>.<br> +</div> + +<pre><span id="VALfall"><span class="keyword">val</span> fall</span> : <code class="type">bool <a href="React.html#TYPEsignal">React.signal</a> -> unit <a href="React.html#TYPEevent">React.event</a></code></pre><div class="info "> +<code class="code">fall s</code> is <code class="code"><span class="constructor">E</span>.fmap (<span class="keyword">fun</span> b <span class="keywordsign">-></span> <span class="keyword">if</span> b <span class="keyword">then</span> <span class="constructor">None</span> <span class="keyword">else</span> <span class="constructor">Some</span> ()) (edge s)</code>.<br> +</div> + +<pre><span id="VALflip"><span class="keyword">val</span> flip</span> : <code class="type">bool -> 'a <a href="React.html#TYPEevent">React.event</a> -> bool <a href="React.html#TYPEsignal">React.signal</a></code></pre><div class="info "> +<code class="code">flip b e</code> is a signal whose boolean value flips each time + <code class="code">e</code> occurs. <code class="code">b</code> is the initial signal value. + <ul> +<li>[<code class="code">flip b e</code>]<sub class="subscript">0</sub> <code class="code">= not b</code> if [<code class="code">e</code>]<sub class="subscript">0</sub> <code class="code">= <span class="constructor">Some</span> _</code></li> +<li>[<code class="code">flip b e</code>]<sub class="subscript">t</sub> <code class="code">= b</code> if [<code class="code">e</code>]<sub class="subscript"><=t</sub> <code class="code">= <span class="constructor">None</span></code></li> +<li>[<code class="code">flip b e</code>]<sub class="subscript">t</sub> <code class="code">=</code> <code class="code">not</code> [<code class="code">flip b e</code>]<sub class="subscript">t-dt</sub> + if [<code class="code">e</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> _</code></li> +</ul> +<br> +</div> +</body></html>
\ No newline at end of file diff --git a/doc/React.S.Option.html b/doc/React.S.Option.html index a0f30ad..5523801 100644 --- a/doc/React.S.Option.html +++ b/doc/React.S.Option.html @@ -32,17 +32,17 @@ </div> <pre><span id="VALvalue"><span class="keyword">val</span> value</span> : <code class="type">?eq:('a -> 'a -> bool) -><br> default:[ `Always of 'a <a href="React.html#TYPEsignal">React.signal</a> | `Init of 'a <a href="React.html#TYPEsignal">React.signal</a> ] -><br> 'a option <a href="React.html#TYPEsignal">React.signal</a> -> 'a <a href="React.html#TYPEsignal">React.signal</a></code></pre><div class="info "> -<code class="code">value default s</code> is <code class="code">s</code> with only its <code class="code"><span class="constructor">Some</span> v</code> values. - Whenever <code class="code">s</code> is <code class="code"><span class="constructor">None</span></code>, if <code class="code">default</code> is <code class="code"><span class="keywordsign">`</span><span class="constructor">Always</span> dv</code> then +<code class="code">value default s</code> is <code class="code">s</code> with only its <code class="code"><span class="constructor">Some</span> v</code> values. + Whenever <code class="code">s</code> is <code class="code"><span class="constructor">None</span></code>, if <code class="code">default</code> is <code class="code"><span class="keywordsign">`</span><span class="constructor">Always</span> dv</code> then the current value of <code class="code">dv</code> is used instead. If <code class="code">default</code> is <code class="code"><span class="keywordsign">`</span><span class="constructor">Init</span> dv</code> the current value of <code class="code">dv</code> is only used if there's no value at creation time, otherwise the last <code class="code"><span class="constructor">Some</span> v</code> value of <code class="code">s</code> is used. <ul> <li>[<code class="code">value ~default s</code>]<sub class="subscript">t</sub> <code class="code">= v</code> if [<code class="code">s</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> v</code></li> -<li>[<code class="code">value ~default:(<span class="keywordsign">`</span><span class="constructor">Always</span> d) s</code>]<sub class="subscript">t</sub> <code class="code">=</code> [<code class="code">d</code>]<sub class="subscript">t</sub> +<li>[<code class="code">value ~default:(<span class="keywordsign">`</span><span class="constructor">Always</span> d) s</code>]<sub class="subscript">t</sub> <code class="code">=</code> [<code class="code">d</code>]<sub class="subscript">t</sub> if [<code class="code">s</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">None</span></code></li> -<li>[<code class="code">value ~default:(<span class="keywordsign">`</span><span class="constructor">Init</span> d) s</code>]<sub class="subscript">0</sub> <code class="code">=</code> [<code class="code">d</code>]<sub class="subscript">0</sub> +<li>[<code class="code">value ~default:(<span class="keywordsign">`</span><span class="constructor">Init</span> d) s</code>]<sub class="subscript">0</sub> <code class="code">=</code> [<code class="code">d</code>]<sub class="subscript">0</sub> if [<code class="code">s</code>]<sub class="subscript">0</sub> <code class="code">= <span class="constructor">None</span></code></li> <li>[<code class="code">value ~default:(<span class="keywordsign">`</span><span class="constructor">Init</span> d) s</code>]<sub class="subscript">t</sub> <code class="code">=</code> [<code class="code">value ~default:(<span class="keywordsign">`</span><span class="constructor">Init</span> d) s</code>]<sub class="subscript">t'</sub> diff --git a/doc/React.S.Special.html b/doc/React.S.Special.html index f014834..8479c22 100644 --- a/doc/React.S.Special.html +++ b/doc/React.S.Special.html @@ -19,7 +19,7 @@ <h1>Module <a href="type_React.S.Special.html">React.S.Special</a></h1> <pre><span class="keyword">module</span> Special: <code class="code"><span class="keyword">sig</span></code> <a href="React.S.Special.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info module top"> -Specialization for booleans, integers and floats. +Specialization for booleans, integers and floats. <p> Open this module to use it.<br> diff --git a/doc/React.S.html b/doc/React.S.html index 2163423..cad02a1 100644 --- a/doc/React.S.html +++ b/doc/React.S.html @@ -28,7 +28,7 @@ <h1>Module <a href="type_React.S.html">React.S</a></h1> <pre><span class="keyword">module</span> S: <code class="code"><span class="keyword">sig</span></code> <a href="React.S.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info module top"> -Signal combinators. +Signal combinators. <p> Consult their <a href="React.html#sigsem">semantics.</a><br> @@ -51,13 +51,13 @@ The type for signals of type <code class="code"><span class="keywordsign">'</spa <code class="code">create i</code> is a primitive signal <code class="code">s</code> set to <code class="code">i</code> and a <code class="code">set</code> function. The function <code class="code">set</code> is such that: <ul> -<li><code class="code">set v</code> sets the signal's value to <code class="code">v</code> at the time it is called and +<li><code class="code">set v</code> sets the signal's value to <code class="code">v</code> at the time it is called and triggers an <a href="React.html#steps">update step</a>.</li> -<li><code class="code">set ~step v</code> sets the signal's value to <code class="code">v</code> at the time it is - called and updates it dependencies when <code class="code">step</code> is +<li><code class="code">set ~step v</code> sets the signal's value to <code class="code">v</code> at the time it is + called and updates it dependencies when <code class="code">step</code> is <a href="React.Step.html#VALexecute">executed</a></li> -<li><code class="code">set ~step v</code> raises <code class="code"><span class="constructor">Invalid_argument</span></code> if it was previously - called with a step and this step has not executed yet or if +<li><code class="code">set ~step v</code> raises <code class="code"><span class="constructor">Invalid_argument</span></code> if it was previously + called with a step and this step has not executed yet or if the given <code class="code">step</code> was already executed.</li> </ul> @@ -65,7 +65,7 @@ The type for signals of type <code class="code"><span class="keywordsign">'</spa </div> <pre><span id="VALvalue"><span class="keyword">val</span> value</span> : <code class="type">'a <a href="React.html#TYPEsignal">React.signal</a> -> 'a</code></pre><div class="info "> -<code class="code">value s</code> is <code class="code">s</code>'s current value. +<code class="code">value s</code> is <code class="code">s</code>'s current value. <p> <b>Warning.</b> If executed in an <a href="React.html#steps">update @@ -89,11 +89,11 @@ The type for signals of type <code class="code"><span class="keywordsign">'</spa <p> The <code class="code">strong</code> argument should only be used on platforms - where weak arrays have a strong semantics (i.e. JavaScript). - See <a href="React.html#strongstop">details</a>. + where weak arrays have a strong semantics (i.e. JavaScript). + See <a href="React.html#strongstop">details</a>. <p> - <b>Note.</b> If executed in an update step the signal may + <b>Note.</b> If executed in an update step the signal may still update in the step.<br> </div> @@ -115,7 +115,7 @@ The type for signals of type <code class="code"><span class="keywordsign">'</spa <h1 id="1_Fromevents">From events</h1><br> <pre><span id="VALhold"><span class="keyword">val</span> hold</span> : <code class="type">?eq:('a -> 'a -> bool) -> 'a -> 'a <a href="React.html#TYPEevent">React.event</a> -> 'a <a href="React.html#TYPEsignal">React.signal</a></code></pre><div class="info "> -<code class="code">hold i e</code> has the value of <code class="code">e</code>'s last occurrence or <code class="code">i</code> if there +<code class="code">hold i e</code> has the value of <code class="code">e</code>'s last occurrence or <code class="code">i</code> if there wasn't any. <ul> <li>[<code class="code">hold i e</code>]<sub class="subscript">t</sub> <code class="code">= i</code> if [<code class="code">e</code>]<sub class="subscript"><=t</sub> <code class="code">= <span class="constructor">None</span></code></li> @@ -128,7 +128,7 @@ The type for signals of type <code class="code"><span class="keywordsign">'</spa <pre><span id="VALapp"><span class="keyword">val</span> app</span> : <code class="type">?eq:('b -> 'b -> bool) -><br> ('a -> 'b) <a href="React.html#TYPEsignal">React.signal</a> -> 'a <a href="React.html#TYPEsignal">React.signal</a> -> 'b <a href="React.html#TYPEsignal">React.signal</a></code></pre><div class="info "> <code class="code">app sf s</code> holds the value of <code class="code">sf</code> applied - to the value of <code class="code">s</code>, [<code class="code">app sf s</code>]<sub class="subscript">t</sub> + to the value of <code class="code">s</code>, [<code class="code">app sf s</code>]<sub class="subscript">t</sub> <code class="code">=</code> [<code class="code">sf</code>]<sub class="subscript">t</sub> [<code class="code">s</code>]<sub class="subscript">t</sub>.<br> </div> @@ -139,7 +139,7 @@ The type for signals of type <code class="code"><span class="keywordsign">'</spa <pre><span id="VALfilter"><span class="keyword">val</span> filter</span> : <code class="type">?eq:('a -> 'a -> bool) -><br> ('a -> bool) -> 'a -> 'a <a href="React.html#TYPEsignal">React.signal</a> -> 'a <a href="React.html#TYPEsignal">React.signal</a></code></pre><div class="info "> <code class="code">filter f i s</code> is <code class="code">s</code>'s values that satisfy <code class="code">p</code>. If a value does not satisfy <code class="code">p</code> it holds the last value that was satisfied or <code class="code">i</code> if - there is none. + there is none. <ul> <li>[<code class="code">filter p s</code>]<sub class="subscript">t</sub> <code class="code">=</code> [<code class="code">s</code>]<sub class="subscript">t</sub> if <code class="code">p</code> [<code class="code">s</code>]<sub class="subscript">t</sub><code class="code"> = <span class="keyword">true</span></code>.</li> <li>[<code class="code">filter p s</code>]<sub class="subscript">t</sub> <code class="code">=</code> [<code class="code">s</code>]<sub class="subscript">t'</sub> if <code class="code">p</code> [<code class="code">s</code>]<sub class="subscript">t</sub><code class="code"> = <span class="keyword">false</span></code> @@ -153,8 +153,8 @@ The type for signals of type <code class="code"><span class="keywordsign">'</spa <code class="code">fmap fm i s</code> is <code class="code">s</code> filtered and mapped by <code class="code">fm</code>. <ul> <li>[<code class="code">fmap fm i s</code>]<sub class="subscript">t</sub> <code class="code">=</code> v if <code class="code">fm</code> [<code class="code">s</code>]<sub class="subscript">t</sub><code class="code"> = <span class="constructor">Some</span> v</code>.</li> -<li>[<code class="code">fmap fm i s</code>]<sub class="subscript">t</sub> <code class="code">=</code> [<code class="code">fmap fm i s</code>]<sub class="subscript">t'</sub> if <code class="code">fm</code> - [<code class="code">s</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">None</span></code> and t' is the greatest t' < t with <code class="code">fm</code> +<li>[<code class="code">fmap fm i s</code>]<sub class="subscript">t</sub> <code class="code">=</code> [<code class="code">fmap fm i s</code>]<sub class="subscript">t'</sub> if <code class="code">fm</code> + [<code class="code">s</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">None</span></code> and t' is the greatest t' < t with <code class="code">fm</code> [<code class="code">s</code>]<sub class="subscript">t'</sub> <code class="code"><> <span class="constructor">None</span></code>.</li> <li>[<code class="code">fmap fm i s</code>]<sub class="subscript">t</sub> <code class="code">= i</code> otherwise.</li> </ul> @@ -166,7 +166,7 @@ The type for signals of type <code class="code"><span class="keywordsign">'</spa <code class="code">v'</code> to <code class="code">v</code> and <code class="code">eq v v'</code> is <code class="code"><span class="keyword">false</span></code> (<code class="code">eq</code> is the signal's equality function). The value of the occurrence is <code class="code">f v v'</code>. <ul> -<li>[<code class="code">diff f s</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> d</code> +<li>[<code class="code">diff f s</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">Some</span> d</code> if [<code class="code">s</code>]<sub class="subscript">t</sub> <code class="code">= v</code> and [<code class="code">s</code>]<sub class="subscript">t-dt</sub> <code class="code">= v'</code> and <code class="code">eq v v' = <span class="keyword">false</span></code> and <code class="code">f v v' = d</code>.</li> <li>[<code class="code">diff f s</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">None</span></code> otherwise.</li> @@ -194,7 +194,7 @@ The type for signals of type <code class="code"><span class="keywordsign">'</spa <code class="code">c</code> was the last time <code class="code"><span class="keyword">true</span></code> or <code class="code">i</code> if it never was. <ul> <li>[<code class="code">on c i s</code>]<sub class="subscript">t</sub> <code class="code">=</code> [<code class="code">s</code>]<sub class="subscript">t</sub> if [<code class="code">c</code>]<sub class="subscript">t</sub> <code class="code">= <span class="keyword">true</span></code></li> -<li>[<code class="code">on c i s</code>]<sub class="subscript">t</sub> <code class="code">=</code> [<code class="code">s</code>]<sub class="subscript">t'</sub> if [<code class="code">c</code>]<sub class="subscript">t</sub> <code class="code">= <span class="keyword">false</span></code> +<li>[<code class="code">on c i s</code>]<sub class="subscript">t</sub> <code class="code">=</code> [<code class="code">s</code>]<sub class="subscript">t'</sub> if [<code class="code">c</code>]<sub class="subscript">t</sub> <code class="code">= <span class="keyword">false</span></code> where t' is the greatest t' < t with [<code class="code">c</code>]<sub class="subscript">t'</sub> <code class="code">= <span class="keyword">true</span></code>.</li> <li>[<code class="code">on c i s</code>]<sub class="subscript">t</sub> <code class="code">=</code> <code class="code">i</code> otherwise.</li> </ul> @@ -232,15 +232,15 @@ The type for signals of type <code class="code"><span class="keywordsign">'</spa <pre><span id="VALmerge"><span class="keyword">val</span> merge</span> : <code class="type">?eq:('a -> 'a -> bool) -><br> ('a -> 'b -> 'a) -> 'a -> 'b <a href="React.html#TYPEsignal">React.signal</a> list -> 'a <a href="React.html#TYPEsignal">React.signal</a></code></pre><div class="info "> <code class="code">merge f a sl</code> merges the value of every signal in <code class="code">sl</code> - using <code class="code">f</code> and the accumulator <code class="code">a</code>. + using <code class="code">f</code> and the accumulator <code class="code">a</code>. <p> - [<code class="code">merge f a sl</code>]<sub class="subscript">t</sub> + [<code class="code">merge f a sl</code>]<sub class="subscript">t</sub> <code class="code">= <span class="constructor">List</span>.fold_left f a (<span class="constructor">List</span>.map</code> []<sub class="subscript">t</sub><code class="code"> sl)</code>.<br> </div> <pre><span id="VALswitch"><span class="keyword">val</span> switch</span> : <code class="type">?eq:('a -> 'a -> bool) -> 'a <a href="React.html#TYPEsignal">React.signal</a> <a href="React.html#TYPEsignal">React.signal</a> -> 'a <a href="React.html#TYPEsignal">React.signal</a></code></pre><div class="info "> -<code class="code">switch ss</code> is the inner signal of <code class="code">ss</code>. +<code class="code">switch ss</code> is the inner signal of <code class="code">ss</code>. <ul> <li>[<code class="code">switch ss</code>]<sub class="subscript">t</sub> <code class="code">=</code> [[<code class="code">ss</code>]<sub class="subscript">t</sub>]<sub class="subscript">t</sub>.</li> </ul> @@ -264,22 +264,22 @@ The type for signals of type <code class="code"><span class="keywordsign">'</spa <li>[<code class="code">s</code>]<sub class="subscript">t</sub> <code class="code">=</code> <code class="code">i</code> for t = 0. </li> <li>[<code class="code">s</code>]<sub class="subscript">t</sub> <code class="code">=</code> [<code class="code">s'</code>]<sub class="subscript">t-dt</sub> otherwise.</li> </ul> - + <p> - <code class="code">eq</code> is the equality used by <code class="code">s</code>. + <code class="code">eq</code> is the equality used by <code class="code">s</code>. <p> - <b>Raises.</b> <code class="code"><span class="constructor">Invalid_argument</span></code> if <code class="code">s'</code> is directly a delayed signal (i.e. + <b>Raises.</b> <code class="code"><span class="constructor">Invalid_argument</span></code> if <code class="code">s'</code> is directly a delayed signal (i.e. a signal given to a fixing function). <p> - <b>Note.</b> Regarding values depending on the result <code class="code">r</code> of + <b>Note.</b> Regarding values depending on the result <code class="code">r</code> of <code class="code">s', r = sf s</code> the following two cases need to be distinguished : <ul> -<li>After <code class="code">sf s</code> is applied, <code class="code">s'</code> does not depend on +<li>After <code class="code">sf s</code> is applied, <code class="code">s'</code> does not depend on a value that is in a step and <code class="code">s</code> has no dependents in a step (e.g - in the simple case where <code class="code">fix</code> is applied outside a step). + in the simple case where <code class="code">fix</code> is applied outside a step). <p> In that case if the initial value of <code class="code">s'</code> differs from <code class="code">i</code>, @@ -294,7 +294,7 @@ The type for signals of type <code class="code"><span class="keywordsign">'</spa <br> </div> <br> -<h1 id="lifting">Lifting</h1> +<h1 id="lifting">Lifting</h1> <p> Lifting combinators. For a given <code class="code">n</code> the semantics is : @@ -308,7 +308,7 @@ The type for signals of type <code class="code"><span class="keywordsign">'</spa <pre><span id="VALl4"><span class="keyword">val</span> l4</span> : <code class="type">?eq:('e -> 'e -> bool) -><br> ('a -> 'b -> 'c -> 'd -> 'e) -><br> 'a <a href="React.html#TYPEsignal">React.signal</a> -><br> 'b <a href="React.html#TYPEsignal">React.signal</a> -> 'c <a href="React.html#TYPEsignal">React.signal</a> -> 'd <a href="React.html#TYPEsignal">React.signal</a> -> 'e <a href="React.html#TYPEsignal">React.signal</a></code></pre> <pre><span id="VALl5"><span class="keyword">val</span> l5</span> : <code class="type">?eq:('f -> 'f -> bool) -><br> ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -><br> 'a <a href="React.html#TYPEsignal">React.signal</a> -><br> 'b <a href="React.html#TYPEsignal">React.signal</a> -><br> 'c <a href="React.html#TYPEsignal">React.signal</a> -> 'd <a href="React.html#TYPEsignal">React.signal</a> -> 'e <a href="React.html#TYPEsignal">React.signal</a> -> 'f <a href="React.html#TYPEsignal">React.signal</a></code></pre> <pre><span id="VALl6"><span class="keyword">val</span> l6</span> : <code class="type">?eq:('g -> 'g -> bool) -><br> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) -><br> 'a <a href="React.html#TYPEsignal">React.signal</a> -><br> 'b <a href="React.html#TYPEsignal">React.signal</a> -><br> 'c <a href="React.html#TYPEsignal">React.signal</a> -><br> 'd <a href="React.html#TYPEsignal">React.signal</a> -> 'e <a href="React.html#TYPEsignal">React.signal</a> -> 'f <a href="React.html#TYPEsignal">React.signal</a> -> 'g <a href="React.html#TYPEsignal">React.signal</a></code></pre><br> -The following modules lift some of <code class="code"><span class="constructor">Pervasives</span></code> functions and +The following modules lift some of <code class="code"><span class="constructor">Pervasives</span></code> functions and operators.<br> <pre><span class="keyword">module</span> <a href="React.S.Bool.html">Bool</a>: <code class="code"><span class="keyword">sig</span></code> <a href="React.S.Bool.html">..</a> <code class="code"><span class="keyword">end</span></code></pre> @@ -320,13 +320,13 @@ The following modules lift some of <code class="code"><span class="constructor"> <h1 id="special">Combinator specialization</h1> <p> - Given an equality function <code class="code">equal</code> and a type <code class="code">t</code>, the functor - <a href="React.S.Make.html"><code class="code"><span class="constructor">React</span>.<span class="constructor">S</span>.<span class="constructor">Make</span></code></a> automatically applies the <code class="code">eq</code> parameter of the combinators. - The outcome is combinators whose <em>results</em> are signals with + Given an equality function <code class="code">equal</code> and a type <code class="code">t</code>, the functor + <a href="React.S.Make.html"><code class="code"><span class="constructor">React</span>.<span class="constructor">S</span>.<span class="constructor">Make</span></code></a> automatically applies the <code class="code">eq</code> parameter of the combinators. + The outcome is combinators whose <em>results</em> are signals with values in <code class="code">t</code>. <p> - Basic types are already specialized in the module <a href="React.S.Special.html"><code class="code"><span class="constructor">React</span>.<span class="constructor">S</span>.<span class="constructor">Special</span></code></a>, open + Basic types are already specialized in the module <a href="React.S.Special.html"><code class="code"><span class="constructor">React</span>.<span class="constructor">S</span>.<span class="constructor">Special</span></code></a>, open this module to use them.<br> <pre><span class="keyword">module type</span> <a href="React.S.EqType.html">EqType</a> = <code class="code"><span class="keyword">sig</span></code> <a href="React.S.EqType.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info"> diff --git a/doc/React.Step.html b/doc/React.Step.html index 7a1015a..c52b573 100644 --- a/doc/React.Step.html +++ b/doc/React.Step.html @@ -20,18 +20,18 @@ <h1>Module <a href="type_React.Step.html">React.Step</a></h1> <pre><span class="keyword">module</span> Step: <code class="code"><span class="keyword">sig</span></code> <a href="React.Step.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info module top"> -Update steps. +Update steps. <p> Update functions returned by <a href="React.S.html#VALcreate"><code class="code"><span class="constructor">React</span>.<span class="constructor">S</span>.create</code></a> and <a href="React.E.html#VALcreate"><code class="code"><span class="constructor">React</span>.<span class="constructor">E</span>.create</code></a> implicitely create and execute update steps when used without - specifying their <code class="code">step</code> argument. + specifying their <code class="code">step</code> argument. <p> - Using explicit <a href="React.html#TYPEstep"><code class="code"><span class="constructor">React</span>.step</code></a> values with these functions gives more control on - the time when the update step is perfomed and allows to perform - simultaneous <a href="React.html#primitives">primitive</a> signal updates and event - occurences. See also the documentation about <a href="React.html#steps">update steps</a> and + Using explicit <a href="React.html#TYPEstep"><code class="code"><span class="constructor">React</span>.step</code></a> values with these functions gives more control on + the time when the update step is perfomed and allows to perform + simultaneous <a href="React.html#primitives">primitive</a> signal updates and event + occurences. See also the documentation about <a href="React.html#steps">update steps</a> and <a href="React.html#simultaneity">simultaneous events</a>.<br> </div> <hr width="100%"> diff --git a/doc/React.html b/doc/React.html index e413d24..7a93bca 100644 --- a/doc/React.html +++ b/doc/React.html @@ -47,7 +47,7 @@ Declarative events and signals. types and modules in your scope. <p> - <em>Release 1.1.0 - Daniel Bünzli <daniel.buenzl i@erratique.ch> </em><br> + <em>Release 1.2.0 - Daniel Bünzli <daniel.buenzl i@erratique.ch> </em><br> </div> <hr width="100%"> <br> @@ -83,18 +83,18 @@ Signal combinators. Update steps. </div> <br> -<h1 id="sem">Semantics</h1> +<h1 id="sem">Semantics</h1> <p> - The following notations are used to give precise meaning to the - combinators. It is important to note that in these semantic + The following notations are used to give precise meaning to the + combinators. It is important to note that in these semantic descriptions the origin of time t = 0 is <em>always</em> fixed at the time at which the combinator creates the event or the signal and the semantics of the dependents is evaluated relative to this timeline. <p> We use dt to denote an infinitesimal amount of time. - <h2 id="evsem">Events</h2> + <h2 id="evsem">Events</h2> <p> An event is a value with discrete occurrences over time. @@ -112,14 +112,14 @@ Update steps. event before (resp. before or at) <code class="code">t</code>. More precisely : <ul> <li>[<code class="code">e</code>]<sub class="subscript"><t</sub> <code class="code">=</code> [<code class="code">e</code>]<sub class="subscript">t'</sub> with t' the greatest t' < t - (resp. <code class="code"><=</code>) such that + (resp. <code class="code"><=</code>) such that [<code class="code">e</code>]<sub class="subscript">t'</sub> <code class="code"><> <span class="constructor">None</span></code>.</li> <li>[<code class="code">e</code>]<sub class="subscript"><t</sub> <code class="code">= <span class="constructor">None</span></code> if there is no such t'.</li> </ul> <p> - <h2 id="sigsem">Signals</h2> + <h2 id="sigsem">Signals</h2> <p> A signal is a value that varies continuously over time. In @@ -129,9 +129,9 @@ Update steps. The semantic function [] <code class="code">: <span class="keywordsign">'</span>a signal <span class="keywordsign">-></span> time <span class="keywordsign">-></span> <span class="keywordsign">'</span>a</code> gives meaning to a signal <code class="code">s</code> by mapping it to a function of time - [<code class="code">s</code>] that returns its value at a given time. We write [<code class="code">s</code>]<sub class="subscript">t</sub> + [<code class="code">s</code>] that returns its value at a given time. We write [<code class="code">s</code>]<sub class="subscript">t</sub> the evaluation of this <em>semantic</em> function at time t. - <h3 id="sigeq">Equality</h3> + <h3 id="sigeq">Equality</h3> <p> Most signal combinators have an optional <code class="code">eq</code> parameter that @@ -139,7 +139,7 @@ Update steps. function used to detect changes in the value of the resulting signal. This function is needed for the efficient update of signals and to deal correctly with signals that perform - <a href="React.html#sideeffects">side effects</a>. + <a href="React.html#sideeffects">side effects</a>. <p> Given an equality function on a type the combinators can be automatically @@ -179,11 +179,11 @@ Update steps. Primitive signals are created with <a href="React.S.html#VALcreate"><code class="code"><span class="constructor">React</span>.<span class="constructor">S</span>.create</code></a>. This function returns a new signal and an update function that sets the signal's value at the time it is called. The following code creates an - integer signal <code class="code">x</code> initially set to <code class="code">1</code> and updates it three time with - values <code class="code">2</code>, <code class="code">2</code>, <code class="code">3</code>. The signal's values are printed on stdout by the + integer signal <code class="code">x</code> initially set to <code class="code">1</code> and updates it three time with + values <code class="code">2</code>, <code class="code">2</code>, <code class="code">3</code>. The signal's values are printed on stdout by the effectful signal <code class="code">pr_x</code>. Note that only updates that change the signal's value are printed, hence the program prints <code class="code">123</code>, not <code class="code">1223</code>. - See the discussion on + See the discussion on <a href="React.html#sideeffects">side effects</a> for more details. <p> @@ -192,11 +192,11 @@ Update steps. <span class="keyword">let</span> x, set_x = <span class="constructor">S</span>.create 1<br> <span class="keyword">let</span> pr_x = <span class="constructor">S</span>.map print_int x<br> <span class="keyword">let</span> () = <span class="constructor">List</span>.iter set_x [2; 2; 3]</code></pre> - The <a href="React.html#clock">clock</a> example shows how a realtime time + The <a href="React.html#clock">clock</a> example shows how a realtime time flow can be defined. <p> - <h2 id="steps">Update steps</h2> + <h2 id="steps">Update steps</h2> <p> The <a href="React.E.html#VALcreate"><code class="code"><span class="constructor">React</span>.<span class="constructor">E</span>.create</code></a> and <a href="React.S.html#VALcreate"><code class="code"><span class="constructor">React</span>.<span class="constructor">S</span>.create</code></a> functions return update functions @@ -220,15 +220,15 @@ Update steps. <h2 id="simultaneity">Simultaneous events</h2> <p> - <a href="React.html#steps">Update steps</a> are made under a + <a href="React.html#steps">Update steps</a> are made under a <a href="http://dx.doi.org/10.1016/0167-6423(92)90005-V">synchrony hypothesis</a> : - the update step takes no time, it is instantenous. Two event occurrences - are <em>simultaneous</em> if they occur in the same update step. + the update step takes no time, it is instantenous. Two event occurrences + are <em>simultaneous</em> if they occur in the same update step. <p> - In the code below <code class="code">w</code>, <code class="code">x</code> and <code class="code">y</code> will always have simultaneous + In the code below <code class="code">w</code>, <code class="code">x</code> and <code class="code">y</code> will always have simultaneous occurrences. They <em>may</em> have simulatenous occurences with <code class="code">z</code> - if <code class="code">send_w</code> and <code class="code">send_z</code> are used with the same update step. + if <code class="code">send_w</code> and <code class="code">send_z</code> are used with the same update step. <p> <pre class="codepre"><code class="code"><span class="keyword">let</span> w, send_w = <span class="constructor">E</span>.create ()<br> @@ -236,13 +236,13 @@ Update steps. <span class="keyword">let</span> y = <span class="constructor">E</span>.map succ x<br> <span class="keyword">let</span> z, send_z = <span class="constructor">E</span>.create ()<br> <br> -<span class="keyword">let</span> () = <br> +<span class="keyword">let</span> () =<br> <span class="keyword">let</span> () = send_w 3 <span class="comment">(* w x y occur simultaneously, z doesn't occur *)</span> <span class="keyword">in</span><br> - <span class="keyword">let</span> step = <span class="constructor">Step</span>.create () <span class="keyword">in</span> <br> - send_w ~step 3; <br> - send_z ~step 4; <br> + <span class="keyword">let</span> step = <span class="constructor">Step</span>.create () <span class="keyword">in</span><br> + send_w ~step 3;<br> + send_z ~step 4;<br> <span class="constructor">Step</span>.execute step <span class="comment">(* w x z y occur simultaneously *)</span><br> -</code></pre> +</code></pre> <p> <h2 id="update">The update step and thread safety</h2> @@ -285,10 +285,10 @@ Update steps. is an update of at least one of the event or signal it depends on. <p> - Remember that a signal updates in a step iff its + Remember that a signal updates in a step iff its <a href="React.html#sigeq">equality function</a> determined that the signal - value changed. Signal initialization is unconditionally considered as - an update. + value changed. Signal initialization is unconditionally considered as + an update. <p> It is important to keep references on effectful events and @@ -313,17 +313,17 @@ Update steps. Besides, some of <code class="code"><span class="constructor">Pervasives</span></code>'s functions and operators are already lifted and availables in submodules of <a href="React.S.html"><code class="code"><span class="constructor">React</span>.<span class="constructor">S</span></code></a>. They can be be opened in specific scopes. For example if you are dealing with - float signals you can open <a href="React.S.Float.html"><code class="code"><span class="constructor">React</span>.<span class="constructor">S</span>.<span class="constructor">Float</span></code></a>. -<pre class="codepre"><code class="code"><span class="keyword">open</span> <span class="constructor">React</span> <br> -<span class="keyword">open</span> <span class="constructor">React</span>.<span class="constructor">S</span>.<span class="constructor">Float</span> <br> + float signals you can open <a href="React.S.Float.html"><code class="code"><span class="constructor">React</span>.<span class="constructor">S</span>.<span class="constructor">Float</span></code></a>. +<pre class="codepre"><code class="code"><span class="keyword">open</span> <span class="constructor">React</span><br> +<span class="keyword">open</span> <span class="constructor">React</span>.<span class="constructor">S</span>.<span class="constructor">Float</span><br> <br> <span class="keyword">let</span> f t = sqrt t *. sin t <span class="comment">(* f is defined on float signals *)</span><br> ...<br> <span class="keyword">open</span> <span class="constructor">Pervasives</span> <span class="comment">(* back to pervasives floats *)</span><br> </code></pre> If you are using OCaml 3.12 or later you can also use the <code class="code"><span class="keyword">let</span> <span class="keyword">open</span></code> - construct -<pre class="codepre"><code class="code"><span class="keyword">let</span> <span class="keyword">open</span> <span class="constructor">React</span>.<span class="constructor">S</span>.<span class="constructor">Float</span> <span class="keyword">in</span> <br> + construct +<pre class="codepre"><code class="code"><span class="keyword">let</span> <span class="keyword">open</span> <span class="constructor">React</span>.<span class="constructor">S</span>.<span class="constructor">Float</span> <span class="keyword">in</span><br> <span class="keyword">let</span> f t = sqrt t *. sin t <span class="keyword">in</span> <span class="comment">(* f is defined on float signals *)</span><br> ...<br> </code></pre> @@ -347,16 +347,16 @@ Update steps. itself returns. <p> - In the example below <code class="code">history s</code> returns a signal whose value - is the history of <code class="code">s</code> as a list. -<pre class="codepre"><code class="code"><span class="keyword">let</span> history ?(eq = ( = )) s = <br> - <span class="keyword">let</span> push v = <span class="keyword">function</span> <br> - <span class="keywordsign">|</span> [] <span class="keywordsign">-></span> [ v ] <br> + In the example below <code class="code">history s</code> returns a signal whose value + is the history of <code class="code">s</code> as a list. +<pre class="codepre"><code class="code"><span class="keyword">let</span> history ?(eq = ( = )) s =<br> + <span class="keyword">let</span> push v = <span class="keyword">function</span><br> + <span class="keywordsign">|</span> [] <span class="keywordsign">-></span> [ v ]<br> <span class="keywordsign">|</span> v' :: _ <span class="keyword">as</span> l <span class="keyword">when</span> eq v v' <span class="keywordsign">-></span> l<br> - <span class="keywordsign">|</span> l <span class="keywordsign">-></span> v :: l <br> + <span class="keywordsign">|</span> l <span class="keywordsign">-></span> v :: l<br> <span class="keyword">in</span><br> - <span class="keyword">let</span> define h = <br> - <span class="keyword">let</span> h' = <span class="constructor">S</span>.l2 push s h <span class="keyword">in</span> <br> + <span class="keyword">let</span> define h =<br> + <span class="keyword">let</span> h' = <span class="constructor">S</span>.l2 push s h <span class="keyword">in</span><br> h', h'<br> <span class="keyword">in</span><br> <span class="constructor">S</span>.fix [] define</code></pre> @@ -370,17 +370,17 @@ Update steps. be well-founded otherwise this may trigger an infinite number of update steps, like in the following examples. <pre class="codepre"><code class="code"><span class="keyword">let</span> start, send_start = <span class="constructor">E</span>.create ()<br> -<span class="keyword">let</span> diverge = <br> - <span class="keyword">let</span> define e = <br> - <span class="keyword">let</span> e' = <span class="constructor">E</span>.select [e; start] <span class="keyword">in</span> <br> +<span class="keyword">let</span> diverge =<br> + <span class="keyword">let</span> define e =<br> + <span class="keyword">let</span> e' = <span class="constructor">E</span>.select [e; start] <span class="keyword">in</span><br> e', e'<br> <span class="keyword">in</span><br> <span class="constructor">E</span>.fix define<br> - <br> +<br> <span class="keyword">let</span> () = send_start () <span class="comment">(* diverges *)</span><br> - <br> +<br> <span class="keyword">let</span> diverge = <span class="comment">(* diverges *)</span><br> - <span class="keyword">let</span> define s = <br> + <span class="keyword">let</span> define s =<br> <span class="keyword">let</span> s' = <span class="constructor">S</span>.<span class="constructor">Int</span>.succ s <span class="keyword">in</span><br> s', s'<br> <span class="keyword">in</span><br> @@ -389,10 +389,10 @@ Update steps. fixing functions) are not allowed to directly depend on each other. Fixed point combinators will raise <code class="code"><span class="constructor">Invalid_argument</span></code> if such dependencies are created. This limitation can be - circumvented by mapping these values with the identity. + circumvented by mapping these values with the identity. <p> - <h2 id="strongstop">Strong stops</h2> + <h2 id="strongstop">Strong stops</h2> <p> Strong stops should only be used on platforms where weak arrays have @@ -422,22 +422,22 @@ Update steps. the example below, <code class="code">e1</code> will <em>never</em> occur: <pre class="codepre"><code class="code"><span class="keyword">let</span> e, e_send = <span class="constructor">E</span>.create ()<br> <span class="keyword">let</span> e1 = <span class="constructor">E</span>.map (<span class="keyword">fun</span> x <span class="keywordsign">-></span> x + 1) e <span class="comment">(* never occurs *)</span><br> -<span class="keyword">let</span> () = <br> - <span class="keyword">let</span> e2 = <span class="constructor">E</span>.map (<span class="keyword">fun</span> x <span class="keywordsign">-></span> x + 1) e1 <span class="keyword">in</span> <br> +<span class="keyword">let</span> () =<br> + <span class="keyword">let</span> e2 = <span class="constructor">E</span>.map (<span class="keyword">fun</span> x <span class="keywordsign">-></span> x + 1) e1 <span class="keyword">in</span><br> <span class="constructor">E</span>.stop ~strong:<span class="keyword">true</span> e2<br> </code></pre> - This can be side stepped by making an artificial dependency to keep + This can be side stepped by making an artificial dependency to keep the reference: <pre class="codepre"><code class="code"><span class="keyword">let</span> e, e_send = <span class="constructor">E</span>.create ()<br> <span class="keyword">let</span> e1 = <span class="constructor">E</span>.map (<span class="keyword">fun</span> x <span class="keywordsign">-></span> x + 1) e <span class="comment">(* may still occur *)</span><br> -<span class="keyword">let</span> e1_ref = <span class="constructor">E</span>.map (<span class="keyword">fun</span> x <span class="keywordsign">-></span> x) e1 <br> -<span class="keyword">let</span> () = <br> +<span class="keyword">let</span> e1_ref = <span class="constructor">E</span>.map (<span class="keyword">fun</span> x <span class="keywordsign">-></span> x) e1<br> +<span class="keyword">let</span> () =<br> <span class="keyword">let</span> e2 = <span class="constructor">E</span>.map (<span class="keyword">fun</span> x <span class="keywordsign">-></span> x + 1) e1 <span class="keyword">in</span><br> <span class="constructor">E</span>.stop ~strong:<span class="keyword">true</span> e2<br> </code></pre> <p> - <h1 id="ex">Examples</h1> + <h1 id="ex">Examples</h1> <p> <h2 id="clock">Clock</h2> @@ -449,16 +449,16 @@ Update steps. along with an <a href="http://www.ecma-international.org/publications/standards/Ecma-048.htm">ANSI escape sequence</a> to control the cursor position. -<pre class="codepre"><code class="code"><span class="keyword">let</span> pr_time t = <br> +<pre class="codepre"><code class="code"><span class="keyword">let</span> pr_time t =<br> <span class="keyword">let</span> tm = <span class="constructor">Unix</span>.localtime t <span class="keyword">in</span><br> - <span class="constructor">Printf</span>.printf <span class="string">"\x1B[8D%02d:%02d:%02d%!"</span> <br> + <span class="constructor">Printf</span>.printf <span class="string">"\x1B[8D%02d:%02d:%02d%!"</span><br> tm.<span class="constructor">Unix</span>.tm_hour tm.<span class="constructor">Unix</span>.tm_min tm.<span class="constructor">Unix</span>.tm_sec<br> <br> <span class="keyword">open</span> <span class="constructor">React</span>;;<br> <br> -<span class="keyword">let</span> seconds, run = <br> +<span class="keyword">let</span> seconds, run =<br> <span class="keyword">let</span> e, send = <span class="constructor">E</span>.create () <span class="keyword">in</span><br> - <span class="keyword">let</span> run () = <br> + <span class="keyword">let</span> run () =<br> <span class="keyword">while</span> <span class="keyword">true</span> <span class="keyword">do</span> send (<span class="constructor">Unix</span>.gettimeofday ()); <span class="constructor">Unix</span>.sleep 1 <span class="keyword">done</span><br> <span class="keyword">in</span><br> e, run<br> diff --git a/doc/index_values.html b/doc/index_values.html index 6dba048..63722b4 100644 --- a/doc/index_values.html +++ b/doc/index_values.html @@ -94,7 +94,7 @@ <tr><td><a href="React.S.html#VALapp">app</a> [<a href="React.S.html">React.S</a>]</td> <td><div class="info"> <code class="code">app sf s</code> holds the value of <code class="code">sf</code> applied - to the value of <code class="code">s</code>, [<code class="code">app sf s</code>]<sub class="subscript">t</sub> + to the value of <code class="code">s</code>, [<code class="code">app sf s</code>]<sub class="subscript">t</sub> <code class="code">=</code> [<code class="code">sf</code>]<sub class="subscript">t</sub> [<code class="code">s</code>]<sub class="subscript">t</sub>. </div> </td></tr> @@ -128,7 +128,7 @@ </td></tr> <tr><td><a href="React.E.html#VALchanges">changes</a> [<a href="React.E.html">React.E</a>]</td> <td><div class="info"> -<code class="code">changes eq e</code> is <code class="code">e</code>'s occurrences with occurences equal to +<code class="code">changes eq e</code> is <code class="code">e</code>'s occurrences with occurences equal to the previous one dropped. </div> </td></tr> @@ -195,6 +195,11 @@ </div> </td></tr> <tr><td align="left"><br>E</td></tr> +<tr><td><a href="React.S.Bool.html#VALedge">edge</a> [<a href="React.S.Bool.html">React.S.Bool</a>]</td> +<td><div class="info"> +<code class="code">edge s</code> is <code class="code">changes s</code>. +</div> +</td></tr> <tr><td><a href="React.S.Float.html#VALepsilon_float">epsilon_float</a> [<a href="React.S.Float.html">React.S.Float</a>]</td> <td></td></tr> <tr><td><a href="React.S.EqType.html#VALequal">equal</a> [<a href="React.S.EqType.html">React.S.EqType</a>]</td> @@ -219,6 +224,11 @@ <tr><td><a href="React.S.Float.html#VALexp">exp</a> [<a href="React.S.Float.html">React.S.Float</a>]</td> <td></td></tr> <tr><td align="left"><br>F</td></tr> +<tr><td><a href="React.S.Bool.html#VALfall">fall</a> [<a href="React.S.Bool.html">React.S.Bool</a>]</td> +<td><div class="info"> +<code class="code">fall s</code> is <code class="code"><span class="constructor">E</span>.fmap (<span class="keyword">fun</span> b <span class="keywordsign">-></span> <span class="keyword">if</span> b <span class="keyword">then</span> <span class="constructor">None</span> <span class="keyword">else</span> <span class="constructor">Some</span> ()) (edge s)</code>. +</div> +</td></tr> <tr><td><a href="React.S.S.html#VALfilter">filter</a> [<a href="React.S.S.html">React.S.S</a>]</td> <td></td></tr> <tr><td><a href="React.S.html#VALfilter">filter</a> [<a href="React.S.html">React.S</a>]</td> @@ -245,6 +255,12 @@ infinitesimal amount of time before. </div> </td></tr> +<tr><td><a href="React.S.Bool.html#VALflip">flip</a> [<a href="React.S.Bool.html">React.S.Bool</a>]</td> +<td><div class="info"> +<code class="code">flip b e</code> is a signal whose boolean value flips each time + <code class="code">e</code> occurs. +</div> +</td></tr> <tr><td><a href="React.S.Float.html#VALfloat">float</a> [<a href="React.S.Float.html">React.S.Float</a>]</td> <td></td></tr> <tr><td><a href="React.S.Float.html#VALfloat_of_int">float_of_int</a> [<a href="React.S.Float.html">React.S.Float</a>]</td> @@ -284,7 +300,7 @@ <td></td></tr> <tr><td><a href="React.S.html#VALhold">hold</a> [<a href="React.S.html">React.S</a>]</td> <td><div class="info"> -<code class="code">hold i e</code> has the value of <code class="code">e</code>'s last occurrence or <code class="code">i</code> if there +<code class="code">hold i e</code> has the value of <code class="code">e</code>'s last occurrence or <code class="code">i</code> if there wasn't any. </div> </td></tr> @@ -438,6 +454,11 @@ A never occuring event. returns the previously retained value. </div> </td></tr> +<tr><td><a href="React.S.Bool.html#VALrise">rise</a> [<a href="React.S.Bool.html">React.S.Bool</a>]</td> +<td><div class="info"> +<code class="code">rise s</code> is <code class="code"><span class="constructor">E</span>.fmap (<span class="keyword">fun</span> b <span class="keywordsign">-></span> <span class="keyword">if</span> b <span class="keyword">then</span> <span class="constructor">Some</span> () <span class="keyword">else</span> <span class="constructor">None</span>) (edge s)</code>. +</div> +</td></tr> <tr><td align="left"><br>S</td></tr> <tr><td><a href="React.S.html#VALsample">sample</a> [<a href="React.S.html">React.S</a>]</td> <td><div class="info"> @@ -494,7 +515,7 @@ A never occuring event. </td></tr> <tr><td><a href="React.E.html#VALswitch">switch</a> [<a href="React.E.html">React.E</a>]</td> <td><div class="info"> -<code class="code">switch e ee</code> is <code class="code">e</code>'s occurrences until there is an +<code class="code">switch e ee</code> is <code class="code">e</code>'s occurrences until there is an occurrence <code class="code">e'</code> on <code class="code">ee</code>, the occurrences of <code class="code">e'</code> are then used until there is a new occurrence on <code class="code">ee</code>, etc.. </div> diff --git a/doc/style.css b/doc/style.css index cb77a1d..cf17675 100644 --- a/doc/style.css +++ b/doc/style.css @@ -4,9 +4,9 @@ html,body,div,span,applet,object,iframe,h1,h2,h3,h4,h5,h6,p,blockquote,pre, a,abbr,acronym,address,big,cite,code,del,dfn,em,font,img,ins,kbd,q,s,samp, small,strike,strong,sub,sup,tt,var,b,u,i,center,dl,dt,dd,ol,ul,li,fieldset, -form,label,legend,table,caption,tbody,tfoot,thead,tr,th,td -{ margin: 0; padding: 0; border: 0 none; outline: 0; font-size: 100%; - font-weight: inherit; font-style:inherit; font-family:inherit; +form,label,legend,table,caption,tbody,tfoot,thead,tr,th,td +{ margin: 0; padding: 0; border: 0 none; outline: 0; font-size: 100%; + font-weight: inherit; font-style:inherit; font-family:inherit; line-height: inherit; vertical-align: baseline; text-align:inherit; color:inherit; background: transparent; } @@ -19,14 +19,14 @@ body { font: normal 10pt/1.375em helvetica, arial, sans-serif; text-align:left; color: black; background: white /* url(line-height-22.gif) */; } b { font-weight: bold } -em { font-style: italic } +em { font-style: italic } -tt, code, pre { font-family: WorkAroundWebKitAndMozilla, monospace; +tt, code, pre { font-family: WorkAroundWebKitAndMozilla, monospace; font-size: 1em; } pre code { font-size : inherit; } -.codepre { margin-bottom:1.375em /* after code example we introduce space. */ } +.codepre { margin-bottom:1.375em /* after code example we introduce space. */ } -.superscript,.subscript +.superscript,.subscript { font-size : 0.813em; line-height:0; margin-left:0.4ex;} .superscript { vertical-align: super; } .subscript { vertical-align: sub; } @@ -47,7 +47,7 @@ h1 + pre { margin-bottom:1.375em} /* Toplevel module description */ /* .navbar { margin-bottom: -1.375em } */ h1 { font-weight: bold; font-size: 1.5em; /* margin-top:1.833em; */ - margin-top:0.917em; padding-top:0.875em; + margin-top:0.917em; padding-top:0.875em; border-top-style:solid; border-width:1px; border-color:#AAA; } h2 { font-weight: bold; font-size: 1.313em; margin-top: 1.048em } h3 { font-weight: bold; font-size: 1.125em; margin-top: 1.222em } @@ -63,7 +63,7 @@ pre { margin-top: 1.375em } .info { margin: 0.458em 0em -0.458em 2em;}/* Description of types values etc. */ td .info { margin:0; padding:0; margin-left: 2em;} /* Description in indexes */ -ul, ol { margin-top:0.688em; padding-bottom:0.687em; +ul, ol { margin-top:0.688em; padding-bottom:0.687em; list-style-position:outside} ul + p, ol + p { margin-top: 0em } ul { list-style-type: square } @@ -74,7 +74,7 @@ ul > li { margin-left: 1.375em; } ol > li { margin-left: 1.7em; } /* Links */ -a, a:link, a:visited, a:active, a:hover { color : #00B; text-decoration: none } +a, a:link, a:visited, a:active, a:hover { color : #00B; text-decoration: none } a:hover { text-decoration : underline } *:target {background-color: #FFFF99;} /* anchor highlight */ @@ -88,7 +88,7 @@ a:hover { text-decoration : underline } /* Functors */ -.paramstable { border-style : hidden ; padding-bottom:1.375em} +.paramstable { border-style : hidden ; padding-bottom:1.375em} .paramstable code { margin-left: 1ex; margin-right: 1ex } .sig_block {margin-left: 1em} @@ -96,14 +96,3 @@ a:hover { text-decoration : underline } img { margin-top: 1.375em; display:block } li img { margin-top: 0em; } - - - - - - - - - - - diff --git a/doc/type_React.S.Bool.html b/doc/type_React.S.Bool.html index 8226733..c542efb 100644 --- a/doc/type_React.S.Bool.html +++ b/doc/type_React.S.Bool.html @@ -15,4 +15,8 @@ <span class="keyword">val</span> not : bool <span class="constructor">React</span>.signal <span class="keywordsign">-></span> bool <span class="constructor">React</span>.signal<br> <span class="keyword">val</span> ( <span class="keywordsign">&&</span> ) : bool <span class="constructor">React</span>.signal <span class="keywordsign">-></span> bool <span class="constructor">React</span>.signal <span class="keywordsign">-></span> bool <span class="constructor">React</span>.signal<br> <span class="keyword">val</span> ( <span class="keywordsign">||</span> ) : bool <span class="constructor">React</span>.signal <span class="keywordsign">-></span> bool <span class="constructor">React</span>.signal <span class="keywordsign">-></span> bool <span class="constructor">React</span>.signal<br> + <span class="keyword">val</span> edge : bool <span class="constructor">React</span>.signal <span class="keywordsign">-></span> bool <span class="constructor">React</span>.event<br> + <span class="keyword">val</span> rise : bool <span class="constructor">React</span>.signal <span class="keywordsign">-></span> unit <span class="constructor">React</span>.event<br> + <span class="keyword">val</span> fall : bool <span class="constructor">React</span>.signal <span class="keywordsign">-></span> unit <span class="constructor">React</span>.event<br> + <span class="keyword">val</span> flip : bool <span class="keywordsign">-></span> <span class="keywordsign">'</span>a <span class="constructor">React</span>.event <span class="keywordsign">-></span> bool <span class="constructor">React</span>.signal<br> <span class="keyword">end</span></code></body></html>
\ No newline at end of file diff --git a/doc/type_React.S.html b/doc/type_React.S.html index 39549b5..ab386ca 100644 --- a/doc/type_React.S.html +++ b/doc/type_React.S.html @@ -103,6 +103,10 @@ bool <span class="constructor">React</span>.signal <span class="keywordsign">-></span> bool <span class="constructor">React</span>.signal <span class="keywordsign">-></span> bool <span class="constructor">React</span>.signal<br> <span class="keyword">val</span> ( <span class="keywordsign">||</span> ) :<br> bool <span class="constructor">React</span>.signal <span class="keywordsign">-></span> bool <span class="constructor">React</span>.signal <span class="keywordsign">-></span> bool <span class="constructor">React</span>.signal<br> + <span class="keyword">val</span> edge : bool <span class="constructor">React</span>.signal <span class="keywordsign">-></span> bool <span class="constructor">React</span>.event<br> + <span class="keyword">val</span> rise : bool <span class="constructor">React</span>.signal <span class="keywordsign">-></span> unit <span class="constructor">React</span>.event<br> + <span class="keyword">val</span> fall : bool <span class="constructor">React</span>.signal <span class="keywordsign">-></span> unit <span class="constructor">React</span>.event<br> + <span class="keyword">val</span> flip : bool <span class="keywordsign">-></span> <span class="keywordsign">'</span>a <span class="constructor">React</span>.event <span class="keywordsign">-></span> bool <span class="constructor">React</span>.signal<br> <span class="keyword">end</span><br> <span class="keyword">module</span> <span class="constructor">Int</span> :<br> <span class="keyword">sig</span><br> diff --git a/doc/type_React.html b/doc/type_React.html index 0f3812d..8c1832f 100644 --- a/doc/type_React.html +++ b/doc/type_React.html @@ -181,6 +181,10 @@ bool <span class="constructor">React</span>.signal <span class="keywordsign">-></span> bool <span class="constructor">React</span>.signal <span class="keywordsign">-></span> bool <span class="constructor">React</span>.signal<br> <span class="keyword">val</span> ( <span class="keywordsign">||</span> ) :<br> bool <span class="constructor">React</span>.signal <span class="keywordsign">-></span> bool <span class="constructor">React</span>.signal <span class="keywordsign">-></span> bool <span class="constructor">React</span>.signal<br> + <span class="keyword">val</span> edge : bool <span class="constructor">React</span>.signal <span class="keywordsign">-></span> bool <span class="constructor">React</span>.event<br> + <span class="keyword">val</span> rise : bool <span class="constructor">React</span>.signal <span class="keywordsign">-></span> unit <span class="constructor">React</span>.event<br> + <span class="keyword">val</span> fall : bool <span class="constructor">React</span>.signal <span class="keywordsign">-></span> unit <span class="constructor">React</span>.event<br> + <span class="keyword">val</span> flip : bool <span class="keywordsign">-></span> <span class="keywordsign">'</span>a <span class="constructor">React</span>.event <span class="keywordsign">-></span> bool <span class="constructor">React</span>.signal<br> <span class="keyword">end</span><br> <span class="keyword">module</span> <span class="constructor">Int</span> :<br> <span class="keyword">sig</span><br> @@ -3,7 +3,9 @@ maintainer: "Daniel Bünzli <daniel.buenzl i@erratique.ch>" homepage: "http://erratique.ch/software/react" authors: ["Daniel Bünzli <daniel.buenzl i@erratique.ch>"] doc: "http://erratique.ch/software/react/doc/React" -tags: [ "reactive" "declarative" "signal" "event" "frp" ] +dev-repo: "http://erratique.ch/repos/react.git" +bug-reports: "https://github.com/dbuenzli/react/issues" +tags: [ "reactive" "declarative" "signal" "event" "frp" "org:erratique" ] license: "BSD3" depends: ["ocamlfind"] ocaml-version: [>= "3.11.0"] @@ -11,5 +13,5 @@ build: [ [ "ocaml" "pkg/git.ml" ] [ "ocaml" "pkg/build.ml" "native=%{ocaml-native}%" - "native-dynlink=%{ocaml-native}%" ] # TODO FIXME + "native-dynlink=%{ocaml-native-dynlink}%" ] ]
\ No newline at end of file @@ -1,8 +1,22 @@ -version = "1.1.0" +version = "1.2.0" description = "Declarative events and signals for OCaml" archive(byte) = "react.cma" archive(byte, plugin) = "react.cma" +archive(byte, toploop) += "react_top.cma" archive(native) = "react.cmxa" archive(native, plugin) = "react.cmxs" +archive(native, toploop) += "react_top.cmxs" exists_if = "react.cma" +package "top" ( + description = "Toplevel support for React" + version = "1.2.0" + requires = "compiler-libs.toplevel" + archive(byte) = "react_top.cma" + archive(byte, plugin) = "react_top.cma" + archive(native) = "react_top.cmxa" + archive(native, plugin) = "react_top.cmxs" + exists_if = "react_top.cma" +) + + diff --git a/pkg/build.ml b/pkg/build.ml index 1ab82dd..53255fe 100755 --- a/pkg/build.ml +++ b/pkg/build.ml @@ -6,6 +6,7 @@ let () = Pkg.describe "react" ~builder:`OCamlbuild [ Pkg.lib "pkg/META"; Pkg.lib ~exts:Exts.module_library "src/react"; + Pkg.lib ~exts:Exts.library "src/react_top"; Pkg.doc "README.md"; Pkg.doc "CHANGES.md"; Pkg.doc "test/breakout.ml"; @@ -7,7 +7,8 @@ let () = if Dir.exists ".git" then begin - Vars.subst ~skip:Config.subst_skip ~vars:Config.vars ~dir:"." &>>= fun () -> - Cmd.exec_hook Config.git_hook &>>= fun () -> () + Vars.subst ~skip:Config.subst_skip ~vars:Config.vars ~dir:"." + >>& fun () -> Cmd.exec_hook Config.git_hook + >>& fun () -> () end diff --git a/pkg/topkg-ext.ml b/pkg/topkg-ext.ml index 4f5906a..b904899 100644 --- a/pkg/topkg-ext.ml +++ b/pkg/topkg-ext.ml @@ -1,11 +1,11 @@ (*--------------------------------------------------------------------------- Copyright (c) 2014 Daniel C. Bünzli. All rights reserved. Distributed under the BSD3 license, see license at the end of the file. - react release 1.1.0 + react release 1.2.0 ---------------------------------------------------------------------------*) let ( >>= ) v f = match v with `Ok v -> f v | `Error _ as e -> e -let ( &>>= ) v f = match v with +let ( >>& ) v f = match v with | `Ok v -> f v | `Error e -> Printf.eprintf "%s: %s\n%!" Sys.argv.(0) e; exit 1 type 'a result = [ `Ok of 'a | `Error of string ] @@ -53,7 +53,7 @@ end = struct let start = ref 0 in let last = ref 0 in let len = String.length s in - while (!last < len - 2) do + while (!last < len - 4) do if not (s.[!last] = '%' && s.[!last + 1] = '%') then incr last else begin let start_subst = !last in @@ -198,7 +198,7 @@ module Git : sig end = struct let describe ?(chop_v = false) branch = if not (Dir.exists ".git") then "not-a-git-checkout" else - Cmd.read (Printf.sprintf "git describe %s" branch) &>>= fun d -> + Cmd.read (Printf.sprintf "git describe %s" branch) >>& fun d -> let len = String.length d in if chop_v && len > 0 && d.[0] = 'v' then String.sub d 1 (len - 2) else String.sub d 0 (len - 1) (* remove \n *) diff --git a/pkg/topkg.ml b/pkg/topkg.ml index 0901c8e..a2b8406 100644 --- a/pkg/topkg.ml +++ b/pkg/topkg.ml @@ -1,7 +1,7 @@ (*--------------------------------------------------------------------------- Copyright (c) 2014 Daniel C. Bünzli. All rights reserved. Distributed under the BSD3 license, see license at the end of the file. - react release 1.1.0 + react release 1.2.0 ---------------------------------------------------------------------------*) (* Public api *) @@ -238,7 +238,7 @@ module Pkg : Pkg = struct let toplevel = mvs "toplevel" let doc = mvs "doc" let misc = mvs "misc" - let stublibs = mvs "stublib" + let stublibs = mvs "stublibs" let man = mvs "man" let bin_drops = if not Env.native then [ ".native" ] else [] diff --git a/src/react.ml b/src/react.ml index d477b7f..790324d 100644 --- a/src/react.ml +++ b/src/react.ml @@ -1,7 +1,7 @@ (*--------------------------------------------------------------------------- Copyright (c) 2009 Daniel C. Bünzli. All rights reserved. Distributed under a BSD3 license, see license at the end of the file. - react release 1.1.0 + react release 1.2.0 ---------------------------------------------------------------------------*) let err_max_rank = "maximal rank exceeded" @@ -9,13 +9,13 @@ let err_sig_undef = "signal value undefined yet" let err_fix = "trying to fix a delayed value" let err_retain_never = "E.never cannot retain a closure" let err_retain_cst_sig = "constant signals cannot retain a closure" -let err_step_executed = "step already executed" +let err_step_executed = "step already executed" let err_event_scheduled = "event already scheduled on a step" let err_signal_scheduled = "signal already scheduled on a step" - -module Wa = struct + +module Wa = struct type 'a t = { mutable arr : 'a Weak.t; mutable len : int } - (* The type for resizeable weak arrays. + (* The type for resizeable weak arrays. For now the arrays only grow. We could try to compact and downsize the array in scan_add if a threshold of empty slots is @@ -23,32 +23,32 @@ module Wa = struct let create size = { arr = Weak.create size; len = 0 } let length a = a.len - let is_empty a = - try - for i = 0 to a.len - 1 do - if Weak.check a.arr i then raise Exit; - done; + let is_empty a = + try + for i = 0 to a.len - 1 do + if Weak.check a.arr i then raise Exit; + done; true with Exit -> false - + let clear a = a.arr <- Weak.create 0; a.len <- 0 let get a i = Weak.get a.arr i let set a i = Weak.set a.arr i - let swap a i i' = - let v = Weak.get a.arr i' in + let swap a i i' = + let v = Weak.get a.arr i' in Weak.blit a.arr i a.arr i' 1; (* blit prevents i from becoming live. *) Weak.set a.arr i v - + let grow a = let arr' = Weak.create (2 * (a.len + 1)) in Weak.blit a.arr 0 arr' 0 a.len; a.arr <- arr' - + let add a v = (* adds v at the end of a. *) if a.len = Weak.length a.arr then grow a; Weak.set a.arr a.len (Some v); a.len <- a.len + 1 - + let scan_add a v = (* adds v to a, tries to find an empty slot, O(a.len). *) try for i = 0 to a.len - 1 do @@ -57,38 +57,38 @@ module Wa = struct done; add a v with Exit -> () - + let rem_last a = let l = a.len - 1 in (a.len <- l; Weak.set a.arr l None) let rem a v = (* removes v from a, uses physical equality, O(a.len). *) - try - for i = 0 to a.len - 1 do + try + for i = 0 to a.len - 1 do match Weak.get a.arr i with | Some v' when v == v' -> Weak.set a.arr i None; raise Exit | _ -> () done with Exit -> () - + let iter f a = for i = 0 to a.len - 1 do match Weak.get a.arr i with Some v -> f v | None -> () - done - - let fold f acc a = - let acc = ref acc in + done + + let fold f acc a = + let acc = ref acc in for i = 0 to a.len - 1 do - match Weak.get a.arr i with Some v -> acc := f !acc v | None -> () + match Weak.get a.arr i with Some v -> acc := f !acc v | None -> () done; !acc end -type node = +type node = { mutable rank : int; (* its rank (height) in the dataflow graph. *) mutable stamp : step; (* last step in which it was scheduled. *) mutable retain : unit -> unit; (* retained by the node, NEVER invoked. *) - mutable producers : unit -> node list; (* nodes on which it depends. *) + mutable producers : unit -> node list; (* nodes on which it depends. *) mutable update : step -> unit; (* update closure. *) deps : node Wa.t } (* weak references to dependent nodes. *) -(* The type for nodes. +(* The type for nodes. Each event and (non-constant) signal has an associated node. The fields producers and update keep, in their closure environment, @@ -103,14 +103,14 @@ type node = end of the step and treated specially at that point (see Step.execute). *) -and step = +and step = { mutable over : bool; (* true when the step is over. *) mutable heap : heap; (* min-heap of nodes sorted by rank. *) mutable eops : (unit -> unit) list; (* end of step operations. *) mutable cops : (unit -> unit) list } (* cleanup step operations. *) (* The type for update steps. - - Note for historical reasons we use the variable names [c] and [c'] + + Note for historical reasons we use the variable names [c] and [c'] in the code for representing update steps. There are four successive phases in the execution of a step c (see @@ -131,17 +131,17 @@ and step = updated in any order as a delayed node updating in a step cannot depend on a delayed node updating in the same step. - 4. Cleanup operations are executed. This clears the event occurences of + 4. Cleanup operations are executed. This clears the event occurences of non-delayed event that occured in c. After this, if a step c' was created in 3. the step gets executed. *) and heap = node Wa.t -(* The type for heaps. +(* The type for heaps. Weak min-heaps of nodes sorted according to their rank. Classic imperative implementation with a twist to accomodate the fact - that nodes may disappear. + that nodes may disappear. The heap property we maintain is that for any node its descendents (vs. children) are either of no smaller rank or they are None. None @@ -154,7 +154,7 @@ and heap = node Wa.t parent of smaller rank), the property can however be reestablished by percolating down from that point. *) -type 'a emut = +type 'a emut = { ev : 'a option ref; (* during steps, holds a potential occurence. *) enode : node; } (* associated node. *) @@ -178,10 +178,10 @@ type 'a event = Never | Emut of 'a emut be scheduled (see E.add_dep). If m only occurs later in the step, the n will be scheduled as usual with the others. *) -type 'a smut = +type 'a smut = { mutable sv : 'a option; (* signal value (None only temporary). *) - mutable eq : 'a -> 'a -> bool; (* to detect signal value changes. *) - mutable snode : node } (* associated node. *) + eq : 'a -> 'a -> bool; (* to detect signal value changes. *) + snode : node } (* associated node. *) type 'a signal = Const of 'a | Smut of 'a smut (* The type for signals. @@ -232,7 +232,7 @@ type 'a signal = Const of 'a | Smut of 'a smut m's up to date values whenever n will initialize and the rank of n ensures this. *) -module H = struct +module H = struct let size = Wa.length let els h = Wa.fold (fun acc e -> e :: acc) [] h (* no particular order. *) let compare_down h i i' = match Wa.get h i, Wa.get h i' with @@ -240,127 +240,127 @@ module H = struct | Some _, None -> 1 (* None is smaller than anything. *) | None, Some _ -> -1 (* None is smaller than anything. *) | None, None -> 0 - + let rec down h i = let last = size h - 1 in let start = 2 * i in - let l = start + 1 in (* left child index. *) + let l = start + 1 in (* left child index. *) let r = start + 2 in (* right child index. *) if l > last then () (* no child, stop *) else let child = (* index of smallest child. *) if r > last then l else (if compare_down h l r < 0 then l else r) in if compare_down h i child > 0 then (Wa.swap h i child; down h child) - + let up h i = let rec aux h i last_none = if i = 0 then (if last_none then down h 0) else let p = (i - 1) / 2 in (* parent index. *) match Wa.get h i, Wa.get h p with - | Some n, Some n' -> + | Some n, Some n' -> if compare n.rank n'.rank < 0 then (Wa.swap h i p; aux h p false) else (if last_none then down h i) - | Some _, None -> + | Some _, None -> Wa.swap h i p; aux h p true - | None, _ -> () + | None, _ -> () in aux h i false - + let rebuild h = for i = (size h - 2) / 2 downto 0 do down h i done let add h n = Wa.add h n; up h (size h - 1) - let rec take h = + let rec take h = let s = size h in if s = 0 then None else let v = Wa.get h 0 in - begin - if s > 1 - then (Wa.set h 0 (Wa.get h (s - 1)); Wa.rem_last h; down h 0) + begin + if s > 1 + then (Wa.set h 0 (Wa.get h (s - 1)); Wa.rem_last h; down h 0) else Wa.rem_last h end; match v with None -> take h | v -> v end -let delayed_rank = max_int - +let delayed_rank = max_int + module Step = struct (* Update steps. *) type t = step let nil = { over = true; heap = Wa.create 0; eops = []; cops = []} let create () = - let h = Wa.create 11 in + let h = Wa.create 11 in { over = false; heap = h; eops = []; cops = []} - + let add c n = if n.stamp == c then () else (n.stamp <- c; H.add c.heap n) let add_deps c n = Wa.iter (add c) n.deps let add_eop c op = c.eops <- op :: c.eops let add_cop c op = c.cops <- op :: c.cops let allow_reschedule n = n.stamp <- nil - let rebuild c = H.rebuild c.heap - - let rec execute c = - let eops c = List.iter (fun op -> op ()) c.eops; c.eops <- [] in + let rebuild c = H.rebuild c.heap + + let rec execute c = + let eops c = List.iter (fun op -> op ()) c.eops; c.eops <- [] in let cops c = List.iter (fun op -> op ()) c.cops; c.cops <- [] in let finish c = c.over <- true; c.heap <- Wa.create 0 in let rec update c = match H.take c.heap with - | Some n when n.rank <> delayed_rank -> n.update c; update c - | Some n -> + | Some n when n.rank <> delayed_rank -> n.update c; update c + | Some n -> let c' = create () in eops c; List.iter (fun n -> n.update c') (n :: H.els c.heap); cops c; finish c; - execute c' + execute c' | None -> eops c; cops c; finish c in update c let execute c = if c.over then invalid_arg err_step_executed else execute c - + let find_unfinished nl = (* find unfinished step in recursive producers. *) let rec aux next = function (* zig-zag breadth-first search. *) | [] -> if next = [] then nil else aux [] next - | [] :: todo -> aux next todo + | [] :: todo -> aux next todo | nl :: todo -> find next todo nl and find next todo = function | [] -> aux next todo - | n :: nl -> + | n :: nl -> if not n.stamp.over then n.stamp else find (n.producers () :: next) todo nl in aux [] [ nl ] end - + module Node = struct let delayed_rank = delayed_rank let min_rank = min_int let max_rank = delayed_rank - 1 - + let nop _ = () let no_producers () = [] - let create r = + let create r = { rank = r; stamp = Step.nil; update = nop; retain = nop; producers = no_producers; deps = Wa.create 0 } let rem_dep n n' = Wa.rem n.deps n' let add_dep n n' = Wa.scan_add n.deps n' let has_dep n = not (Wa.is_empty n.deps) - let deps n = Wa.fold (fun acc d -> d :: acc) [] n.deps + let deps n = Wa.fold (fun acc d -> d :: acc) [] n.deps let bind n p u = n.producers <- p; n.update <- u - let stop ?(strong = false) n = - if not strong then begin - n.producers <- no_producers; n.update <- nop; Wa.clear n.deps; - end else begin - let rec loop next to_rem = function - | [] -> - begin match next with + let stop ?(strong = false) n = + if not strong then begin + n.producers <- no_producers; n.update <- nop; Wa.clear n.deps; + end else begin + let rec loop next to_rem = function + | [] -> + begin match next with | (to_rem, prods) :: next -> loop next to_rem prods | [] -> () - end - | n :: todo -> + end + | n :: todo -> rem_dep n to_rem; (* N.B. rem_dep could be combined with has_dep *) - if n.rank = min_rank (* is a primitive *) || has_dep n - then loop next to_rem todo else - begin + if n.rank = min_rank (* is a primitive *) || has_dep n + then loop next to_rem todo else + begin let prods = n.producers () in n.producers <- no_producers; n.update <- nop; Wa.clear n.deps; loop ((n, prods) :: next) to_rem todo @@ -370,17 +370,17 @@ module Node = struct n.producers <- no_producers; n.update <- nop; Wa.clear n.deps; loop [] n producers end - + let set_rank n r = n.rank <- r let rmin = create min_rank let rmax n n' = if n.rank > n'.rank then n else n' - let rsucc n = + let rsucc n = if n.rank = delayed_rank then min_rank else if n.rank < max_rank then n.rank + 1 else invalid_arg err_max_rank - - let rsucc2 n n' = - let r = rsucc n in - let r' = rsucc n' in + + let rsucc2 n n' = + let r = rsucc n in + let r' = rsucc n' in if r > r' then r else r' (* Rank updates currently only increases ranks. If this is problematic @@ -390,9 +390,9 @@ module Node = struct let update_rank n r = (* returns true iff n's rank increased. *) let rec aux = function | [] -> () - | n :: todo -> + | n :: todo -> let update todo d = - if n.rank < d.rank || n.rank = delayed_rank then todo else + if n.rank < d.rank || n.rank = delayed_rank then todo else (d.rank <- rsucc n; d :: todo) in aux (Wa.fold update todo n.deps) @@ -402,7 +402,7 @@ end (* Shortcuts *) -let rsucc = Node.rsucc +let rsucc = Node.rsucc let rsucc2 = Node.rsucc2 let rmax = Node.rmax @@ -412,16 +412,16 @@ let eval m = match !(m.ev) with Some v -> v | None -> assert false let emut rank = { ev = ref None; enode = Node.create rank } let event m p u = Node.bind m.enode p u; Emut m let eupdate v m c = - let clear v () = v := None in + let clear v () = v := None in m.ev := Some v; Step.add_cop c (clear m.ev); Step.add_deps c m.enode (* Signal value, creation and update *) -let sval m = match m.sv with Some v -> v | None -> assert false +let sval m = match m.sv with Some v -> v | None -> assert false let smut rank eq = { sv = None; eq = eq; snode = Node.create rank } -let signal ?i m p u = +let signal ?i m p u = Node.bind m.snode p u; begin match i with Some _ as v -> m.sv <- v | None -> () end; begin match Step.find_unfinished (m.snode.producers ()) with @@ -429,24 +429,24 @@ let signal ?i m p u = | c -> Step.add c m.snode end; Smut m - -let supdate v m c = match m.sv with + +let supdate v m c = match m.sv with | Some v' when (m.eq v v') -> () | Some _ -> m.sv <- Some v; if c != Step.nil then Step.add_deps c m.snode | None -> m.sv <- Some v (* init. without init value. *) - + module E = struct type 'a t = 'a event - - let add_dep m n = + + let add_dep m n = Node.add_dep m.enode n; if !(m.ev) <> None then Step.add m.enode.stamp n - + let send m ?step v = match step with (* sends an event occurence. *) | Some c -> if c.over then invalid_arg err_step_executed else if not m.enode.stamp.over then invalid_arg err_event_scheduled else - m.enode.stamp <- c; + m.enode.stamp <- c; eupdate v m c | None -> let c = Step.create () in @@ -457,14 +457,14 @@ module E = struct (* Basics *) let never = Never - let create () = + let create () = let m = emut Node.min_rank in Emut m, send m - - let retain e c = match e with - | Never -> invalid_arg err_retain_never + + let retain e c = match e with + | Never -> invalid_arg err_retain_never | Emut m -> let c' = m.enode.retain in (m.enode.retain <- c); (`R c') - + let stop ?strong = function Never -> () | Emut m -> Node.stop ?strong m.enode let equal e e' = match e, e' with | Never, Never -> true @@ -474,21 +474,21 @@ module E = struct let trace ?(iff = Const true) t e = match iff with | Const false -> e | Const true -> - begin match e with - | Never -> e + begin match e with + | Never -> e | Emut m -> let m' = emut (rsucc m.enode) in - let rec p () = [ m.enode ] + let rec p () = [ m.enode ] and u c = let v = eval m in t v; eupdate v m' c in add_dep m m'.enode; - event m' p u + event m' p u end | Smut mc -> match e with | Never -> Never | Emut m -> let m' = emut (rsucc2 mc.snode m.enode) in - let rec p () = [mc.snode; m.enode] + let rec p () = [mc.snode; m.enode] and u c = match !(m.ev) with | None -> () (* mc updated. *) | Some v -> if (sval mc) then t v; eupdate v m' c @@ -496,94 +496,94 @@ module E = struct Node.add_dep mc.snode m'.enode; add_dep m m'.enode; event m' p u - + (* Transforming and filtering *) - + let once = function - | Never -> Never - | Emut m -> + | Never -> Never + | Emut m -> let m' = emut (rsucc m.enode) in let rec p () = [ m.enode ] - and u c = - Node.rem_dep m.enode m'.enode; - eupdate (eval m) m' c; + and u c = + Node.rem_dep m.enode m'.enode; + eupdate (eval m) m' c; Node.stop m'.enode in add_dep m m'.enode; event m' p u - + let drop_once = function | Never -> Never | Emut m -> - let m' = emut (rsucc m.enode) in + let m' = emut (rsucc m.enode) in let rec p () = [ m.enode ] and u c = (* first update. *) let u' c = eupdate (eval m) m' c in (* subsequent updates. *) Node.bind m'.enode p u' - in + in add_dep m m'.enode; event m' p u - + let app ef = function - | Never -> Never - | Emut m -> + | Never -> Never + | Emut m -> match ef with - | Never -> Never + | Never -> Never | Emut mf -> - let m' = emut (rsucc2 m.enode mf.enode) in + let m' = emut (rsucc2 m.enode mf.enode) in let rec p () = [ m.enode; mf.enode ] and u c = match !(mf.ev), !(m.ev) with | None, _ | _, None -> () - | Some f, Some v -> eupdate (f v) m' c - in + | Some f, Some v -> eupdate (f v) m' c + in add_dep m m'.enode; add_dep mf m'.enode; event m' p u - + let map f = function | Never -> Never - | Emut m -> + | Emut m -> let m' = emut (rsucc m.enode) in let rec p () = [ m.enode ] and u c = eupdate (f (eval m)) m' c in add_dep m m'.enode; event m' p u - + let stamp e v = match e with - | Never -> Never - | Emut m -> + | Never -> Never + | Emut m -> let m' = emut (rsucc m.enode) in let rec p () = [ m.enode ] - and u c = eupdate v m' c in + and u c = eupdate v m' c in add_dep m m'.enode; event m' p u - + let filter pred = function - | Never -> Never - | Emut m -> - let m' = emut (rsucc m.enode) in + | Never -> Never + | Emut m -> + let m' = emut (rsucc m.enode) in let rec p () = [ m.enode ] and u c = let v = eval m in if pred v then eupdate v m' c else () in add_dep m m'.enode; event m' p u - + let fmap fm = function - | Never -> Never - | Emut m -> + | Never -> Never + | Emut m -> let m' = emut (rsucc m.enode) in - let rec p () = [ m.enode ] - and u c = match fm (eval m) with Some v -> eupdate v m' c | None -> () + let rec p () = [ m.enode ] + and u c = match fm (eval m) with Some v -> eupdate v m' c | None -> () in add_dep m m'.enode; event m' p u - + let diff d = function | Never -> Never | Emut m -> let m' = emut (rsucc m.enode) in let last = ref None in let rec p () = [ m.enode ] - and u c = + and u c = let v = eval m in match !last with | None -> last := Some v @@ -591,68 +591,68 @@ module E = struct in add_dep m m'.enode; event m' p u - + let changes ?(eq = ( = )) = function | Never -> Never - | Emut m -> + | Emut m -> let m' = emut (rsucc m.enode) in let last = ref None in let rec p () = [ m.enode ] and u c = let v = eval m in - match !last with - | None -> last := Some v; eupdate v m' c + match !last with + | None -> last := Some v; eupdate v m' c | Some v' -> last := Some v; if eq v v' then () else eupdate v m' c in add_dep m m'.enode; event m' p u - + let on c = function | Never -> Never - | Emut m as e -> + | Emut m as e -> match c with | Const true -> e | Const false -> Never | Smut mc -> let m' = emut (rsucc2 m.enode mc.snode) in - let rec p () = [ m.enode; mc.snode ] + let rec p () = [ m.enode; mc.snode ] and u c = match !(m.ev) with | None -> () (* mc updated. *) - | Some _ -> if (sval mc) then eupdate (eval m) m' c else () + | Some _ -> if (sval mc) then eupdate (eval m) m' c else () in add_dep m m'.enode; Node.add_dep mc.snode m'.enode; - event m' p u + event m' p u let when_ = on - + let dismiss c = function | Never -> Never - | Emut m as e -> + | Emut m as e -> match c with | Never -> e | Emut mc -> let m' = emut (rsucc2 mc.enode m.enode) in let rec p () = [ mc.enode; m.enode ] and u c = match !(mc.ev) with - | Some _ -> () - | None -> eupdate (eval m) m' c + | Some _ -> () + | None -> eupdate (eval m) m' c in add_dep mc m'.enode; add_dep m m'.enode; event m' p u - + let until c = function | Never -> Never - | Emut m as e -> - match c with - | Never -> e + | Emut m as e -> + match c with + | Never -> e | Emut mc -> - let m' = emut (rsucc2 m.enode mc.enode) in - let rec p () = [ m.enode; mc.enode] in + let m' = emut (rsucc2 m.enode mc.enode) in + let rec p () = [ m.enode; mc.enode] in let u c = match !(mc.ev) with | None -> eupdate (eval m) m' c - | Some _ -> + | Some _ -> Node.rem_dep m.enode m'.enode; Node.rem_dep mc.enode m'.enode; Node.stop m'.enode @@ -660,87 +660,87 @@ module E = struct add_dep m m'.enode; add_dep mc m'.enode; event m' p u - + (* Accumulating *) let accum ef i = match ef with | Never -> Never - | Emut m -> - let m' = emut (rsucc m.enode) in + | Emut m -> + let m' = emut (rsucc m.enode) in let acc = ref i in - let rec p () = [ m.enode ] + let rec p () = [ m.enode ] and u c = acc := (eval m) !acc; eupdate !acc m' c in add_dep m m'.enode; event m' p u - - let fold f i = function + + let fold f i = function | Never -> Never | Emut m -> - let m' = emut (rsucc m.enode) in + let m' = emut (rsucc m.enode) in let acc = ref i in - let rec p () = [ m.enode ] - and u c = acc := f !acc (eval m); eupdate !acc m' c in + let rec p () = [ m.enode ] + and u c = acc := f !acc (eval m); eupdate !acc m' c in add_dep m m'.enode; event m' p u - + (* Combining *) - + let occurs m = !(m.ev) <> None - let find_muts_and_next_rank el = + let find_muts_and_next_rank el = let rec aux acc max = function | [] -> List.rev acc, rsucc max - | (Emut m) :: l -> aux (m :: acc) (rmax max m.enode) l - | Never :: l -> aux acc max l + | (Emut m) :: l -> aux (m :: acc) (rmax max m.enode) l + | Never :: l -> aux acc max l in - aux [] Node.rmin el - + aux [] Node.rmin el + let select el = let emuts, r = find_muts_and_next_rank el in let m' = emut r in let rec p () = List.rev_map (fun m -> m.enode) emuts and u c = try eupdate (eval (List.find occurs emuts)) m' c with - | Not_found -> assert false + | Not_found -> assert false in List.iter (fun m -> add_dep m m'.enode) emuts; event m' p u - + let merge f a el = let rec fold f acc = function | m :: l when occurs m -> fold f (f acc (eval m)) l | m :: l -> fold f acc l | [] -> acc in - let emuts, r = find_muts_and_next_rank el in + let emuts, r = find_muts_and_next_rank el in let m' = emut r in - let rec p () = List.rev_map (fun m -> m.enode) emuts + let rec p () = List.rev_map (fun m -> m.enode) emuts and u c = eupdate (fold f a emuts) m' c in List.iter (fun m -> add_dep m m'.enode) emuts; event m' p u - + let switch e = function | Never -> e | Emut ms -> let r = match e with | Emut m -> rsucc2 m.enode ms.enode | Never -> rsucc ms.enode - in - let m' = emut r in + in + let m' = emut r in let src = ref e in (* current event source. *) let rec p () = match !src with - | Emut m -> [ m.enode; ms.enode ] | Never -> [ ms.enode ] + | Emut m -> [ m.enode; ms.enode ] | Never -> [ ms.enode ] and u c = match !(ms.ev) with | None -> (match !src with (* only src occurs. *) | Emut m -> eupdate (eval m) m' c | Never -> assert false) | Some e -> - begin match !src with + begin match !src with | Emut m -> Node.rem_dep m.enode m'.enode | Never -> () end; src := e; match e with | Never -> ignore (Node.update_rank m'.enode (rsucc ms.enode)) - | Emut m -> + | Emut m -> Node.add_dep m.enode m'.enode; - if Node.update_rank m'.enode (rsucc2 m.enode ms.enode) then - begin + if Node.update_rank m'.enode (rsucc2 m.enode ms.enode) then + begin (* Rank increased because of m. Thus m may stil update and we may be rescheduled. If it happens we'll be in the other branch without any harm @@ -755,17 +755,17 @@ module E = struct (match e with Emut m -> add_dep m m'.enode | Never -> ()); add_dep ms m'.enode; event m' p u - - let fix f = + + let fix f = let m = emut Node.delayed_rank in let e = event m (fun () -> []) (fun _ -> assert false) in match f e with | Never, r -> r - | Emut m', r -> + | Emut m', r -> if m'.enode.rank = Node.delayed_rank then invalid_arg err_fix; - let rec p () = [ (* avoid cyclic dep. *) ] + let rec p () = [ (* avoid cyclic dep. *) ] and u c = (* N.B. c is the next step. *) - let clear v () = v := None in + let clear v () = v := None in m.ev := Some (eval m'); Step.add_eop c (clear m.ev); (* vs. add_cop for regular events. *) Step.add_deps c m.enode @@ -774,220 +774,243 @@ module E = struct add_dep m' m.enode; r - (* Lifting *) + (* Lifting *) - let l1 = map - let l2 f e0 e1 = match e0, e1 with - | Never, _ -> Never + let l1 = map + let l2 f e0 e1 = match e0, e1 with + | Never, _ -> Never | _, Never -> Never - | Emut m0, Emut m1 -> - let r = rsucc2 m0.enode m1.enode in - let m' = emut r in - let rec p () = [ m0.enode; m1.enode ] in - let u c = match !(m0.ev), !(m1.ev) with + | Emut m0, Emut m1 -> + let r = rsucc2 m0.enode m1.enode in + let m' = emut r in + let rec p () = [ m0.enode; m1.enode ] in + let u c = match !(m0.ev), !(m1.ev) with | None, _ | _, None -> () - | Some v0, Some v1 -> eupdate (f v0 v1) m' c + | Some v0, Some v1 -> eupdate (f v0 v1) m' c in - add_dep m0 m'.enode; - add_dep m1 m'.enode; + add_dep m0 m'.enode; + add_dep m1 m'.enode; event m' p u - - let l3 f e0 e1 e2 = match e0, e1, e2 with - | Never, _, _ -> Never + + let l3 f e0 e1 e2 = match e0, e1, e2 with + | Never, _, _ -> Never | _, Never, _ -> Never | _, _, Never -> Never - | Emut m0, Emut m1, Emut m2 -> - let r = rsucc (rmax (rmax m0.enode m1.enode) m2.enode) in - let m' = emut r in - let rec p () = [ m0.enode; m1.enode; m2.enode ] in - let u c = match !(m0.ev), !(m1.ev), !(m2.ev) with + | Emut m0, Emut m1, Emut m2 -> + let r = rsucc (rmax (rmax m0.enode m1.enode) m2.enode) in + let m' = emut r in + let rec p () = [ m0.enode; m1.enode; m2.enode ] in + let u c = match !(m0.ev), !(m1.ev), !(m2.ev) with | None, _, _ | _, None, _ | _, _, None -> () - | Some v0, Some v1, Some v2 -> eupdate (f v0 v1 v2) m' c + | Some v0, Some v1, Some v2 -> eupdate (f v0 v1 v2) m' c in - add_dep m0 m'.enode; - add_dep m1 m'.enode; - add_dep m2 m'.enode; + add_dep m0 m'.enode; + add_dep m1 m'.enode; + add_dep m2 m'.enode; event m' p u - let l4 f e0 e1 e2 e3 = match e0, e1, e2, e3 with - | Never, _, _, _ -> Never + let l4 f e0 e1 e2 e3 = match e0, e1, e2, e3 with + | Never, _, _, _ -> Never | _, Never, _, _ -> Never | _, _, Never, _ -> Never | _, _, _, Never -> Never - | Emut m0, Emut m1, Emut m2, Emut m3 -> - let r = rsucc (rmax (rmax m0.enode m1.enode) (rmax m2.enode m3.enode)) in - let m' = emut r in - let rec p () = [ m0.enode; m1.enode; m2.enode; m3.enode ] in - let u c = match !(m0.ev), !(m1.ev), !(m2.ev), !(m3.ev) with + | Emut m0, Emut m1, Emut m2, Emut m3 -> + let r = rsucc (rmax (rmax m0.enode m1.enode) (rmax m2.enode m3.enode)) in + let m' = emut r in + let rec p () = [ m0.enode; m1.enode; m2.enode; m3.enode ] in + let u c = match !(m0.ev), !(m1.ev), !(m2.ev), !(m3.ev) with | None, _, _, _ | _, None, _, _ | _, _, None, _ | _, _, _, None -> () - | Some v0, Some v1, Some v2, Some v3 -> eupdate (f v0 v1 v2 v3) m' c + | Some v0, Some v1, Some v2, Some v3 -> eupdate (f v0 v1 v2 v3) m' c in - add_dep m0 m'.enode; - add_dep m1 m'.enode; - add_dep m2 m'.enode; - add_dep m3 m'.enode; + add_dep m0 m'.enode; + add_dep m1 m'.enode; + add_dep m2 m'.enode; + add_dep m3 m'.enode; event m' p u - let l5 f e0 e1 e2 e3 e4 = match e0, e1, e2, e3, e4 with - | Never, _, _, _, _ -> Never + let l5 f e0 e1 e2 e3 e4 = match e0, e1, e2, e3, e4 with + | Never, _, _, _, _ -> Never | _, Never, _, _, _ -> Never | _, _, Never, _, _ -> Never | _, _, _, Never, _ -> Never | _, _, _, _, Never -> Never - | Emut m0, Emut m1, Emut m2, Emut m3, Emut m4 -> - let r = + | Emut m0, Emut m1, Emut m2, Emut m3, Emut m4 -> + let r = rsucc (rmax (rmax (rmax m0.enode m1.enode) (rmax m2.enode m3.enode)) m4.enode) - in - let m' = emut r in - let rec p () = [ m0.enode; m1.enode; m2.enode; m3.enode; m4.enode ] in - let u c = match !(m0.ev), !(m1.ev), !(m2.ev), !(m3.ev), !(m4.ev) with + in + let m' = emut r in + let rec p () = [ m0.enode; m1.enode; m2.enode; m3.enode; m4.enode ] in + let u c = match !(m0.ev), !(m1.ev), !(m2.ev), !(m3.ev), !(m4.ev) with | None, _, _, _, _ | _, None, _, _, _ | _, _, None, _, _ | _, _, _, None, _ | _, _, _, _, None -> () - | Some v0, Some v1, Some v2, Some v3, Some v4 -> - eupdate (f v0 v1 v2 v3 v4) m' c + | Some v0, Some v1, Some v2, Some v3, Some v4 -> + eupdate (f v0 v1 v2 v3 v4) m' c in - add_dep m0 m'.enode; - add_dep m1 m'.enode; - add_dep m2 m'.enode; - add_dep m3 m'.enode; - add_dep m4 m'.enode; + add_dep m0 m'.enode; + add_dep m1 m'.enode; + add_dep m2 m'.enode; + add_dep m3 m'.enode; + add_dep m4 m'.enode; event m' p u - let l6 f e0 e1 e2 e3 e4 e5 = match e0, e1, e2, e3, e4, e5 with - | Never, _, _, _, _, _ -> Never + let l6 f e0 e1 e2 e3 e4 e5 = match e0, e1, e2, e3, e4, e5 with + | Never, _, _, _, _, _ -> Never | _, Never, _, _, _, _ -> Never | _, _, Never, _, _, _ -> Never | _, _, _, Never, _, _ -> Never | _, _, _, _, Never, _ -> Never | _, _, _, _, _, Never -> Never - | Emut m0, Emut m1, Emut m2, Emut m3, Emut m4, Emut m5 -> - let r = + | Emut m0, Emut m1, Emut m2, Emut m3, Emut m4, Emut m5 -> + let r = rsucc (rmax (rmax (rmax m0.enode m1.enode) (rmax m2.enode m3.enode)) (rmax m4.enode m5.enode)) - in - let m' = emut r in - let rec p () = [ m0.enode; m1.enode; m2.enode; m3.enode; m4.enode; - m5.enode; ] in - let u c = match !(m0.ev), !(m1.ev), !(m2.ev), !(m3.ev), !(m4.ev), - !(m5.ev) with + in + let m' = emut r in + let rec p () = [ m0.enode; m1.enode; m2.enode; m3.enode; m4.enode; + m5.enode; ] in + let u c = match !(m0.ev), !(m1.ev), !(m2.ev), !(m3.ev), !(m4.ev), + !(m5.ev) with | None, _, _, _, _, _ | _, None, _, _, _, _ | _, _, None, _, _, _ | _, _, _, None, _, _ | _, _, _, _, None, _ | _, _, _, _, _, None -> () - | Some v0, Some v1, Some v2, Some v3, Some v4, Some v5 -> - eupdate (f v0 v1 v2 v3 v4 v5) m' c + | Some v0, Some v1, Some v2, Some v3, Some v4, Some v5 -> + eupdate (f v0 v1 v2 v3 v4 v5) m' c in - add_dep m0 m'.enode; - add_dep m1 m'.enode; - add_dep m2 m'.enode; - add_dep m3 m'.enode; - add_dep m4 m'.enode; - add_dep m5 m'.enode; + add_dep m0 m'.enode; + add_dep m1 m'.enode; + add_dep m2 m'.enode; + add_dep m3 m'.enode; + add_dep m4 m'.enode; + add_dep m5 m'.enode; event m' p u - (* Pervasives support *) + (* Pervasives support *) module Option = struct - let some e = map (fun v -> Some v) e - let value ?default e = match default with + let some e = map (fun v -> Some v) e + let value ?default e = match default with | None -> fmap (fun v -> v) e | Some (Const dv) -> map (function None -> dv | Some v -> v) e - | Some (Smut ms) -> - match e with + | Some (Smut ms) -> + match e with | Never -> Never | Emut m -> - let m' = emut (rsucc2 m.enode ms.snode) in + let m' = emut (rsucc2 m.enode ms.snode) in let rec p () = [ m.enode; ms.snode ] - and u c = match !(m.ev) with + and u c = match !(m.ev) with | None -> () (* ms updated. *) - | Some None -> eupdate (sval ms) m' c + | Some None -> eupdate (sval ms) m' c | Some Some v -> eupdate v m' c in - add_dep m m'.enode; - Node.add_dep ms.snode m'.enode; + add_dep m m'.enode; + Node.add_dep ms.snode m'.enode; event m' p u end end module S = struct type 'a t = 'a signal - + let set_sval v m c = m.sv <- Some v; Step.add_deps c m.snode let set m ?step v = (* starts an update step. *) if m.eq (sval m) v then () else - match step with - | Some c -> + match step with + | Some c -> if c.over then invalid_arg err_step_executed else if not m.snode.stamp.over then invalid_arg err_signal_scheduled else - m.snode.stamp <- c; - m.sv <- Some v; + m.snode.stamp <- c; + m.sv <- Some v; Step.add_deps c m.snode - | None -> + | None -> let c = Step.create () in m.snode.stamp <- c; - m.sv <- Some v; + m.sv <- Some v; Step.add_deps c m.snode; Step.execute c - + + let end_of_step_add_dep ?(post_add_op = fun () -> ()) ~stop_if_stopped m m' = + (* In some combinators, when the semantics of event m' is such + that it should not occur in the (potential) step it is created, + we add the dependency [m'] to signal [m] only via an end of + step operation to avoid being scheduled in the step. *) + match Step.find_unfinished (m.snode.producers ()) with + | c when c == Step.nil -> + Node.add_dep m.snode m'.enode; + post_add_op (); + | c -> + let add_dep () = + if m.snode.update == Node.nop then + (* m stopped in step *) + (if stop_if_stopped then Node.stop m'.enode) + else + begin + ignore (Node.update_rank m'.enode (rsucc m.snode)); + Node.add_dep m.snode m'.enode; + post_add_op (); + end + in + Step.add_eop c add_dep + (* Basics *) - + let const v = Const v - let create ?(eq = ( = )) v = + let create ?(eq = ( = )) v = let m = smut Node.min_rank eq in m.sv <- Some v; Smut m, set m - - let retain s c = match s with + + let retain s c = match s with | Const _ -> invalid_arg err_retain_cst_sig | Smut m -> let c' = m.snode.retain in m.snode.retain <- c; (`R c') - + let eq_fun = function Const _ -> None | Smut m -> Some m.eq - let value = function + let value = function | Const v | Smut { sv = Some v } -> v | Smut { sv = None } -> failwith err_sig_undef - - let stop ?strong = + + let stop ?strong = function Const _ -> () | Smut m -> Node.stop ?strong m.snode let equal ?(eq = ( = )) s s' = match s, s' with | Const v, Const v' -> eq v v' | Const _, _ | _, Const _ -> false | Smut m, Smut m' -> m == m' - + let trace ?(iff = const true) t s = match iff with | Const false -> s - | Const true -> - begin match s with + | Const true -> + begin match s with | Const v -> t v; s - | Smut m -> - let m' = smut (rsucc m.snode) m.eq in + | Smut m -> + let m' = smut (rsucc m.snode) m.eq in let rec p () = [ m.snode ] in let u c = let v = sval m in t v; supdate v m' c in Node.add_dep m.snode m'.snode; signal m' p u end - | Smut mc -> - match s with - | Const v -> - let m' = smut (rsucc mc.snode) ( = ) (* we don't care about eq *) in + | Smut mc -> + match s with + | Const v -> + let m' = smut (rsucc mc.snode) ( = ) (* we don't care about eq *) in let rec p () = [ mc.snode ] - and u c = - if (sval mc) then t v; - Node.rem_dep mc.snode m'.snode; + and u c = + if (sval mc) then t v; + Node.rem_dep mc.snode m'.snode; Node.stop m'.snode; in Node.add_dep mc.snode m'.snode; @@ -995,210 +1018,188 @@ module S = struct | Smut m -> let m' = smut (rsucc2 mc.snode m.snode) m.eq in let rec p () = [ mc.snode; m.snode ] - and u c = + and u c = let v = sval m in - match m'.sv with + match m'.sv with | Some v' when m'.eq v v' -> () (* mc updated. *) | _ -> if (sval mc) then t v; supdate v m' c (* init or diff. *) in Node.add_dep mc.snode m'.snode; Node.add_dep m.snode m'.snode; signal m' p u - + (* From events *) - + let hold ?(eq = ( = )) i = function | Never -> Const i | Emut m -> let m' = smut (rsucc m.enode) eq in - let rec p () = [ m.enode ] + let rec p () = [ m.enode ] and u c = match !(m.ev) with | None -> () (* init. only. *) - | Some v -> supdate v m' c + | Some v -> supdate v m' c in E.add_dep m m'.snode; signal ~i m' p u - + (* Filtering and transforming *) - + let map ?(eq = ( = )) f = function | Const v -> Const (f v) - | Smut m -> + | Smut m -> let m' = smut (rsucc m.snode) eq in - let rec p () = [ m.snode ] + let rec p () = [ m.snode ] and u c = supdate (f (sval m)) m' c in Node.add_dep m.snode m'.snode; signal m' p u - + let app ?(eq = ( = )) sf sv = match sf, sv with - | Smut mf, Smut mv -> - let m' = smut (rsucc2 mf.snode mv.snode) eq in - let rec p () = [ mf.snode; mv.snode ] + | Smut mf, Smut mv -> + let m' = smut (rsucc2 mf.snode mv.snode) eq in + let rec p () = [ mf.snode; mv.snode ] and u c = supdate ((sval mf) (sval mv)) m' c in Node.add_dep mf.snode m'.snode; Node.add_dep mv.snode m'.snode; signal m' p u | Const f, Const v -> Const (f v) | Const f, sv -> map ~eq f sv - | Smut mf, Const v -> - let m' = smut (rsucc mf.snode) eq in + | Smut mf, Const v -> + let m' = smut (rsucc mf.snode) eq in let rec p () = [ mf.snode ] - and u c = supdate ((sval mf) v) m' c in + and u c = supdate ((sval mf) v) m' c in Node.add_dep mf.snode m'.snode; signal m' p u let filter ?(eq = ( = )) pred i = function - | Const v as s -> if pred v then s else Const i + | Const v as s -> if pred v then s else Const i | Smut m -> - let m' = smut (rsucc m.snode) eq in - let rec p () = [ m.snode ] + let m' = smut (rsucc m.snode) eq in + let rec p () = [ m.snode ] and u c = let v = sval m in if pred v then supdate v m' c else () in Node.add_dep m.snode m'.snode; signal ~i m' p u - + let fmap ?(eq = ( = )) fm i = function | Const v -> (match fm v with Some v' -> Const v' | None -> Const i) | Smut m -> - let m' = smut (rsucc m.snode) eq in - let rec p () = [ m.snode ] - and u c = match fm (sval m) with Some v -> supdate v m' c | None -> () + let m' = smut (rsucc m.snode) eq in + let rec p () = [ m.snode ] + and u c = match fm (sval m) with Some v -> supdate v m' c | None -> () in Node.add_dep m.snode m'.snode; signal ~i m' p u - + let diff d = function | Const _ -> Never | Smut m -> - let m' = emut (rsucc m.snode) in + let m' = emut (rsucc m.snode) in let last = ref None in - let rec p () = [ m.snode ] - and u c = - let v = sval m in - match !last with + let rec p () = [ m.snode ] + and u c = + let v = sval m in + match !last with | Some v' -> last := Some v; eupdate (d v v') m' c | None -> assert false in - begin match Step.find_unfinished (m.snode.producers ()) with - | c when c == Step.nil -> - Node.add_dep m.snode m'.enode; last := Some (sval m) - | c -> (* In a step, m' cannot occur in that step (cf. semantics). - Dep. added at the end of step to avoid being scheduled. *) - let setup () = - if m.snode.update == Node.nop then - () (* m stopped in step *) - else - (Node.add_dep m.snode m'.enode; last := Some (sval m)) - in - Step.add_eop c setup - end; + let post_add_op () = last := Some (sval m) in + end_of_step_add_dep ~post_add_op ~stop_if_stopped:true m m'; event m' p u - + let changes = function | Const _ -> Never | Smut m -> let m' = emut (rsucc m.snode) in let rec p () = [ m.snode ] and u c = eupdate (sval m) m' c in - begin match Step.find_unfinished (m.snode.producers ()) with - | c when c == Step.nil -> Node.add_dep m.snode m'.enode - | c -> (* In a step, m' cannot occur in that step (cf. semantics). - Dep. added at the end of step to avoid being scheduled. *) - let setup () = - if m.snode.update == Node.nop then - () (* m stopped in step *) - else - (Node.add_dep m.snode m'.enode) - in - Step.add_eop c setup - end; + end_of_step_add_dep ~stop_if_stopped:true m m'; event m' p u - + let sample f e = function - | Const v -> E.map (fun ev -> f ev v) e - | Smut ms -> + | Const v -> E.map (fun ev -> f ev v) e + | Smut ms -> match e with | Never -> Never - | Emut me -> + | Emut me -> let m' = emut (rsucc2 me.enode ms.snode) in let rec p () = [ me.enode; ms.snode ] - and u c = match !(me.ev) with - | None -> () (* ms updated *) - | Some v -> eupdate (f v (sval ms)) m' c - in - E.add_dep me m'.enode; + and u c = match !(me.ev) with + | None -> () (* ms updated *) + | Some v -> eupdate (f v (sval ms)) m' c + in + E.add_dep me m'.enode; Node.add_dep ms.snode m'.enode; event m' p u - + let on ?(eq = ( = )) c i s = match c with | Const true -> s - | Const false -> Const i - | Smut mc -> + | Const false -> Const i + | Smut mc -> match s with | Const v -> let m' = smut (rsucc mc.snode) eq in - let rec p () = [ mc.snode ] + let rec p () = [ mc.snode ] and u c = if (sval mc) then supdate v m' c else () in Node.add_dep mc.snode m'.snode; signal ~i m' p u - | Smut ms -> - let m' = smut (rsucc2 mc.snode ms.snode) eq in - let rec p () = [ mc.snode; ms.snode ] - and u c = if (sval mc) then supdate (sval ms) m' c else () in + | Smut ms -> + let m' = smut (rsucc2 mc.snode ms.snode) eq in + let rec p () = [ mc.snode; ms.snode ] + and u c = if (sval mc) then supdate (sval ms) m' c else () in Node.add_dep mc.snode m'.snode; Node.add_dep ms.snode m'.snode; signal ~i m' p u let when_ = on - - let dismiss ?(eq = ( = )) c i s = match c with + + let dismiss ?(eq = ( = )) c i s = match c with | Never -> s - | Emut mc -> + | Emut mc -> match s with - | Const v -> - let m' = smut (rsucc mc.enode) eq in - let rec p () = [ mc.enode ] - and u c = match !(mc.ev) with - | Some _ -> () | None -> supdate v m' c + | Const v -> + let m' = smut (rsucc mc.enode) eq in + let rec p () = [ mc.enode ] + and u c = match !(mc.ev) with + | Some _ -> () | None -> supdate v m' c in Node.add_dep mc.enode m'.snode; signal ~i m' p u | Smut ms -> - let m' = smut (rsucc2 mc.enode ms.snode) eq in - let rec p () = [ mc.enode; ms.snode ] - and u c = match !(mc.ev) with + let m' = smut (rsucc2 mc.enode ms.snode) eq in + let rec p () = [ mc.enode; ms.snode ] + and u c = match !(mc.ev) with | Some _ -> () | None -> supdate (sval ms) m' c in Node.add_dep mc.enode m'.snode; Node.add_dep ms.snode m'.snode; signal ~i m' p u - + (* Accumulating *) - + let accum ?(eq = ( = )) ef i = match ef with | Never -> Const i - | Emut m -> - let m' = smut (rsucc m.enode) eq in - let rec p () = [ m.enode ] + | Emut m -> + let m' = smut (rsucc m.enode) eq in + let rec p () = [ m.enode ] and u c = match !(m.ev) with | None -> () (* init only. *) - | Some v -> supdate (v (sval m')) m' c + | Some v -> supdate (v (sval m')) m' c in E.add_dep m m'.snode; signal ~i m' p u - let fold ?(eq = ( = )) f i = function + let fold ?(eq = ( = )) f i = function | Never -> Const i | Emut m -> - let m' = smut (rsucc m.enode) eq in + let m' = smut (rsucc m.enode) eq in let rec p () = [ m.enode ] and u c = match !(m.ev) with | None -> () (* init only. *) | Some v -> supdate (f (sval m') v) m' c in E.add_dep m m'.snode; signal ~i m' p u - + (* Combining *) - + let merge ?(eq = ( = )) f a sl = let rmax' acc = function Const _ -> acc | Smut m -> rmax acc m.snode in let nodes acc = function Const _ -> acc | Smut m -> m.snode :: acc in @@ -1209,66 +1210,75 @@ module S = struct let dep = function Const _ -> ()| Smut m -> Node.add_dep m.snode m'.snode in List.iter dep sl; signal m' p u - + let switch ?(eq = ( = )) = function | Const s -> s - | Smut mss -> - let src = ref (sval mss) in (* current signal source. *) - let r = match !src with - | Smut ms -> rsucc2 ms.snode mss.snode | Const _ -> rsucc mss.snode - in - let m' = smut r eq in + | Smut mss -> + let dummy = smut Node.min_rank eq in + let src = ref (Smut dummy) in (* dummy is overwritten by sig. init *) + let m' = smut (rsucc mss.snode) eq in let rec p () = match !src with | Smut m -> [ mss.snode; m.snode] | Const _ -> [ mss.snode ] - and u c = + and u c = if (sval mss) == !src then (* ss didn't change, !src did *) - begin match !src with + begin match !src with | Smut m -> supdate (sval m) m' c | Const _ -> () (* init only. *) - end + end else (* ss changed *) - begin - begin match !src with - | Smut m -> Node.rem_dep m.snode m'.snode + begin + begin match !src with + | Smut m -> Node.rem_dep m.snode m'.snode | Const _ -> () end; - let new_src = sval mss in - src := new_src; - match new_src with - | Const v -> - ignore (Node.update_rank m'.snode (rsucc mss.snode)); + let new_src = sval mss in + src := new_src; + match new_src with + | Const v -> + ignore (Node.update_rank m'.snode (rsucc mss.snode)); supdate v m' c - | Smut m -> - Node.add_dep m.snode m'.snode; + | Smut m -> + Node.add_dep m.snode m'.snode; + if c == Step.nil then + begin + ignore (Node.update_rank m'.snode + (rsucc2 m.snode mss.snode)); + (* Check if the init src is in a step. *) + match Step.find_unfinished [m.snode] with + | c when c == Step.nil -> supdate (sval m) m' c + | c -> Step.add c m'.snode + end + else if Node.update_rank m'.snode (rsucc2 m.snode mss.snode) then - begin + begin (* Rank increased because of m. Thus m may still - update and we need to reschedule. Next time we + update and we need to reschedule. Next time we will be in the other branch. *) Step.allow_reschedule m'.snode; Step.rebuild c; Step.add c m'.snode end else - (* No rank increase. m already updated if needed. - No need to reschedule and rebuild the queue. *) + (* No rank increase. m already updated if needed, no need + to reschedule and rebuild the queue. *) supdate (sval m) m' c end in - Node.add_dep mss.snode m'.snode; - match !src with - | Const i -> signal ~i m' p u - | Smut m -> Node.add_dep m.snode m'.snode; signal m' p u - + Node.add_dep mss.snode m'.snode; + (* We add a dep to dummy to avoid a long scan of Wa.rem when we remove + the dep in the [u] function during static init. *) + Node.add_dep dummy.snode m'.snode; + signal m' p u + let bind ?eq s sf = switch ?eq (map ~eq:( == ) sf s) - let fix ?(eq = ( = )) i f = - let update_delayed n p u nl = + let fix ?(eq = ( = )) i f = + let update_delayed n p u nl = Node.bind n p u; match Step.find_unfinished nl with - | c when c == Step.nil -> + | c when c == Step.nil -> (* no pertinent occuring step, create a step for update. *) - let c = Step.create () in + let c = Step.create () in n.update c; Step.execute c | c -> Step.add c n @@ -1276,83 +1286,83 @@ module S = struct let m = smut Node.delayed_rank eq in let s = signal ~i m (fun () -> []) (fun _ -> ()) in match f s with - | Const v, r -> + | Const v, r -> let rec p () = [] - and u c = supdate v m c in + and u c = supdate v m c in update_delayed m.snode p u (Node.deps m.snode); r - | Smut m', r -> + | Smut m', r -> if m'.snode.rank = Node.delayed_rank then invalid_arg err_fix; let rec p () = [ (* avoid cyclic dep. *) ] and u c = supdate (sval m') m c in (* N.B. c is the next step. *) Node.add_dep m'.snode m.snode; update_delayed m.snode p u (m'.snode :: Node.deps m.snode); r - + (* Lifting *) - + let l1 = map let l2 ?(eq = ( = )) f s s' = match s, s' with - | Smut m0, Smut m1 -> - let m' = smut (rsucc2 m0.snode m1.snode) eq in + | Smut m0, Smut m1 -> + let m' = smut (rsucc2 m0.snode m1.snode) eq in let rec p () = [ m0.snode; m1.snode ] - and u c = supdate (f (sval m0) (sval m1)) m' c in + and u c = supdate (f (sval m0) (sval m1)) m' c in Node.add_dep m0.snode m'.snode; Node.add_dep m1.snode m'.snode; signal m' p u - | Const v, Const v' -> Const (f v v') - | Const v, Smut m -> + | Const v, Const v' -> Const (f v v') + | Const v, Smut m -> let m' = smut (rsucc m.snode) eq in let rec p () = [ m.snode ] - and u c = supdate (f v (sval m)) m' c in + and u c = supdate (f v (sval m)) m' c in Node.add_dep m.snode m'.snode; signal m' p u - | Smut m, Const v -> + | Smut m, Const v -> let m' = smut (rsucc m.snode) eq in let rec p () = [ m.snode ] - and u c = supdate (f (sval m) v) m' c in + and u c = supdate (f (sval m) v) m' c in Node.add_dep m.snode m'.snode; signal m' p u - + let l3 ?(eq = ( = )) f s0 s1 s2 = match s0, s1, s2 with - | Smut m0, Smut m1, Smut m2 -> + | Smut m0, Smut m1, Smut m2 -> let r = rsucc (rmax (rmax m0.snode m1.snode) m2.snode) in let m' = smut r eq in let rec p () = [ m0.snode; m1.snode; m2.snode ] - and u c = supdate (f (sval m0) (sval m1) (sval m2)) m' c in + and u c = supdate (f (sval m0) (sval m1) (sval m2)) m' c in Node.add_dep m0.snode m'.snode; Node.add_dep m1.snode m'.snode; Node.add_dep m2.snode m'.snode; signal m' p u | Const v0, Const v1, Const v2 -> Const (f v0 v1 v2) | s0, s1, s2 -> app ~eq (l2 ~eq:( == ) f s0 s1) s2 - - let l4 ?(eq = ( = )) f s0 s1 s2 s3 = match s0, s1, s2, s3 with - | Smut m0, Smut m1, Smut m2, Smut m3 -> + + let l4 ?(eq = ( = )) f s0 s1 s2 s3 = match s0, s1, s2, s3 with + | Smut m0, Smut m1, Smut m2, Smut m3 -> let r = rsucc (rmax (rmax m0.snode m1.snode) (rmax m2.snode m3.snode)) in let m' = smut r eq in let rec p () = [ m0.snode; m1.snode; m2.snode; m3.snode ] - and u c = supdate (f (sval m0) (sval m1) (sval m2) (sval m3)) m' c in + and u c = supdate (f (sval m0) (sval m1) (sval m2) (sval m3)) m' c in Node.add_dep m0.snode m'.snode; Node.add_dep m1.snode m'.snode; Node.add_dep m2.snode m'.snode; Node.add_dep m3.snode m'.snode; signal m' p u | Const v0, Const v1, Const v2, Const v3 -> Const (f v0 v1 v2 v3) - | s0, s1, s2, s3 -> app ~eq (l3 ~eq:( == ) f s0 s1 s2) s3 - - let l5 ?(eq = ( = )) f s0 s1 s2 s3 s4 = match s0, s1, s2, s3, s4 with - | Smut m0, Smut m1, Smut m2, Smut m3, Smut m4 -> + | s0, s1, s2, s3 -> app ~eq (l3 ~eq:( == ) f s0 s1 s2) s3 + + let l5 ?(eq = ( = )) f s0 s1 s2 s3 s4 = match s0, s1, s2, s3, s4 with + | Smut m0, Smut m1, Smut m2, Smut m3, Smut m4 -> let m = rmax in - let r = rsucc (m (m m0.snode m1.snode) - (m m2.snode (m m3.snode m4.snode))) + let r = rsucc (m (m m0.snode m1.snode) + (m m2.snode (m m3.snode m4.snode))) in let m' = smut r eq in let rec p () = [ m0.snode; m1.snode; m2.snode; m3.snode; m4.snode ] - and u c = + and u c = let v = f (sval m0) (sval m1) (sval m2) (sval m3) (sval m4) in supdate v m' c - in + in Node.add_dep m0.snode m'.snode; Node.add_dep m1.snode m'.snode; Node.add_dep m2.snode m'.snode; @@ -1360,21 +1370,21 @@ module S = struct Node.add_dep m4.snode m'.snode; signal m' p u | Const v0, Const v1, Const v2, Const v3, Const v4 -> Const (f v0 v1 v2 v3 v4) - | s0, s1, s2, s3, s4 -> app ~eq (l4 ~eq:( == ) f s0 s1 s2 s3) s4 - - let l6 ?(eq = ( = )) f s0 s1 s2 s3 s4 s5 = match s0, s1, s2, s3, s4, s5 with - | Smut m0, Smut m1, Smut m2, Smut m3, Smut m4, Smut m5 -> + | s0, s1, s2, s3, s4 -> app ~eq (l4 ~eq:( == ) f s0 s1 s2 s3) s4 + + let l6 ?(eq = ( = )) f s0 s1 s2 s3 s4 s5 = match s0, s1, s2, s3, s4, s5 with + | Smut m0, Smut m1, Smut m2, Smut m3, Smut m4, Smut m5 -> let m = rmax in - let m = m (m m0.snode (m m1.snode m2.snode)) + let m = m (m m0.snode (m m1.snode m2.snode)) (m m3.snode (m m4.snode m5.snode)) in let m' = smut (rsucc m) eq in - let rec p () = + let rec p () = [ m0.snode; m1.snode; m2.snode; m3.snode; m4.snode; m5.snode ] - and u c = + and u c = let v = f (sval m0) (sval m1) (sval m2) (sval m3) (sval m4) (sval m5) in - supdate v m' c - in + supdate v m' c + in Node.add_dep m0.snode m'.snode; Node.add_dep m1.snode m'.snode; Node.add_dep m2.snode m'.snode; @@ -1382,19 +1392,48 @@ module S = struct Node.add_dep m4.snode m'.snode; Node.add_dep m5.snode m'.snode; signal m' p u - | Const v0, Const v1, Const v2, Const v3, Const v4, Const v5-> + | Const v0, Const v1, Const v2, Const v3, Const v4, Const v5-> Const (f v0 v1 v2 v3 v4 v5) - | s0, s1, s2, s3, s4, s5 -> app ~eq (l5 ~eq:( == ) f s0 s1 s2 s3 s4) s5 - + | s0, s1, s2, s3, s4, s5 -> app ~eq (l5 ~eq:( == ) f s0 s1 s2 s3 s4) s5 + module Bool = struct let one = Const true let zero = Const false - let eq : bool -> bool -> bool = ( = ) + let eq : bool -> bool -> bool = ( = ) let not s = l1 ~eq not s - let ( && ) s s' = l2 ~eq ( && ) s s' + let ( && ) s s' = l2 ~eq ( && ) s s' let ( || ) s s' = l2 ~eq ( || ) s s' + + let edge s = changes s + let edge_detect edge = function + | Const _ -> Never + | Smut m -> + let m' = emut (rsucc m.snode) in + let rec p () = [ m.snode ] + and u c = if (sval m) = edge then eupdate () m' c in + end_of_step_add_dep ~stop_if_stopped:true m m'; + event m' p u + + let rise s = edge_detect true s + let fall s = edge_detect false s + let flip b = function + | Never -> Const b + | Emut m -> + let m' = smut (rsucc m.enode) ( = ) in + let rec p () = [ m.enode ] + and u c = supdate (Pervasives.not (sval m')) m' c in + E.add_dep m m'.snode; + (* can't use [signal] here because of semantics. *) + Node.bind m'.snode p u; + m'.sv <- Some b; + begin match Step.find_unfinished [m.enode] with + | c when c == Step.nil -> () + | c -> Step.add c m'.snode + end; + Smut m' + end - + module Int = struct let zero = Const 0 let one = Const 1 @@ -1402,7 +1441,7 @@ module S = struct let eq : int -> int -> bool = ( = ) let ( ~- ) s = l1 ~eq ( ~- ) s let succ s = l1 ~eq succ s - let pred s = l1 ~eq pred s + let pred s = l1 ~eq pred s let ( + ) s s' = l2 ~eq ( + ) s s' let ( - ) s s' = l2 ~eq ( - ) s s' let ( * ) s s' = l2 ~eq ( * ) s s' @@ -1418,10 +1457,10 @@ module S = struct let ( lsr ) s s' = l2 ~eq ( lsr ) s s' let ( asr ) s s' = l2 ~eq ( asr ) s s' end - + module Float = struct - let zero = Const 0. - let one = Const 1. + let zero = Const 0. + let one = Const 1. let minus_one = Const (-1.) let eq : float -> float -> bool = ( = ) let ( ~-. ) s = l1 ~eq ( ~-. ) s @@ -1458,12 +1497,12 @@ module S = struct let infinity = const infinity let neg_infinity = const neg_infinity let nan = const nan - let max_float = const max_float + let max_float = const max_float let min_float = const min_float let epsilon_float = const epsilon_float let classify_float s = l1 ~eq:( = ) classify_float s end - + module Pair = struct let pair ?eq s s' = l2 ?eq (fun x y -> x, y) s s' let fst ?eq s = l1 ?eq fst s @@ -1472,85 +1511,85 @@ module S = struct module Option = struct let none = Const None - let some s = - let eq = match eq_fun s with - | None -> None - | Some eq -> - let eq v v' = match v, v' with + let some s = + let eq = match eq_fun s with + | None -> None + | Some eq -> + let eq v v' = match v, v' with | Some v, Some v' -> eq v v' - | _ -> assert false + | _ -> assert false in Some eq in map ?eq (fun v -> Some v) s - let value ?(eq = ( = )) ~default s = match s with + let value ?(eq = ( = )) ~default s = match s with | Const (Some v) -> Const v - | Const None -> - let d = match default with `Init d -> d | `Always d -> d in - begin match d with - | Const d -> Const d + | Const None -> + let d = match default with `Init d -> d | `Always d -> d in + begin match d with + | Const d -> Const d | Smut md -> - match Step.find_unfinished [md.snode] with + match Step.find_unfinished [md.snode] with | c when c == Step.nil -> Const (sval md) | c -> let m' = smut (rsucc md.snode) eq in - let rec p () = [ md.snode ] - and u c = + let rec p () = [ md.snode ] + and u c = Node.rem_dep md.snode m'.snode; supdate (sval md) m' c; Node.stop m'.snode in - Node.add_dep md.snode m'.snode; + Node.add_dep md.snode m'.snode; signal m' p u end | Smut m -> - match default with + match default with | `Init (Const d) -> fmap ~eq (fun v -> v) d s | `Always (Const d) -> map ~eq (function None -> d | Some v -> v) s | `Init (Smut md) -> - begin match Step.find_unfinished [md.snode] with - | c when c == Step.nil -> + begin match Step.find_unfinished [md.snode] with + | c when c == Step.nil -> let m' = smut (rsucc m.snode) eq in - let rec p () = [ m.snode ] - and u c = match sval m with - | Some v -> supdate v m' c | None -> () + let rec p () = [ m.snode ] + and u c = match sval m with + | Some v -> supdate v m' c | None -> () in - Node.add_dep m.snode m'.snode; - signal ~i:(sval md) m' p u - | c -> - let m' = smut (rsucc2 m.snode md.snode) eq in - let rec p () = [ m.snode ] in (* subsequent updates *) - let u c = match sval m with + Node.add_dep m.snode m'.snode; + signal ~i:(sval md) m' p u + | c -> + let m' = smut (rsucc2 m.snode md.snode) eq in + let rec p () = [ m.snode ] in (* subsequent updates *) + let u c = match sval m with | Some v -> supdate v m' c | None -> () in let rec p_first () = [ m.snode; md.snode ] in (* first update *) - let u_first c = - Node.rem_dep md.snode m'.snode; - begin match sval m with - | None -> supdate (sval md) m' c - | Some v -> supdate v m' c + let u_first c = + Node.rem_dep md.snode m'.snode; + begin match sval m with + | None -> supdate (sval md) m' c + | Some v -> supdate v m' c end; Node.bind m'.snode p u in - Node.add_dep m.snode m'.snode; - Node.add_dep md.snode m'.snode; + Node.add_dep m.snode m'.snode; + Node.add_dep md.snode m'.snode; signal m' p_first u_first end | `Always (Smut md) -> - let m' = smut (rsucc2 m.snode md.snode) eq in - let rec p () = [ m.snode; md.snode ] in - let u c = match sval m with - | Some v -> supdate v m' c - | None -> supdate (sval md) m' c + let m' = smut (rsucc2 m.snode md.snode) eq in + let rec p () = [ m.snode; md.snode ] in + let u c = match sval m with + | Some v -> supdate v m' c + | None -> supdate (sval md) m' c in - Node.add_dep m.snode m'.snode; - Node.add_dep md.snode m'.snode; + Node.add_dep m.snode m'.snode; + Node.add_dep md.snode m'.snode; signal m' p u end - module Compare = struct - let eq = Bool.eq + module Compare = struct + let eq = Bool.eq let ( = ) s s' = l2 ~eq ( = ) s s' let ( <> ) s s' = l2 ~eq ( <> ) s s' let ( < ) s s' = l2 ~eq ( < ) s s' @@ -1560,49 +1599,49 @@ module S = struct let compare s s' = l2 ~eq:Int.eq compare s s' let ( == ) s s' = l2 ~eq ( == ) s s' let ( != ) s s' = l2 ~eq ( != ) s s' - end - + end + (* Combinator specialization *) module type EqType = sig - type 'a t - val equal : 'a t -> 'a t -> bool + type 'a t + val equal : 'a t -> 'a t -> bool end - + module type S = sig - type 'a v + type 'a v val create : 'a v -> 'a v signal * (?step:step -> 'a v -> unit) val equal : 'a v signal -> 'a v signal -> bool val hold : 'a v -> 'a v event -> 'a v signal val app : ('a -> 'b v) signal -> 'a signal -> 'b v signal val map : ('a -> 'b v) -> 'a signal -> 'b v signal - val filter : ('a v -> bool) -> 'a v -> 'a v signal -> 'a v signal + val filter : ('a v -> bool) -> 'a v -> 'a v signal -> 'a v signal val fmap : ('a -> 'b v option) -> 'b v -> 'a signal -> 'b v signal val when_ : bool signal -> 'a v -> 'a v signal -> 'a v signal val dismiss : 'b event -> 'a v -> 'a v signal -> 'a v signal - val accum : ('a v -> 'a v) event -> 'a v -> 'a v signal + val accum : ('a v -> 'a v) event -> 'a v -> 'a v signal val fold : ('a v -> 'b -> 'a v) -> 'a v -> 'b event -> 'a v signal val merge : ('a v -> 'b -> 'a v) -> 'a v -> 'b signal list -> 'a v signal val switch : 'a v signal signal -> 'a v signal val bind : 'b signal -> ('b -> 'a v signal) -> 'a v signal val fix : 'a v -> ('a v signal -> 'a v signal * 'b) -> 'b val l1 : ('a -> 'b v) -> ('a signal -> 'b v signal) - val l2 : ('a -> 'b -> 'c v) -> ('a signal -> 'b signal -> 'c v signal) - val l3 : ('a -> 'b -> 'c -> 'd v) -> ('a signal -> 'b signal -> 'c signal - -> 'd v signal) - val l4 : ('a -> 'b -> 'c -> 'd -> 'e v) -> - ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e v signal) - val l5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f v) -> - ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> - 'f v signal) - val l6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g v) -> - ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> - 'f signal -> 'g v signal) + val l2 : ('a -> 'b -> 'c v) -> ('a signal -> 'b signal -> 'c v signal) + val l3 : ('a -> 'b -> 'c -> 'd v) -> ('a signal -> 'b signal -> 'c signal + -> 'd v signal) + val l4 : ('a -> 'b -> 'c -> 'd -> 'e v) -> + ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e v signal) + val l5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f v) -> + ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> + 'f v signal) + val l6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g v) -> + ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> + 'f signal -> 'g v signal) end - + module Make (Eq : EqType) = struct type 'a v = 'a Eq.t - let eq = Eq.equal + let eq = Eq.equal let create v = create ~eq v let equal s s' = equal ~eq s s' let hold v e = hold ~eq v e @@ -1611,21 +1650,21 @@ module S = struct let filter pred i = filter ~eq pred i let fmap fm i = fmap ~eq fm i let when_ c i s = when_ ~eq c i s - let dismiss c s = dismiss ~eq c s + let dismiss c s = dismiss ~eq c s let accum ef i = accum ~eq ef i let fold f i = fold ~eq f i let merge f a sl = merge ~eq f a sl let switch s = switch ~eq s let bind s sf = bind ~eq s sf let fix f = fix ~eq f - let l1 = map + let l1 = map let l2 f s s' = l2 ~eq f s s' let l3 f s0 s1 s2 = l3 ~eq f s0 s1 s2 let l4 f s0 s1 s2 s3 = l4 ~eq f s0 s1 s2 s3 let l5 f s0 s1 s2 s3 s4 = l5 ~eq f s0 s1 s2 s3 s4 let l6 f s0 s1 s2 s3 s4 s5 = l6 ~eq f s0 s1 s2 s3 s4 s5 end - + module Special = struct module Sb = Make (struct type 'a t = bool let equal = Bool.eq end) module Si = Make (struct type 'a t = int let equal = Int.eq end) @@ -1640,7 +1679,7 @@ end Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. diff --git a/src/react.mli b/src/react.mli index e54061d..90fb6cf 100644 --- a/src/react.mli +++ b/src/react.mli @@ -1,7 +1,7 @@ (*--------------------------------------------------------------------------- Copyright (c) 2009 Daniel C. Bünzli. All rights reserved. Distributed under a BSD3 license, see license at the end of the file. - react release 1.1.0 + react release 1.2.0 ---------------------------------------------------------------------------*) (** Declarative events and signals. @@ -16,8 +16,8 @@ {{!ex}examples}. Open the module to use it, this defines only two types and modules in your scope. - {e Release 1.1.0 - Daniel Bünzli <daniel.buenzl i\@erratique.ch> } *) - + {e Release 1.2.0 - Daniel Bünzli <daniel.buenzl i\@erratique.ch> } *) + (** {1 Interface} *) type 'a event @@ -26,10 +26,10 @@ type 'a event type 'a signal (** The type for signals of type ['a]. *) -type step -(** The type for update steps. *) +type step +(** The type for update steps. *) -(** Event combinators. +(** Event combinators. Consult their {{!evsem}semantics.} *) module E : sig @@ -42,17 +42,17 @@ module E : sig (** A never occuring event. For all t, \[[never]\]{_t} [= None]. *) val create : unit -> 'a event * (?step:step -> 'a -> unit) - (** [create ()] is a primitive event [e] and a [send] function. The + (** [create ()] is a primitive event [e] and a [send] function. The function [send] is such that: {ul - {- [send v] generates an occurrence [v] of [e] at the time it is called + {- [send v] generates an occurrence [v] of [e] at the time it is called and triggers an {{!steps}update step}.} - {- [send ~step v] generates an occurence [v] of [e] on the step [step] + {- [send ~step v] generates an occurence [v] of [e] on the step [step] when [step] is {{!Step.execute}executed}.} - {- [send ~step v] raises [Invalid_argument] if it was previously - called with a step and this step has not executed yet or if + {- [send ~step v] raises [Invalid_argument] if it was previously + called with a step and this step has not executed yet or if the given [step] was already executed.}} - + {b Warning.} [send] must not be executed inside an update step. *) val retain : 'a event -> (unit -> unit) -> [ `R of (unit -> unit) ] @@ -64,12 +64,12 @@ module E : sig val stop : ?strong:bool -> 'a event -> unit (** [stop e] stops [e] from occuring. It conceptually becomes - {!never} and cannot be restarted. Allows to - disable {{!sideeffects}effectful} events. + {!never} and cannot be restarted. Allows to + disable {{!sideeffects}effectful} events. The [strong] argument should only be used on platforms - where weak arrays have a strong semantics (i.e. JavaScript). - See {{!strongstop}details}. + where weak arrays have a strong semantics (i.e. JavaScript). + See {{!strongstop}details}. {b Note.} If executed in an {{!steps}update step} the event may still occur in the step. *) @@ -89,14 +89,14 @@ module E : sig val once : 'a event -> 'a event (** [once e] is [e] with only its next occurence. {ul - {- \[[once e]\]{_t} [= Some v] if \[[e]\]{_t} [= Some v] and + {- \[[once e]\]{_t} [= Some v] if \[[e]\]{_t} [= Some v] and \[[e]\]{_<t} [= None].} {- \[[once e]\]{_t} [= None] otherwise.}} *) - + val drop_once : 'a event -> 'a event - (** [drop_once e] is [e] without its next occurrence. + (** [drop_once e] is [e] without its next occurrence. {ul - {- \[[drop_once e]\]{_t} [= Some v] if \[[e]\]{_t} [= Some v] and + {- \[[drop_once e]\]{_t} [= Some v] if \[[e]\]{_t} [= Some v] and \[[e]\]{_<t} [= Some _].} {- \[[drop_once e]\]{_t} [= None] otherwise.}} *) @@ -104,8 +104,8 @@ module E : sig (** [app ef e] occurs when both [ef] and [e] occur {{!simultaneity}simultaneously}. The value is [ef]'s occurence applied to [e]'s one. - {ul - {- \[[app ef e]\]{_t} [= Some v'] if \[[ef]\]{_t} [= Some f] and + {ul + {- \[[app ef e]\]{_t} [= Some v'] if \[[ef]\]{_t} [= Some f] and \[[e]\]{_t} [= Some v] and [f v = v'].} {- \[[app ef e]\]{_t} [= None] otherwise.}} *) @@ -119,9 +119,9 @@ module E : sig (** [stamp e v] is [map (fun _ -> v) e]. *) val filter : ('a -> bool) -> 'a event -> 'a event - (** [filter p e] are [e]'s occurrences that satisfy [p]. + (** [filter p e] are [e]'s occurrences that satisfy [p]. {ul - {- \[[filter p e]\]{_t} [= Some v] if \[[e]\]{_t} [= Some v] and + {- \[[filter p e]\]{_t} [= Some v] if \[[e]\]{_t} [= Some v] and [p v = true]} {- \[[filter p e]\]{_t} [= None] otherwise.}} *) @@ -131,7 +131,7 @@ module E : sig {- \[[fmap fm e]\]{_t} [= Some v] if [fm] \[[e]\]{_t} [= Some v]} {- \[[fmap fm e]\]{_t} [= None] otherwise.}} *) - val diff : ('a -> 'a -> 'b) -> 'a event -> 'b event + val diff : ('a -> 'a -> 'b) -> 'a event -> 'b event (** [diff f e] occurs whenever [e] occurs except on the next occurence. Occurences are [f v v'] where [v] is [e]'s current occurrence and [v'] the previous one. @@ -141,55 +141,55 @@ module E : sig {- \[[diff f e]\]{_t} [= None] otherwise.}} *) val changes : ?eq:('a -> 'a -> bool) -> 'a event -> 'a event - (** [changes eq e] is [e]'s occurrences with occurences equal to + (** [changes eq e] is [e]'s occurrences with occurences equal to the previous one dropped. Equality is tested with [eq] (defaults to structural equality). {ul {- \[[changes eq e]\]{_t} [= Some v] if \[[e]\]{_t} [= Some v] - and either \[[e]\]{_<t} [= None] or \[[e]\]{_<t} [= Some v'] and + and either \[[e]\]{_<t} [= None] or \[[e]\]{_<t} [= Some v'] and [eq v v' = false].} {- \[[changes eq e]\]{_t} [= None] otherwise.}} *) val on : bool signal -> 'a event -> 'a event - (** [on c e] is the occurrences of [e] when [c] is [true]. - {ul - {- \[[on c e]\]{_t} [= Some v] + (** [on c e] is the occurrences of [e] when [c] is [true]. + {ul + {- \[[on c e]\]{_t} [= Some v] if \[[c]\]{_t} [= true] and \[[e]\]{_t} [= Some v].} {- \[[on c e]\]{_t} [= None] otherwise.}} *) val when_ : bool signal -> 'a event -> 'a event (** @deprecated Use {!on}. *) - val dismiss : 'b event -> 'a event -> 'a event - (** [dismiss c e] is the occurences of [e] except the ones when [c] occurs. + val dismiss : 'b event -> 'a event -> 'a event + (** [dismiss c e] is the occurences of [e] except the ones when [c] occurs. {ul - {- \[[dimiss c e]\]{_t} [= Some v] + {- \[[dimiss c e]\]{_t} [= Some v] if \[[c]\]{_t} [= None] and \[[e]\]{_t} [= Some v].} {- \[[dimiss c e]\]{_t} [= None] otherwise.}} *) val until : 'a event -> 'b event -> 'b event (** [until c e] is [e]'s occurences until [c] occurs. - {ul + {ul {- \[[until c e]\]{_t} [= Some v] if \[[e]\]{_t} [= Some v] and \[[c]\]{_<=t} [= None]} {- \[[until c e]\]{_t} [= None] otherwise.}} *) (** {1:accum Accumulating} *) - val accum : ('a -> 'a) event -> 'a -> 'a event + val accum : ('a -> 'a) event -> 'a -> 'a event (** [accum ef i] accumulates a value, starting with [i], using [e]'s functional occurrences. - {ul + {ul {- \[[accum ef i]\]{_t} [= Some (f i)] if \[[ef]\]{_t} [= Some f] and \[[ef]\]{_<t} [= None]. } - {- \[[accum ef i]\]{_t} [= Some (f acc)] if \[[ef]\]{_t} [= Some f] + {- \[[accum ef i]\]{_t} [= Some (f acc)] if \[[ef]\]{_t} [= Some f] and \[[accum ef i]\]{_<t} [= Some acc].} {- \[[accum ef i]\] [= None] otherwise.}} *) val fold : ('a -> 'b -> 'a) -> 'a -> 'b event -> 'a event - (** [fold f i e] accumulates [e]'s occurrences with [f] starting with [i]. - {ul + (** [fold f i e] accumulates [e]'s occurrences with [f] starting with [i]. + {ul {- \[[fold f i e]\]{_t} [= Some (f i v)] if \[[e]\]{_t} [= Some v] and \[[e]\]{_<t} [= None].} {- \[[fold f i e]\]{_t} [= Some (f acc v)] if @@ -199,29 +199,29 @@ module E : sig (** {1:combine Combining} *) val select : 'a event list -> 'a event - (** [select el] is the occurrences of every event in [el]. + (** [select el] is the occurrences of every event in [el]. If more than one event occurs {{!simultaneity}simultaneously} the leftmost is taken and the others are lost. {ul - {- \[[select el]\]{_ t} [=] \[[List.find (fun e -> ]\[[e]\]{_t} + {- \[[select el]\]{_ t} [=] \[[List.find (fun e -> ]\[[e]\]{_t} [<> None) el]\]{_t}}. {- \[[select el]\]{_ t} [= None] otherwise.}} *) val merge : ('a -> 'b -> 'a) -> 'a -> 'b event list -> 'a event (** [merge f a el] merges the {{!simultaneity}simultaneous} occurrences of every event in [el] using [f] and the accumulator [a]. - - \[[merge f a el]\]{_ t} - [= List.fold_left f a (List.filter (fun o -> o <> None) + + \[[merge f a el]\]{_ t} + [= List.fold_left f a (List.filter (fun o -> o <> None) (List.map] \[\]{_t}[ el))]. *) - val switch : 'a event -> 'a event event -> 'a event - (** [switch e ee] is [e]'s occurrences until there is an + val switch : 'a event -> 'a event event -> 'a event + (** [switch e ee] is [e]'s occurrences until there is an occurrence [e'] on [ee], the occurrences of [e'] are then used - until there is a new occurrence on [ee], etc.. + until there is a new occurrence on [ee], etc.. {ul {- \[[switch e ee]\]{_ t} [=] \[[e]\]{_t} if \[[ee]\]{_<=t} [= None].} - {- \[[switch e ee]\]{_ t} [=] \[[e']\]{_t} if \[[ee]\]{_<=t} + {- \[[switch e ee]\]{_ t} [=] \[[e']\]{_t} if \[[ee]\]{_<=t} [= Some e'].}} *) val fix : ('a event -> 'a event * 'b) -> 'b @@ -234,50 +234,50 @@ module E : sig is such that : {ul {- \[[e]\]{_ t} [=] [None] if t = 0 } - {- \[[e]\]{_ t} [=] \[[e']\]{_t-dt} otherwise}} + {- \[[e]\]{_ t} [=] \[[e']\]{_t-dt} otherwise}} - {b Raises.} [Invalid_argument] if [e'] is directly a delayed event (i.e. + {b Raises.} [Invalid_argument] if [e'] is directly a delayed event (i.e. an event given to a fixing function). *) - (** {1 Lifting} + (** {1 Lifting} - Lifting combinators. For a given [n] the semantics is: + Lifting combinators. For a given [n] the semantics is: {ul - {- \[[ln f e1 ... en]\]{_t} [= Some (f v1 ... vn)] if for all + {- \[[ln f e1 ... en]\]{_t} [= Some (f v1 ... vn)] if for all i : \[[ei]\]{_t} [= Some vi].} - {- \[[ln f e1 ... en]\]{_t} [= None] otherwise.}} *) + {- \[[ln f e1 ... en]\]{_t} [= None] otherwise.}} *) - val l1 : ('a -> 'b) -> 'a event -> 'b event + val l1 : ('a -> 'b) -> 'a event -> 'b event val l2 : ('a -> 'b -> 'c) -> 'a event -> 'b event -> 'c event - val l3 : ('a -> 'b -> 'c -> 'd) -> 'a event -> 'b event -> 'c event -> + val l3 : ('a -> 'b -> 'c -> 'd) -> 'a event -> 'b event -> 'c event -> 'd event - val l4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a event -> 'b event -> 'c event -> - 'd event -> 'e event - val l5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 'a event -> 'b event -> - 'c event -> 'd event -> 'e event -> 'f event - val l6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) -> 'a event -> 'b event -> + val l4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a event -> 'b event -> 'c event -> + 'd event -> 'e event + val l5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 'a event -> 'b event -> + 'c event -> 'd event -> 'e event -> 'f event + val l6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) -> 'a event -> 'b event -> 'c event -> 'd event -> 'e event -> 'f event -> 'g event - (** {1 Pervasives support} *) + (** {1 Pervasives support} *) - (** Events with option occurences. *) + (** Events with option occurences. *) module Option : sig - val some : 'a event -> 'a option event - (** [some e] is [map (fun v -> Some v) e]. *) + val some : 'a event -> 'a option event + (** [some e] is [map (fun v -> Some v) e]. *) - val value : ?default:'a signal -> 'a option event -> 'a event + val value : ?default:'a signal -> 'a option event -> 'a event (** [value default e] either silences [None] occurences if [default] is unspecified or replaces them by the value of [default] at the occurence time. - {ul + {ul {- \[[value ~default e]\]{_t}[ = v] if \[[e]\]{_t} [= Some (Some v)].} {- \[[value ?default:None e]\]{_t}[ = None] if \[[e]\]{_t} = [None].} - {- \[[value ?default:(Some s) e]\]{_t}[ = v] + {- \[[value ?default:(Some s) e]\]{_t}[ = v] if \[[e]\]{_t} = [None] and \[[s]\]{_t} [= v].}} *) end end -(** Signal combinators. +(** Signal combinators. Consult their {{!sigsem}semantics.} *) module S : sig @@ -289,23 +289,23 @@ module S : sig val const : 'a -> 'a signal (** [const v] is always [v], \[[const v]\]{_t} [= v]. *) - val create : ?eq:('a -> 'a -> bool) -> 'a -> + val create : ?eq:('a -> 'a -> bool) -> 'a -> 'a signal * (?step:step -> 'a -> unit) (** [create i] is a primitive signal [s] set to [i] and a [set] function. The function [set] is such that: {ul - {- [set v] sets the signal's value to [v] at the time it is called and + {- [set v] sets the signal's value to [v] at the time it is called and triggers an {{!steps}update step}.} - {- [set ~step v] sets the signal's value to [v] at the time it is - called and updates it dependencies when [step] is + {- [set ~step v] sets the signal's value to [v] at the time it is + called and updates it dependencies when [step] is {{!Step.execute}executed}} - {- [set ~step v] raises [Invalid_argument] if it was previously - called with a step and this step has not executed yet or if + {- [set ~step v] raises [Invalid_argument] if it was previously + called with a step and this step has not executed yet or if the given [step] was already executed.}} {b Warning.} [set] must not be executed inside an update step. *) val value : 'a signal -> 'a - (** [value s] is [s]'s current value. + (** [value s] is [s]'s current value. {b Warning.} If executed in an {{!steps}update step} may return a non up-to-date value or raise [Failure] if @@ -328,10 +328,10 @@ module S : sig disable {{!sideeffects}effectful} signals. The [strong] argument should only be used on platforms - where weak arrays have a strong semantics (i.e. JavaScript). - See {{!strongstop}details}. + where weak arrays have a strong semantics (i.e. JavaScript). + See {{!strongstop}details}. - {b Note.} If executed in an update step the signal may + {b Note.} If executed in an update step the signal may still update in the step. *) val equal : ?eq:('a -> 'a -> bool) -> 'a signal -> 'a signal -> bool @@ -350,42 +350,42 @@ module S : sig (** {1 From events} *) val hold : ?eq:('a -> 'a -> bool) -> 'a -> 'a event -> 'a signal - (** [hold i e] has the value of [e]'s last occurrence or [i] if there + (** [hold i e] has the value of [e]'s last occurrence or [i] if there wasn't any. - {ul + {ul {- \[[hold i e]\]{_t} [= i] if \[[e]\]{_<=t} [= None]} {- \[[hold i e]\]{_t} [= v] if \[[e]\]{_<=t} [= Some v]}} *) (** {1:tr Transforming and filtering} *) - val app : ?eq:('b -> 'b -> bool) -> ('a -> 'b) signal -> 'a signal -> + val app : ?eq:('b -> 'b -> bool) -> ('a -> 'b) signal -> 'a signal -> 'b signal (** [app sf s] holds the value of [sf] applied - to the value of [s], \[[app sf s]\]{_t} + to the value of [s], \[[app sf s]\]{_t} [=] \[[sf]\]{_t} \[[s]\]{_t}. *) val map : ?eq:('b -> 'b -> bool) -> ('a -> 'b) -> 'a signal -> 'b signal (** [map f s] is [s] transformed by [f], \[[map f s]\]{_t} = [f] \[[s]\]{_t}. *) - val filter : ?eq:('a -> 'a -> bool) -> ('a -> bool) -> 'a -> 'a signal -> - 'a signal + val filter : ?eq:('a -> 'a -> bool) -> ('a -> bool) -> 'a -> 'a signal -> + 'a signal (** [filter f i s] is [s]'s values that satisfy [p]. If a value does not satisfy [p] it holds the last value that was satisfied or [i] if - there is none. + there is none. {ul {- \[[filter p s]\]{_t} [=] \[[s]\]{_t} if [p] \[[s]\]{_t}[ = true].} {- \[[filter p s]\]{_t} [=] \[[s]\]{_t'} if [p] \[[s]\]{_t}[ = false] and t' is the greatest t' < t with [p] \[[s]\]{_t'}[ = true].} {- \[[filter p e]\]{_t} [= i] otherwise.}} *) - val fmap : ?eq:('b -> 'b -> bool) -> ('a -> 'b option) -> 'b -> 'a signal -> - 'b signal + val fmap : ?eq:('b -> 'b -> bool) -> ('a -> 'b option) -> 'b -> 'a signal -> + 'b signal (** [fmap fm i s] is [s] filtered and mapped by [fm]. {ul {- \[[fmap fm i s]\]{_t} [=] v if [fm] \[[s]\]{_t}[ = Some v].} - {- \[[fmap fm i s]\]{_t} [=] \[[fmap fm i s]\]{_t'} if [fm] - \[[s]\]{_t} [= None] and t' is the greatest t' < t with [fm] + {- \[[fmap fm i s]\]{_t} [=] \[[fmap fm i s]\]{_t'} if [fm] + \[[s]\]{_t} [= None] and t' is the greatest t' < t with [fm] \[[s]\]{_t'} [<> None].} {- \[[fmap fm i s]\]{_t} [= i] otherwise.}} *) @@ -394,7 +394,7 @@ module S : sig [v'] to [v] and [eq v v'] is [false] ([eq] is the signal's equality function). The value of the occurrence is [f v v']. {ul - {- \[[diff f s]\]{_t} [= Some d] + {- \[[diff f s]\]{_t} [= Some d] if \[[s]\]{_t} [= v] and \[[s]\]{_t-dt} [= v'] and [eq v v' = false] and [f v v' = d].} {- \[[diff f s]\]{_t} [= None] otherwise.}} *) @@ -404,28 +404,28 @@ module S : sig val sample : ('b -> 'a -> 'c) -> 'b event -> 'a signal -> 'c event (** [sample f e s] samples [s] at [e]'s occurrences. - {ul + {ul {- \[[sample f e s]\]{_t} [= Some (f ev sv)] if \[[e]\]{_t} [= Some ev] and \[[s]\]{_t} [= sv].} - {- \[[sample e s]\]{_t} [= None] otherwise.}} *) + {- \[[sample e s]\]{_t} [= None] otherwise.}} *) - val on : ?eq:('a -> 'a -> bool) -> bool signal -> 'a -> 'a signal -> + val on : ?eq:('a -> 'a -> bool) -> bool signal -> 'a -> 'a signal -> 'a signal (** [on c i s] is the signal [s] whenever [c] is [true]. When [c] is [false] it holds the last value [s] had when [c] was the last time [true] or [i] if it never was. {ul {- \[[on c i s]\]{_t} [=] \[[s]\]{_t} if \[[c]\]{_t} [= true]} - {- \[[on c i s]\]{_t} [=] \[[s]\]{_t'} if \[[c]\]{_t} [= false] + {- \[[on c i s]\]{_t} [=] \[[s]\]{_t'} if \[[c]\]{_t} [= false] where t' is the greatest t' < t with \[[c]\]{_t'} [= true].} {- \[[on c i s]\]{_t} [=] [i] otherwise.}} *) - val when_ : ?eq:('a -> 'a -> bool) -> bool signal -> 'a -> 'a signal -> + val when_ : ?eq:('a -> 'a -> bool) -> bool signal -> 'a -> 'a signal -> 'a signal (** @deprecated Use {!on}. *) - - val dismiss : ?eq:('a -> 'a -> bool) -> 'b event -> 'a -> 'a signal -> - 'a signal + + val dismiss : ?eq:('a -> 'a -> bool) -> 'b event -> 'a -> 'a signal -> + 'a signal (** [dismiss c i s] is the signal [s] except changes when [c] occurs are ignored. If [c] occurs initially [i] is used. {ul @@ -437,10 +437,10 @@ module S : sig (** {1:acc Accumulating} *) - val accum : ?eq:('a -> 'a -> bool) -> ('a -> 'a) event -> 'a -> 'a signal + val accum : ?eq:('a -> 'a -> bool) -> ('a -> 'a) event -> 'a -> 'a signal (** [accum e i] is [S.hold i (]{!E.accum}[ e i)]. *) - val fold : ?eq:('a -> 'a -> bool) -> ('a -> 'b -> 'a) -> 'a -> 'b event -> + val fold : ?eq:('a -> 'a -> bool) -> ('a -> 'b -> 'a) -> 'a -> 'b event -> 'a signal (** [fold f i e] is [S.hold i (]{!E.fold}[ f i e)]. *) @@ -449,18 +449,18 @@ module S : sig val merge : ?eq:('a -> 'a -> bool) -> ('a -> 'b -> 'a) -> 'a -> 'b signal list -> 'a signal (** [merge f a sl] merges the value of every signal in [sl] - using [f] and the accumulator [a]. - - \[[merge f a sl]\]{_ t} + using [f] and the accumulator [a]. + + \[[merge f a sl]\]{_ t} [= List.fold_left f a (List.map] \[\]{_t}[ sl)]. *) - val switch : ?eq:('a -> 'a -> bool) -> 'a signal signal -> 'a signal - (** [switch ss] is the inner signal of [ss]. - {ul + val switch : ?eq:('a -> 'a -> bool) -> 'a signal signal -> 'a signal + (** [switch ss] is the inner signal of [ss]. + {ul {- \[[switch ss]\]{_ t} [=] \[\[[ss]\]{_t}\]{_t}.}} *) - val bind : ?eq:('b -> 'b -> bool) -> 'a signal -> ('a -> 'b signal) -> - 'b signal + val bind : ?eq:('b -> 'b -> bool) -> 'a signal -> ('a -> 'b signal) -> + 'b signal (** [bind s sf] is [switch (map ~eq:( == ) sf s)]. *) val fix : ?eq:('a -> 'a -> bool) -> 'a -> ('a signal -> 'a signal * 'b) -> 'b @@ -473,19 +473,19 @@ module S : sig is such that : {ul {- \[[s]\]{_ t} [=] [i] for t = 0. } - {- \[[s]\]{_ t} [=] \[[s']\]{_t-dt} otherwise.}} + {- \[[s]\]{_ t} [=] \[[s']\]{_t-dt} otherwise.}} - [eq] is the equality used by [s]. + [eq] is the equality used by [s]. - {b Raises.} [Invalid_argument] if [s'] is directly a delayed signal (i.e. + {b Raises.} [Invalid_argument] if [s'] is directly a delayed signal (i.e. a signal given to a fixing function). - {b Note.} Regarding values depending on the result [r] of + {b Note.} Regarding values depending on the result [r] of [s', r = sf s] the following two cases need to be distinguished : {ul - {- After [sf s] is applied, [s'] does not depend on + {- After [sf s] is applied, [s'] does not depend on a value that is in a step and [s] has no dependents in a step (e.g - in the simple case where [fix] is applied outside a step). + in the simple case where [fix] is applied outside a step). In that case if the initial value of [s'] differs from [i], [s] and its dependents need to be updated and a special @@ -497,43 +497,62 @@ module S : sig step as [s] and [s'] (e.g. they will see the [i] of [s] if [r = s]).}} *) - (** {1:lifting Lifting} + (** {1:lifting Lifting} Lifting combinators. For a given [n] the semantics is : \[[ln f a1] ... [an]\]{_t} = f \[[a1]\]{_t} ... \[[an]\]{_t} *) val l1 : ?eq:('b -> 'b -> bool) -> ('a -> 'b) -> ('a signal -> 'b signal) - val l2 : ?eq:('c -> 'c -> bool) -> - ('a -> 'b -> 'c) -> ('a signal -> 'b signal -> 'c signal) - val l3 : ?eq:('d -> 'd -> bool) -> - ('a -> 'b -> 'c -> 'd) -> ('a signal -> 'b signal -> 'c signal -> 'd signal) - val l4 : ?eq:('e -> 'e -> bool) -> - ('a -> 'b -> 'c -> 'd -> 'e) -> - ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal) - val l5 : ?eq:('f -> 'f -> bool) -> - ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> - ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> - 'f signal) - val l6 : ?eq:('g -> 'g -> bool) -> - ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) -> - ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> - 'f signal -> 'g signal) - - (** The following modules lift some of [Pervasives] functions and + val l2 : ?eq:('c -> 'c -> bool) -> + ('a -> 'b -> 'c) -> ('a signal -> 'b signal -> 'c signal) + val l3 : ?eq:('d -> 'd -> bool) -> + ('a -> 'b -> 'c -> 'd) -> ('a signal -> 'b signal -> 'c signal -> 'd signal) + val l4 : ?eq:('e -> 'e -> bool) -> + ('a -> 'b -> 'c -> 'd -> 'e) -> + ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal) + val l5 : ?eq:('f -> 'f -> bool) -> + ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> + ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> + 'f signal) + val l6 : ?eq:('g -> 'g -> bool) -> + ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) -> + ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> + 'f signal -> 'g signal) + + (** The following modules lift some of [Pervasives] functions and operators. *) module Bool : sig val zero : bool signal - val one : bool signal + val one : bool signal val not : bool signal -> bool signal val ( && ) : bool signal -> bool signal -> bool signal val ( || ) : bool signal -> bool signal -> bool signal + + val edge : bool signal -> bool event + (** [edge s] is [changes s]. *) + + val rise : bool signal -> unit event + (** [rise s] is [E.fmap (fun b -> if b then Some () else None) (edge s)].*) + + val fall : bool signal -> unit event + (** [fall s] is [E.fmap (fun b -> if b then None else Some ()) (edge s)].*) + + val flip : bool -> 'a event -> bool signal + (** [flip b e] is a signal whose boolean value flips each time + [e] occurs. [b] is the initial signal value. + {ul + {- \[[flip b e]\]{_0} [= not b] if \[[e]\]{_0} [= Some _]} + {- \[[flip b e]\]{_t} [= b] if \[[e]\]{_<=t} [= None]} + {- \[[flip b e]\]{_t} [=] [not] \[[flip b e]\]{_t-dt} + if \[[e]\]{_t} [= Some _]}} +*) end - + module Int : sig val zero : int signal - val one : int signal + val one : int signal val minus_one : int signal val ( ~- ) : int signal -> int signal val succ : int signal -> int signal @@ -556,7 +575,7 @@ module S : sig module Float : sig val zero : float signal - val one : float signal + val one : float signal val minus_one : float signal val ( ~-. ) : float signal -> float signal val ( +. ) : float signal -> float signal -> float signal @@ -597,9 +616,9 @@ module S : sig val epsilon_float : float signal val classify_float : float signal -> fpclass signal end - + module Pair : sig - val pair : ?eq:(('a * 'b) -> ('a * 'b) -> bool)-> + val pair : ?eq:(('a * 'b) -> ('a * 'b) -> bool)-> 'a signal -> 'b signal -> ('a * 'b) signal val fst : ?eq:('a -> 'a -> bool) -> ('a * 'b) signal -> 'a signal val snd : ?eq:('a -> 'a -> bool) -> ('b * 'a) signal -> 'a signal @@ -609,24 +628,24 @@ module S : sig val none : 'a option signal (** [none] is [S.const None]. *) - val some : 'a signal -> 'a option signal + val some : 'a signal -> 'a option signal (** [some s] is [S.map ~eq (fun v -> Some v) None], where [eq] uses [s]'s equality function to test the [Some v]'s equalities. *) - val value : ?eq:('a -> 'a -> bool) -> - default:[`Init of 'a signal | `Always of 'a signal ] -> + val value : ?eq:('a -> 'a -> bool) -> + default:[`Init of 'a signal | `Always of 'a signal ] -> 'a option signal -> 'a signal - (** [value default s] is [s] with only its [Some v] values. - Whenever [s] is [None], if [default] is [`Always dv] then + (** [value default s] is [s] with only its [Some v] values. + Whenever [s] is [None], if [default] is [`Always dv] then the current value of [dv] is used instead. If [default] is [`Init dv] the current value of [dv] is only used if there's no value at creation time, otherwise the last [Some v] value of [s] is used. - {ul + {ul {- \[[value ~default s]\]{_t} [= v] if \[[s]\]{_t} [= Some v]} - {- \[[value ~default:(`Always d) s]\]{_t} [=] \[[d]\]{_t} + {- \[[value ~default:(`Always d) s]\]{_t} [=] \[[d]\]{_t} if \[[s]\]{_t} [= None]} - {- \[[value ~default:(`Init d) s]\]{_0} [=] \[[d]\]{_0} + {- \[[value ~default:(`Init d) s]\]{_0} [=] \[[d]\]{_0} if \[[s]\]{_0} [= None]} {- \[[value ~default:(`Init d) s]\]{_t} [=] \[[value ~default:(`Init d) s]\]{_t'} @@ -648,61 +667,61 @@ module S : sig (** {1:special Combinator specialization} - Given an equality function [equal] and a type [t], the functor - {!Make} automatically applies the [eq] parameter of the combinators. - The outcome is combinators whose {e results} are signals with + Given an equality function [equal] and a type [t], the functor + {!Make} automatically applies the [eq] parameter of the combinators. + The outcome is combinators whose {e results} are signals with values in [t]. - Basic types are already specialized in the module {!Special}, open + Basic types are already specialized in the module {!Special}, open this module to use them. *) (** Input signature of {!S.Make} *) module type EqType = sig - type 'a t - val equal : 'a t -> 'a t -> bool + type 'a t + val equal : 'a t -> 'a t -> bool end - (** Output signature of {!S.Make} *) + (** Output signature of {!S.Make} *) module type S = sig - type 'a v + type 'a v val create : 'a v -> 'a v signal * (?step:step -> 'a v -> unit) val equal : 'a v signal -> 'a v signal -> bool val hold : 'a v -> 'a v event -> 'a v signal val app : ('a -> 'b v) signal -> 'a signal -> 'b v signal val map : ('a -> 'b v) -> 'a signal -> 'b v signal - val filter : ('a v -> bool) -> 'a v -> 'a v signal -> 'a v signal + val filter : ('a v -> bool) -> 'a v -> 'a v signal -> 'a v signal val fmap : ('a -> 'b v option) -> 'b v -> 'a signal -> 'b v signal val when_ : bool signal -> 'a v -> 'a v signal -> 'a v signal val dismiss : 'b event -> 'a v -> 'a v signal -> 'a v signal - val accum : ('a v -> 'a v) event -> 'a v -> 'a v signal + val accum : ('a v -> 'a v) event -> 'a v -> 'a v signal val fold : ('a v -> 'b -> 'a v) -> 'a v -> 'b event -> 'a v signal val merge : ('a v -> 'b -> 'a v) -> 'a v -> 'b signal list -> 'a v signal val switch : 'a v signal signal -> 'a v signal val bind : 'b signal -> ('b -> 'a v signal) -> 'a v signal val fix : 'a v -> ('a v signal -> 'a v signal * 'b) -> 'b val l1 : ('a -> 'b v) -> ('a signal -> 'b v signal) - val l2 : ('a -> 'b -> 'c v) -> ('a signal -> 'b signal -> 'c v signal) - val l3 : ('a -> 'b -> 'c -> 'd v) -> ('a signal -> 'b signal -> - 'c signal -> 'd v signal) - val l4 : ('a -> 'b -> 'c -> 'd -> 'e v) -> - ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e v signal) - val l5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f v) -> - ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> - 'f v signal) - val l6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g v) -> - ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> - 'f signal -> 'g v signal) + val l2 : ('a -> 'b -> 'c v) -> ('a signal -> 'b signal -> 'c v signal) + val l3 : ('a -> 'b -> 'c -> 'd v) -> ('a signal -> 'b signal -> + 'c signal -> 'd v signal) + val l4 : ('a -> 'b -> 'c -> 'd -> 'e v) -> + ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e v signal) + val l5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f v) -> + ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> + 'f v signal) + val l6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g v) -> + ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> + 'f signal -> 'g v signal) end (** Functor specializing the combinators for the given signal value type *) module Make (Eq : EqType) : S with type 'a v = 'a Eq.t - (** Specialization for booleans, integers and floats. + (** Specialization for booleans, integers and floats. Open this module to use it. *) module Special : sig - + (** Specialization for booleans. *) module Sb : S with type 'a v = bool @@ -714,43 +733,43 @@ module S : sig end end -(** Update steps. +(** Update steps. Update functions returned by {!S.create} and {!E.create} implicitely create and execute update steps when used without - specifying their [step] argument. + specifying their [step] argument. - Using explicit {!step} values with these functions gives more control on - the time when the update step is perfomed and allows to perform - simultaneous {{!primitives}primitive} signal updates and event - occurences. See also the documentation about {{!steps}update steps} and + Using explicit {!step} values with these functions gives more control on + the time when the update step is perfomed and allows to perform + simultaneous {{!primitives}primitive} signal updates and event + occurences. See also the documentation about {{!steps}update steps} and {{!simultaneity}simultaneous events}. *) module Step : sig (** {1 Steps} *) - + type t = step (** The type for update steps. *) val create : unit -> step (** [create ()] is a new update step. *) - val execute : step -> unit - (** [execute step] executes the update step. - + val execute : step -> unit + (** [execute step] executes the update step. + @raise Invalid_argument if [step] was already executed. *) end -(** {1:sem Semantics} +(** {1:sem Semantics} - The following notations are used to give precise meaning to the - combinators. It is important to note that in these semantic + The following notations are used to give precise meaning to the + combinators. It is important to note that in these semantic descriptions the origin of time t = 0 is {e always} fixed at the time at which the combinator creates the event or the signal and the semantics of the dependents is evaluated relative to this timeline. - + We use dt to denote an infinitesimal amount of time. - {2:evsem Events} + {2:evsem Events} An event is a value with discrete occurrences over time. @@ -765,11 +784,11 @@ end event before (resp. before or at) [t]. More precisely : {ul {- \[[e]\]{_<t} [=] \[[e]\]{_t'} with t' the greatest t' < t - (resp. [<=]) such that + (resp. [<=]) such that \[[e]\]{_t'} [<> None].} {- \[[e]\]{_<t} [= None] if there is no such t'.}} - {2:sigsem Signals} + {2:sigsem Signals} A signal is a value that varies continuously over time. In contrast to {{!evsem}events} which occur at specific point @@ -777,16 +796,16 @@ end The semantic function \[\] [: 'a signal -> time -> 'a] gives meaning to a signal [s] by mapping it to a function of time - \[[s]\] that returns its value at a given time. We write \[[s]\]{_t} + \[[s]\] that returns its value at a given time. We write \[[s]\]{_t} the evaluation of this {e semantic} function at time t. - {3:sigeq Equality} + {3:sigeq Equality} Most signal combinators have an optional [eq] parameter that defaults to structural equality. [eq] specifies the equality function used to detect changes in the value of the resulting signal. This function is needed for the efficient update of signals and to deal correctly with signals that perform - {{!sideeffects}side effects}. + {{!sideeffects}side effects}. Given an equality function on a type the combinators can be automatically {{!S.special}specialized} via a functor. @@ -819,11 +838,11 @@ let () = List.iter send_x [1; 2; 3]]} Primitive signals are created with {!S.create}. This function returns a new signal and an update function that sets the signal's value at the time it is called. The following code creates an - integer signal [x] initially set to [1] and updates it three time with - values [2], [2], [3]. The signal's values are printed on stdout by the + integer signal [x] initially set to [1] and updates it three time with + values [2], [2], [3]. The signal's values are printed on stdout by the effectful signal [pr_x]. Note that only updates that change the signal's value are printed, hence the program prints [123], not [1223]. - See the discussion on + See the discussion on {{!sideeffects}side effects} for more details. {[open React;; @@ -831,10 +850,10 @@ let () = List.iter send_x [1; 2; 3]]} let x, set_x = S.create 1 let pr_x = S.map print_int x let () = List.iter set_x [2; 2; 3]]} - The {{!clock}clock} example shows how a realtime time + The {{!clock}clock} example shows how a realtime time flow can be defined. - {2:steps Update steps} + {2:steps Update steps} The {!E.create} and {!S.create} functions return update functions used to generate primitive event occurences and set the value of @@ -854,27 +873,27 @@ let () = List.iter set_x [2; 2; 3]]} {2:simultaneity Simultaneous events} - {{!steps}Update steps} are made under a + {{!steps}Update steps} are made under a {{:http://dx.doi.org/10.1016/0167-6423(92)90005-V}synchrony hypothesis} : - the update step takes no time, it is instantenous. Two event occurrences - are {e simultaneous} if they occur in the same update step. + the update step takes no time, it is instantenous. Two event occurrences + are {e simultaneous} if they occur in the same update step. - In the code below [w], [x] and [y] will always have simultaneous + In the code below [w], [x] and [y] will always have simultaneous occurrences. They {e may} have simulatenous occurences with [z] - if [send_w] and [send_z] are used with the same update step. + if [send_w] and [send_z] are used with the same update step. {[let w, send_w = E.create () let x = E.map succ w let y = E.map succ x let z, send_z = E.create () -let () = +let () = let () = send_w 3 (* w x y occur simultaneously, z doesn't occur *) in - let step = Step.create () in - send_w ~step 3; - send_z ~step 4; + let step = Step.create () in + send_w ~step 3; + send_z ~step 4; Step.execute step (* w x z y occur simultaneously *) -]} +]} {2:update The update step and thread safety} @@ -909,10 +928,10 @@ let succ_z = S.map succ z]} exactly {e once} in each {{!steps}update step} in which there is an update of at least one of the event or signal it depends on. - Remember that a signal updates in a step iff its + Remember that a signal updates in a step iff its {{!sigeq}equality function} determined that the signal - value changed. Signal initialization is unconditionally considered as - an update. + value changed. Signal initialization is unconditionally considered as + an update. It is important to keep references on effectful events and signals. Otherwise they may be reclaimed by the garbage collector. @@ -935,17 +954,17 @@ let fl' x y = S.l2 f x y (* efficient *) Besides, some of [Pervasives]'s functions and operators are already lifted and availables in submodules of {!S}. They can be be opened in specific scopes. For example if you are dealing with - float signals you can open {!S.Float}. -{[open React -open React.S.Float + float signals you can open {!S.Float}. +{[open React +open React.S.Float let f t = sqrt t *. sin t (* f is defined on float signals *) ... open Pervasives (* back to pervasives floats *) ]} If you are using OCaml 3.12 or later you can also use the [let open] - construct -{[let open React.S.Float in + construct +{[let open React.S.Float in let f t = sqrt t *. sin t in (* f is defined on float signals *) ... ]} @@ -965,16 +984,16 @@ let f t = sqrt t *. sin t in (* f is defined on float signals *) as argument the infinitesimally delayed event or signal that [f] itself returns. - In the example below [history s] returns a signal whose value - is the history of [s] as a list. -{[let history ?(eq = ( = )) s = - let push v = function - | [] -> [ v ] + In the example below [history s] returns a signal whose value + is the history of [s] as a list. +{[let history ?(eq = ( = )) s = + let push v = function + | [] -> [ v ] | v' :: _ as l when eq v v' -> l - | l -> v :: l + | l -> v :: l in - let define h = - let h' = S.l2 push s h in + let define h = + let h' = S.l2 push s h in h', h' in S.fix [] define]} @@ -988,17 +1007,17 @@ let f t = sqrt t *. sin t in (* f is defined on float signals *) be well-founded otherwise this may trigger an infinite number of update steps, like in the following examples. {[let start, send_start = E.create () -let diverge = - let define e = - let e' = E.select [e; start] in +let diverge = + let define e = + let e' = E.select [e; start] in e', e' in E.fix define - + let () = send_start () (* diverges *) - + let diverge = (* diverges *) - let define s = + let define s = let s' = S.Int.succ s in s', s' in @@ -1007,9 +1026,9 @@ let diverge = (* diverges *) fixing functions) are not allowed to directly depend on each other. Fixed point combinators will raise [Invalid_argument] if such dependencies are created. This limitation can be - circumvented by mapping these values with the identity. + circumvented by mapping these values with the identity. - {2:strongstop Strong stops} + {2:strongstop Strong stops} Strong stops should only be used on platforms where weak arrays have a strong semantics (i.e. JavaScript). You can safely ignore that @@ -1035,21 +1054,21 @@ let diverge = (* diverges *) the example below, [e1] will {e never} occur: {[let e, e_send = E.create () let e1 = E.map (fun x -> x + 1) e (* never occurs *) -let () = - let e2 = E.map (fun x -> x + 1) e1 in +let () = + let e2 = E.map (fun x -> x + 1) e1 in E.stop ~strong:true e2 ]} - This can be side stepped by making an artificial dependency to keep + This can be side stepped by making an artificial dependency to keep the reference: {[let e, e_send = E.create () let e1 = E.map (fun x -> x + 1) e (* may still occur *) -let e1_ref = E.map (fun x -> x) e1 -let () = +let e1_ref = E.map (fun x -> x) e1 +let () = let e2 = E.map (fun x -> x + 1) e1 in E.stop ~strong:true e2 ]} - {1:ex Examples} + {1:ex Examples} {2:clock Clock} @@ -1059,16 +1078,16 @@ let () = along with an {{:http://www.ecma-international.org/publications/standards/Ecma-048.htm}ANSI escape sequence} to control the cursor position. -{[let pr_time t = +{[let pr_time t = let tm = Unix.localtime t in - Printf.printf "\x1B[8D%02d:%02d:%02d%!" + Printf.printf "\x1B[8D%02d:%02d:%02d%!" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec open React;; -let seconds, run = +let seconds, run = let e, send = E.create () in - let run () = + let run () = while true do send (Unix.gettimeofday ()); Unix.sleep 1 done in e, run @@ -1085,7 +1104,7 @@ let () = run ()]} Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. diff --git a/src/react_top.ml b/src/react_top.ml new file mode 100644 index 0000000..4b8d1fd --- /dev/null +++ b/src/react_top.ml @@ -0,0 +1,48 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2014 Daniel C. Bünzli. All rights reserved. + Distributed under the BSD3 license, see license at the end of the file. + react release 1.2.0 + ---------------------------------------------------------------------------*) + +let exec s = + let l = Lexing.from_string s in + let ph = !Toploop.parse_toplevel_phrase l in + assert(Toploop.execute_phrase false Format.err_formatter ph) + +let setup () = + exec "open React;;" + +let () = setup () + +(*--------------------------------------------------------------------------- + Copyright (c) 2014 Daniel C. Bünzli. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + 3. Neither the name of Daniel C. Bünzli nor the names of + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + ---------------------------------------------------------------------------*) diff --git a/test/breakout.ml b/test/breakout.ml index 69222cb..9cfe500 100644 --- a/test/breakout.ml +++ b/test/breakout.ml @@ -13,15 +13,15 @@ module Log : sig (* Logs values, signals and events to stderr. *) val e : (Format.formatter -> 'a -> unit) -> string -> 'a event -> 'a event val s : (Format.formatter -> 'a -> unit) -> string -> 'a signal -> 'a signal end = struct - let init () = - let t = Unix.gettimeofday () in - let tm = Unix.localtime t in + let init () = + let t = Unix.gettimeofday () in + let tm = Unix.localtime t in Format.eprintf "\x1B[2J\x1B[H\x1B[7m@[>> %04d-%02d-%02d %02d:%02d:%02d <<@]\x1B[0m@." (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec - let value pp name v = Format.eprintf "@[<hov 2>%s =@ %a@]@." name pp v + let value pp name v = Format.eprintf "@[<hov 2>%s =@ %a@]@." name pp v let e pp name e = E.trace (value pp name) e let s pp name s = S.trace (value pp name) s end @@ -31,24 +31,24 @@ module V2 : sig (* Vectors. *) val v : float -> float -> t val o : t val ex : t - val ey : t + val ey : t val x : t -> float - val y : t -> float + val y : t -> float val add : t -> t -> t val sub : t -> t -> t val neg : t -> t val smul : float -> t -> t - val dot : t -> t -> float + val dot : t -> t -> float val to_ints : t -> int * int val print : Format.formatter -> t -> unit end = struct type t = { x : float; y : float } let v x y = { x = x; y = y } - let o = v 0. 0. - let ex = v 1. 0. + let o = v 0. 0. + let ex = v 1. 0. let ey = v 0. 1. - let x p = p.x - let y p = p.y + let x p = p.x + let y p = p.y let add p p' = v (p.x +. p'.x) (p.y +. p'.y) let sub p p' = v (p.x -. p'.x) (p.y -. p'.y) let neg p = v (-. p.x) (-. p.y) @@ -67,15 +67,15 @@ module Rect : sig (* Rectangles. *) val xmin : t -> float val xmax : t -> float val ymin : t -> float - val ymax : t -> float + val ymax : t -> float val print : Format.formatter -> t -> unit -end = struct +end = struct type t = V2.t * V2.t - let create o size = o, size - let empty = V2.o, V2.o + let create o size = o, size + let empty = V2.o, V2.o let o (o, s) = o let size (_, s) = s - let xmin (o, _) = V2.x o + let xmin (o, _) = V2.x o let xmax (o, s) = V2.x o +. V2.x s let ymin (o, _) = V2.y o let ymax (o, s) = V2.y o +. V2.y s @@ -90,13 +90,13 @@ module Draw : sig (* Draw with ANSI escape sequences. *) val text : ?center:bool -> ?color:int -> V2.t -> string -> unit val rect : ?color:int -> Rect.t -> unit val beep : unit -> unit -end = struct +end = struct let pr = Printf.printf let frame = Rect.create (V2.v 1. 1.) (V2.v 80. 24.) let clear () = pr "\x1B[47m\x1B[2J" let flush () = pr "%!" let reset () = clear (); pr "\x1Bc"; flush () - let init () = + let init () = pr "\x1B[H\x1B[7l\x1B[?25l"; clear (); flush (); at_exit (reset) @@ -104,7 +104,7 @@ end = struct let x, y = V2.to_ints pos in let x = if center then x - (String.length str) / 2 else x in pr ("\x1B[%d;%df\x1B[47;%dm%s") y x color str - + let rect ?(color = 40) r = let (x, y) = V2.to_ints (Rect.o r) in let (w, h) = V2.to_ints (Rect.size r) in @@ -133,14 +133,14 @@ end = struct Sys.set_signal Sys.sigint (Sys.Signal_handle quit); Sys.set_signal Sys.sigfpe (Sys.Signal_handle quit) - let time, send_time = E.create () - let key, send_key = E.create () + let time, send_time = E.create () + let key, send_key = E.create () let gather () = (* updates primitive events. *) let c = " " in - let i = Unix.stdin in + let i = Unix.stdin in let input_char i = ignore (Unix.read i c 0 1); c.[0] in let dt = 0.1 in - while true do + while true do if Unix.select [i] [] [] dt = ([i], [], []) then send_key (input_char i); send_time (Unix.gettimeofday ()); done @@ -157,49 +157,49 @@ module Game : sig (* Game simulation and logic. *) val collisions : t -> unit event val outcome : t -> [> `Game_over of int ] event end = struct - type t = + type t = { walls : Rect.t; ball : Rect.t signal; paddle : Rect.t signal; bricks : Rect.t list signal; brick_count : int signal; collisions : unit event } - + (* Collisions *) - let ctime c r d n = Some (n, (r -. c) /. d) + let ctime c r d n = Some (n, (r -. c) /. d) let cmin c r d n = if r <= c && d < 0. then ctime c r d n else None let cmax c r d n = if r >= c && d > 0. then ctime c r d n else None - let cinter cmin cmax rmin rmax d n = match d with + let cinter cmin cmax rmin rmax d n = match d with | d when d < 0. -> if rmax -. d < cmin then None else (* moving apart. *) - if rmin -. d >= cmax then + if rmin -. d >= cmax then if rmin <= cmax then ctime cmax rmin d n else None else Some (V2.o, 0.) (* initially overlapping. *) | d when d > 0. -> if rmin -. d > cmax then None else (* moving apart. *) - if rmax -. d <= cmin then + if rmax -. d <= cmin then if rmax >= cmin then ctime cmin rmax d (V2.neg n) else None else Some (V2.o, 0.) (* initially overlapping. *) | _ (* d = 0. *) -> - if cmax < rmin || rmax < cmin then None else Some (V2.o, 0.) + if cmax < rmin || rmax < cmin then None else Some (V2.o, 0.) let crect c r d = (* r last moved by d relatively to c. *) - let inter min max c r d n = cinter (min c) (max c) (min r) (max r) d n in + let inter min max c r d n = cinter (min c) (max c) (min r) (max r) d n in match inter Rect.xmin Rect.xmax c r (V2.x d) V2.ex with - | None -> None - | Some (_, t as x) -> + | None -> None + | Some (_, t as x) -> match inter Rect.ymin Rect.ymax c r (V2.y d) V2.ey with | None -> None - | Some (_, t' as y) -> - let _, t as c = if t > t' then x else y in + | Some (_, t' as y) -> + let _, t as c = if t > t' then x else y in if t = 0. then None else Some c - + (* Game objects *) - + let moving_rect pos size = S.map (fun pos -> Rect.create pos size) pos - let ball walls dt collisions = + let ball walls dt collisions = let size = V2.v 2. 1. in let x0 = 0.5 *. (Rect.xmax walls -. V2.x size) in let p0 = V2.v x0 (0.5 *. Rect.ymax walls) in @@ -209,55 +209,55 @@ end = struct let speed = 18. +. Random.float 2. in V2.v (speed *. sin angle) (speed *. cos angle) in - let v = + let v = let bounce (n, _) v = V2.sub v (V2.smul (2. *. V2.dot n v) n) in - S.accum (E.map bounce collisions) v0 + S.accum (E.map bounce collisions) v0 in let dp = S.sample (fun dt v -> V2.smul dt v) dt v in - let p = + let p = let pos p0 = S.fold V2.add p0 dp in let adjust (_, pc) = pos pc in (* visually sufficient. *) S.switch (S.hold ~eq:( == ) (pos p0) (E.map adjust collisions)) in moving_rect p size, dp - - let walls walls (ball, dp) = - let left = Rect.xmin walls in + + let walls walls (ball, dp) = + let left = Rect.xmin walls in let right = Rect.xmax walls in let top = Rect.ymin walls in - let collisions = + let collisions = let collide dp ball = let c = match cmin left (Rect.xmin ball) (V2.x dp) V2.ex with | Some _ as c -> c - | None -> + | None -> match cmax right (Rect.xmax ball) (V2.x dp) (V2.neg V2.ex) with | Some _ as c -> c | None -> cmin top (Rect.ymin ball) (V2.y dp) V2.ey in - match c with - | None -> None + match c with + | None -> None | Some (n, t) -> Some (n, V2.sub (Rect.o ball) (V2.smul t dp)) in - E.fmap (fun x -> x) (S.sample collide dp ball) + E.fmap (fun x -> x) (S.sample collide dp ball) in walls, collisions let paddle walls moves (ball, dp) = - let speed = 4. in + let speed = 4. in let size = V2.v 9. 1. in - let xmin = Rect.xmin walls in - let xmax = Rect.xmax walls -. (V2.x size) in + let xmin = Rect.xmin walls in + let xmax = Rect.xmax walls -. (V2.x size) in let p0 = V2.v (0.5 *. xmax) (Rect.ymax walls -. 2.) in - let control p = function - | `Left -> + let control p = function + | `Left -> let x' = V2.x p -. speed in if x' < xmin then V2.v xmin (V2.y p) else V2.v x' (V2.y p) - | `Right -> - let x' = V2.x p +. speed in + | `Right -> + let x' = V2.x p +. speed in if x' > xmax then V2.v xmax (V2.y p) else V2.v x' (V2.y p) in - let paddle = moving_rect (S.fold control p0 moves) size in - let collisions = + let paddle = moving_rect (S.fold control p0 moves) size in + let collisions = let collide dp (ball, paddle) = match crect paddle ball dp with | None -> None | Some (n, t) -> Some (n, V2.sub (Rect.o ball) (V2.smul t dp)) @@ -265,17 +265,17 @@ end = struct E.fmap (fun x -> x) (S.sample collide dp (S.Pair.pair ball paddle)) in paddle, collisions - + let bricks walls (ball, dp) = - let bricks0 = + let bricks0 = let size = Rect.size walls in - let w = V2.x size in + let w = V2.x size in let h = (V2.y size) /. 4. in (* use 1/4 for bricks. *) let bw, bh = (w /. 8.), h /. 3. in let x_count = truncate (w /. bw) in let y_count = truncate (h /. bh) in let acc = ref [] in - for x = 0 to x_count - 1 do + for x = 0 to x_count - 1 do for y = 0 to y_count - 1 do let x = Rect.xmin walls +. (float x) *. bw in let y = Rect.ymin walls +. 2. *. bh +. (float y) *. bh in @@ -285,10 +285,10 @@ end = struct !acc in let define bricks = - let cresult = - let collide dp (ball, bricks) = + let cresult = + let collide dp (ball, bricks) = let rec aux c acc bricks ball dp = match bricks with - | [] -> c, List.rev acc + | [] -> c, List.rev acc | b :: bricks' -> match crect b ball dp with | None -> aux c (b :: acc) bricks' ball dp | c -> aux c acc bricks' ball dp @@ -297,7 +297,7 @@ end = struct | None, bl -> None, bl | Some (n, t), bl -> Some (n, V2.sub (Rect.o ball) (V2.smul t dp)),bl in - S.sample collide dp (S.Pair.pair ball bricks) + S.sample collide dp (S.Pair.pair ball bricks) in let collisions = E.fmap (fun (c, _) -> c) cresult in let bricks_e = E.map (fun (_, bl) -> fun _ -> bl) cresult in @@ -305,61 +305,61 @@ end = struct bricks', (bricks', collisions) in S.fix bricks0 define - - (* Game data structure, links game objects *) - - let create w dt moves = - let define collisions = + + (* Game data structure, links game objects *) + + let create w dt moves = + let define collisions = let ball = ball w dt collisions in - let walls, wcollisions = walls w ball in - let paddle, pcollisions = paddle w moves ball in + let walls, wcollisions = walls w ball in + let paddle, pcollisions = paddle w moves ball in let bricks, bcollisions = bricks w ball in let collisions' = E.select [pcollisions; wcollisions; bcollisions] in - let g = - { walls = walls; + let g = + { walls = walls; ball = S.dismiss collisions' Rect.empty (fst ball); - paddle = paddle; - bricks = bricks; + paddle = paddle; + bricks = bricks; brick_count = S.map List.length bricks; collisions = E.stamp collisions' () } in collisions', g in E.fix define - - let walls g = g.walls + + let walls g = g.walls let ball g = g.ball let paddle g = g.paddle let bricks g = g.bricks let brick_count g = g.brick_count let collisions g = g.collisions let outcome g = (* game outcome logic. *) - let no_bricks = S.map (fun l -> l = 0) g.brick_count in + let no_bricks = S.map (fun l -> l = 0) g.brick_count in let miss = S.map (fun b -> Rect.ymax b >= Rect.ymax g.walls) g.ball in let game_over = S.changes (S.Bool.( || ) no_bricks miss) in S.sample (fun _ l -> `Game_over l) game_over g.brick_count end -module Render = struct - let str = Printf.sprintf +module Render = struct + let str = Printf.sprintf let str_bricks count = if count = 1 then "1 brick" else str "%d bricks" count - + let intro title_color = (* draws the splash screen. *) let x = 0.5 *. Rect.xmax Draw.frame in - let y = 0.5 *. Rect.ymax Draw.frame in + let y = 0.5 *. Rect.ymax Draw.frame in Draw.clear (); Draw.text ~color:title_color (V2.v x (y -. 2.)) "BREAKOUT"; - Draw.text ~color:30 (V2.v x y) + Draw.text ~color:30 (V2.v x y) "Hit 'a' and 'd' to move the paddle, 'q' to quit"; Draw.text ~color:31 (V2.v x (y +. 2.)) "Hit spacebar to start the game"; Draw.flush () - + let game_init m = (* draws game init message. *) - let x = 0.5 *. Rect.xmax Draw.frame in - let y = 0.5 *. Rect.ymax Draw.frame in - Draw.text ~color:31 (V2.v x (y +. 2.)) m; + let x = 0.5 *. Rect.xmax Draw.frame in + let y = 0.5 *. Rect.ymax Draw.frame in + Draw.text ~color:31 (V2.v x (y +. 2.)) m; Draw.flush () - + let game ball paddle bricks bcount = (* draws the game state. *) let bl = V2.v (Rect.xmin Draw.frame) (Rect.ymax Draw.frame -. 1.) in Draw.clear (); @@ -368,11 +368,11 @@ module Render = struct Draw.rect ~color:41 ball; Draw.text ~center:false ~color:30 bl (str "%s left" (str_bricks bcount)); Draw.flush () - + let game_over outcome = (* draws the game over screen. *) - let x = 0.5 *. Rect.xmax Draw.frame in + let x = 0.5 *. Rect.xmax Draw.frame in let y = 0.5 *. Rect.ymax Draw.frame in - let outcome_msg = + let outcome_msg = if outcome = 0 then "Congratulations, no bricks left" else str "%s left, you can do better" (str_bricks outcome) in @@ -388,26 +388,26 @@ end = struct let key k = E.fmap (fun c -> if c = k then Some () else None) Input.key let quit () = E.once (E.stamp (key 'q') `Quit) let new_game () = E.once (E.stamp (key ' ') `Game) - + let wait_until ?stop e = match stop with | Some s -> E.map (fun v -> s (); v) (E.once e) | None -> E.once e - + let intro () = let color_swap = E.stamp Input.time (fun c -> if c = 31 then 34 else 31) in let output = S.l1 Render.intro (S.accum color_swap 34) in let stop () = S.stop output in wait_until (E.select [quit (); new_game ()]) ~stop - + let game () = let run = S.hold false (E.once (E.stamp (key ' ') true)) in let moves = let move = function 'a' -> Some `Left | 'd' -> Some `Right | _ -> None in E.on run (E.fmap move Input.key) in - let dt = E.on run (E.diff ( -. ) Input.time) in + let dt = E.on run (E.diff ( -. ) Input.time) in let g = Game.create Draw.frame dt moves in - let outcome = Game.outcome g in + let outcome = Game.outcome g in let sound = E.map Draw.beep (Game.collisions g) in let output = S.l4 Render.game (Game.ball g) (Game.paddle g) (Game.bricks g) (Game.brick_count g) @@ -416,13 +416,13 @@ end = struct Render.game_init "Hit spacebar to start the game"; wait_until (E.select [quit (); outcome]) ~stop - let game_over outcome = - Render.game_over outcome; + let game_over outcome = + Render.game_over outcome; wait_until (E.select [quit (); new_game ()]) - let init () = - let define ui = - let display ui = + let init () = + let define ui = + let display ui = Gc.full_major (); (* cleanup game objects. *) match ui with | `Intro -> intro () @@ -433,15 +433,15 @@ end = struct let ui' = E.switch (display `Intro) (E.map display ui) in ui', ui' in - E.stamp (E.fix define) () + E.stamp (E.fix define) () end -let main () = +let main () = Random.self_init (); Log.init (); Draw.init (); Input.init (); - let ui = Ui.init () in + let ui = Ui.init () in Input.gather (); ui @@ -454,7 +454,7 @@ let ui = main () (* keep a ref. to avoid g.c. *) Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. diff --git a/test/clock.ml b/test/clock.ml index dc7e2ce..8b957a8 100644 --- a/test/clock.ml +++ b/test/clock.ml @@ -1,18 +1,18 @@ -(* This code is in the public domain. +(* This code is in the public domain. Prints a clock with the current local time in the terminal. *) - -let pr_time t = + +let pr_time t = let tm = Unix.localtime t in - Printf.printf "\x1B[8D%02d:%02d:%02d%!" + Printf.printf "\x1B[8D%02d:%02d:%02d%!" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec - + open React;; -let seconds, run = +let seconds, run = let e, send = E.create () in let run () = while true do send (Unix.gettimeofday ()); Unix.sleep 1 done in e, run let printer = E.map pr_time seconds - + let () = run () diff --git a/test/js_test.ml b/test/js_test.ml index 81c37ea..853fff0 100644 --- a/test/js_test.ml +++ b/test/js_test.ml @@ -2,11 +2,11 @@ open React -let strong = true +let strong = true -(* Artificially increase memory usage *) -let high_e e = - let id e = E.map (fun v -> v) e in +(* Artificially increase memory usage *) +let high_e e = + let id e = E.map (fun v -> v) e in id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ @@ -25,24 +25,24 @@ let high_e e = id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ id @@ e -let counter_ui = +let counter_ui = let none () = assert false in let el = Dom_html.window ## document ## getElementById (Js.string "count") in Js.Opt.get el none let count = ref 0 -let incr_counter () = - incr count; +let incr_counter () = + incr count; counter_ui ## innerHTML <- Js.string (string_of_int !count) - + let tick, send_tick = E.create () -let rec loop () = +let rec loop () = let ev = E.map (fun () -> incr_counter ()) (high_e tick) in send_tick (); E.stop ~strong ev; ignore (Dom_html.window ## setTimeout (Js.wrap_callback loop, 1.)) - + let main _ = loop (); Js._false diff --git a/test/test.ml b/test/test.ml index 0cffb9d..d1f8633 100644 --- a/test/test.ml +++ b/test/test.ml @@ -4,25 +4,25 @@ ---------------------------------------------------------------------------*) (* Tests for react's combinators. - Compile with -g to get a precise backtrace to the error. + Compile with -g to get a precise backtrace to the error. Note that the testing mechanism itself (cf. occs and vals) needs a correct implementation; particulary w.r.t. updates with side effects. *) open React;; -let pp_list ppv pp l = - Format.fprintf pp "@[["; +let pp_list ppv pp l = + Format.fprintf pp "@[["; List.iter (fun v -> Format.fprintf pp "%a;@ " ppv v) l; Format.fprintf pp "]@]" - -let pr_value pp name v = Format.printf "@[<hov 2>%s =@ %a@]@." name pp v + +let pr_value pp name v = Format.printf "@[<hov 2>%s =@ %a@]@." name pp v let e_pr ?iff pp name e = E.trace ?iff (pr_value pp name) e let s_pr ?iff pp name s = S.trace ?iff (pr_value pp name) s - + (* Tests the event e has occurences occs. *) -let occs ?(eq = ( = )) e occs = - let occs = ref occs in +let occs ?(eq = ( = )) e occs = + let occs = ref occs in let assert_occ o = match !occs with | o' :: occs' when eq o' o -> occs := occs' | _ -> assert false @@ -30,10 +30,10 @@ let occs ?(eq = ( = )) e occs = E.map assert_occ e, occs (* Tests the signal s goes through vals. *) -let vals ?(eq = ( = )) s vals = - let vals = ref vals in +let vals ?(eq = ( = )) s vals = + let vals = ref vals in let assert_val v = match !vals with - | v' :: vals' when eq v' v -> vals := vals' + | v' :: vals' when eq v' v -> vals := vals' | _ -> assert false in S.map assert_val s, vals @@ -46,42 +46,42 @@ let assert_e_stub () = ref (occs E.never []) let assert_s_stub v = ref (vals (S.const v) [v]) (* To keep references for the g.c. (warning also stops the given nodes) *) -let keep_eref e = E.stop e -let keep_sref s = S.stop s +let keep_eref e = E.stop e +let keep_sref s = S.stop s (* To artificially raise the rank of events and signals *) -let high_e e = +let high_e e = let id e = E.map (fun v -> v) e in (id (id (id (id (id (id (id (id e)))))))) -let high_s s = +let high_s s = let id s = S.map (fun v -> v) s in (id (id (id (id (id (id (id (id s)))))))) (* Event tests *) -let test_no_leak () = - let x, send_x = E.create () in +let test_no_leak () = + let x, send_x = E.create () in let count = ref 0 in - let w = - let w = Weak.create 1 in - let e = E.map (fun x -> incr count) x in + let w = + let w = Weak.create 1 in + let e = E.map (fun x -> incr count) x in Weak.set w 0 (Some e); w in List.iter send_x [0; 1; 2]; - Gc.full_major (); + Gc.full_major (); List.iter send_x [3; 4; 5]; (match Weak.get w 0 with None -> () | Some _ -> assert false); if !count > 3 then assert false else () -let test_once_drop_once () = - let w, send_w = E.create () in - let x = E.once w in - let y = E.drop_once w in - let assert_x = occs x [0] in +let test_once_drop_once () = + let w, send_w = E.create () in + let x = E.once w in + let y = E.drop_once w in + let assert_x = occs x [0] in let assert_y = occs y [1; 2; 3] in let assert_dx = assert_e_stub () in let assert_dy = assert_e_stub () in - let dyn () = + let dyn () = let dx = E.once w in let dy = E.drop_once w in assert_dx := occs dx [1]; @@ -93,42 +93,42 @@ let test_once_drop_once () = List.iter empty [assert_x; assert_y; !assert_dx; !assert_dy]; keep_eref create_dyn -let test_app () = - let f x y = x + y in +let test_app () = + let f x y = x + y in let w, send_w = E.create () in let x = E.map (fun w -> f w) w in let y = E.drop_once w in - let z = E.app x y in + let z = E.app x y in let assert_z = occs z [ 2; 4; 6 ] in let assert_dz = assert_e_stub () in - let dyn () = - let dx = E.drop_once (E.map (fun w -> f w) w) in - let dz = E.app dx y in + let dyn () = + let dx = E.drop_once (E.map (fun w -> f w) w) in + let dz = E.app dx y in assert_dz := occs dz [ 4; 6 ]; in - let create_dyn = E.map (fun v -> if v = 1 then dyn ()) w in + let create_dyn = E.map (fun v -> if v = 1 then dyn ()) w in Gc.full_major (); List.iter send_w [0; 1; 2; 3]; List.iter empty [assert_z; !assert_dz]; keep_eref create_dyn -let test_map_stamp_filter_fmap () = - let v, send_v = E.create () in +let test_map_stamp_filter_fmap () = + let v, send_v = E.create () in let w = E.map (fun s -> "z:" ^ s) v in - let x = E.stamp v "bla" in + let x = E.stamp v "bla" in let y = E.filter (fun s -> String.length s = 5) v in let z = E.fmap (fun s -> if s = "blu" then Some "hip" else None) v in let assert_w = occs w ["z:didap"; "z:dip"; "z:didop"; "z:blu"] in let assert_x = occs x ["bla"; "bla"; "bla"; "bla"] in let assert_y = occs y ["didap"; "didop"] in - let assert_z = occs z ["hip"] in + let assert_z = occs z ["hip"] in let assert_dw = assert_e_stub () in let assert_dx = assert_e_stub () in let assert_dy = assert_e_stub () in let assert_dz = assert_e_stub () in - let dyn () = + let dyn () = let dw = E.map (fun s -> String.length s) v in - let dx = E.stamp v 4 in + let dx = E.stamp v 4 in let dy = E.filter (fun s -> String.length s = 5) v in let dz = E.fmap (fun s -> if s = "didap" then Some "ha" else None) v in let _ = E.map (fun _ -> assert false) (E.fmap (fun _ -> None) x) in @@ -137,7 +137,7 @@ let test_map_stamp_filter_fmap () = assert_dy := occs dy ["didap"; "didop"]; assert_dz := occs dz ["ha"]; in - let create_dyn = E.map (fun v -> if v = "didap" then dyn ()) v in + let create_dyn = E.map (fun v -> if v = "didap" then dyn ()) v in Gc.full_major (); List.iter send_v ["didap"; "dip"; "didop"; "blu"]; List.iter empty [assert_w; assert_x; assert_y; assert_z]; @@ -145,17 +145,17 @@ let test_map_stamp_filter_fmap () = List.iter empty [!assert_dy; !assert_dz]; keep_eref create_dyn -let test_diff_changes () = - let x, send_x = E.create () in - let y = E.diff ( - ) x in - let z = E.changes x in - let assert_y = occs y [ 0; 1; 1; 0] in +let test_diff_changes () = + let x, send_x = E.create () in + let y = E.diff ( - ) x in + let z = E.changes x in + let assert_y = occs y [ 0; 1; 1; 0] in let assert_z = occs z [ 1; 2; 3] in let assert_dy = assert_e_stub () in let assert_dz = assert_e_stub () in - let dyn () = - let dy = E.diff ( - ) x in - let dz = E.changes z in + let dyn () = + let dy = E.diff ( - ) x in + let dz = E.changes z in assert_dy := occs dy [1; 0]; assert_dz := occs dz [2; 3]; in @@ -165,33 +165,33 @@ let test_diff_changes () = List.iter empty [assert_y; assert_z; !assert_dy; !assert_dz]; keep_eref create_dyn -let test_dismiss () = - let x, send_x = E.create () in - let y = E.fmap (fun x -> if x mod 2 = 0 then Some x else None) x in - let z = E.dismiss y x in +let test_dismiss () = + let x, send_x = E.create () in + let y = E.fmap (fun x -> if x mod 2 = 0 then Some x else None) x in + let z = E.dismiss y x in let assert_z = occs z [1; 3; 5] in - let assert_dz = assert_e_stub () in - let dyn () = - let dz = E.dismiss y x in + let assert_dz = assert_e_stub () in + let dyn () = + let dz = E.dismiss y x in assert_dz := occs dz [3; 5]; in - let create_dyn = E.map (fun v -> if v = 2 then dyn()) x in + let create_dyn = E.map (fun v -> if v = 2 then dyn()) x in Gc.full_major (); List.iter send_x [0; 1; 2; 3; 4; 5]; List.iter empty [assert_z; !assert_dz]; keep_eref create_dyn -let test_on () = - let e, send_e = E.create () in - let s = S.hold 0 e in +let test_on () = + let e, send_e = E.create () in + let s = S.hold 0 e in let c = S.map (fun x -> x mod 2 = 0) s in - let w = E.on c e in + let w = E.on c e in let ovals = [2; 4; 4; 6; 4] in let assert_w = occs w ovals in let assert_dw = assert_e_stub () in let assert_dhw = assert_e_stub () in - let dyn () = - let dw = E.on c e in + let dyn () = + let dw = E.on c e in let dhw = E.on (high_s c) (high_e e) in assert_dw := occs dw ovals; assert_dhw := occs dhw ovals @@ -202,31 +202,31 @@ let test_on () = List.iter empty [assert_w; !assert_dw; !assert_dhw ]; keep_eref create_dyn -let test_until () = - let x, send_x = E.create () in - let stop = E.filter (fun v -> v = 3) x in +let test_until () = + let x, send_x = E.create () in + let stop = E.filter (fun v -> v = 3) x in let e = E.until stop x in let assert_e = occs e [1; 2] in let assert_de = assert_e_stub () in let assert_de' = assert_e_stub () in - let dyn () = + let dyn () = let de = E.until stop x in let de' = E.until (E.filter (fun v -> v = 5) x) x in assert_de := occs de []; assert_de' := occs de' [3; 4] in let create_dyn = E.map (fun v -> if v = 3 then dyn ()) x in - Gc.full_major (); + Gc.full_major (); List.iter send_x [1; 2; 3; 4; 5]; List.iter empty [assert_e; !assert_de; !assert_de']; keep_eref create_dyn -let test_accum () = - let f, send_f = E.create () in - let a = E.accum f 0 in +let test_accum () = + let f, send_f = E.create () in + let a = E.accum f 0 in let assert_a = occs a [2; -1; -2] in - let assert_da = assert_e_stub () in - let dyn () = + let assert_da = assert_e_stub () in + let dyn () = let da = E.accum f 0 in assert_da := occs da [1; 2]; in @@ -234,70 +234,70 @@ let test_accum () = let count = ref 0 in E.map (fun _ -> incr count; if !count = 2 then dyn ()) f in - Gc.full_major (); + Gc.full_major (); List.iter send_f [( + ) 2; ( - ) 1; ( * ) 2]; List.iter empty [assert_a; !assert_da]; keep_eref create_dyn - + let test_fold () = - let x, send_x = E.create () in - let c = E.fold ( + ) 0 x in + let x, send_x = E.create () in + let c = E.fold ( + ) 0 x in let assert_c = occs c [1; 3; 6; 10] in - let assert_dc = assert_e_stub () in - let dyn () = + let assert_dc = assert_e_stub () in + let dyn () = let dc = E.fold ( + ) 0 x in - assert_dc := occs dc [2; 5; 9]; + assert_dc := occs dc [2; 5; 9]; in - let create_dyn = E.map (fun v -> if v = 2 then dyn ()) x in - Gc.full_major (); + let create_dyn = E.map (fun v -> if v = 2 then dyn ()) x in + Gc.full_major (); List.iter send_x [1; 2; 3; 4]; List.iter empty [assert_c; !assert_dc]; keep_eref create_dyn -let test_select () = - let w, send_w = E.create () in - let x, send_x = E.create () in +let test_select () = + let w, send_w = E.create () in + let x, send_x = E.create () in let y = E.map succ w in let z = E.map succ y in - let tw = E.map (fun v -> `Int v) w in - let tx = E.map (fun v -> `Bool v) x in + let tw = E.map (fun v -> `Int v) w in + let tx = E.map (fun v -> `Bool v) x in let t = E.select [tw; tx] in let sy = E.select [y; z] in (* always y. *) let sz = E.select [z; y] in (* always z. *) - let assert_t = occs t [ `Int 0; `Bool false; `Int 1; `Int 2; `Int 3 ] in + let assert_t = occs t [ `Int 0; `Bool false; `Int 1; `Int 2; `Int 3 ] in let assert_sy = occs sy [1; 2; 3; 4] in let assert_sz = occs sz [2; 3; 4; 5] in let assert_d = assert_e_stub () in - let dyn () = - let d = E.select [y; w; z] in + let dyn () = + let d = E.select [y; w; z] in assert_d := occs d [3; 4] in let create_dyn = E.map (fun v -> if v = 2 then dyn ()) w in - Gc.full_major (); + Gc.full_major (); send_w 0; send_x false; List.iter send_w [1; 2; 3;]; empty assert_t; List.iter empty [assert_sy; assert_sz; !assert_d]; keep_eref create_dyn - -let test_merge () = + +let test_merge () = let w, send_w = E.create () in - let x, send_x = E.create () in + let x, send_x = E.create () in let y = E.map succ w in let z = E.merge (fun acc v -> v :: acc) [] [w; x; y] in let assert_z = occs z [[2; 1]; [4]; [3; 2]] in let assert_dz = assert_e_stub () in - let dyn () = + let dyn () = let dz = E.merge (fun acc v -> v :: acc) [] [y; x; w] in - assert_dz := occs dz [[4]; [2; 3]] + assert_dz := occs dz [[4]; [2; 3]] in let create_dyn = E.map (fun v -> if v = 4 then dyn ()) x in - Gc.full_major (); + Gc.full_major (); send_w 1; send_x 4; send_w 2; List.iter empty [assert_z; !assert_dz]; keep_eref create_dyn let test_switch () = let x, send_x = E.create () in - let switch e = + let switch e = E.fmap (fun v -> if v mod 3 = 0 then Some (E.map (( * ) v) e) else None) x in let s = E.switch x (switch x) in @@ -306,23 +306,23 @@ let test_switch () = let assert_hs = occs hs [1; 2; 9; 12; 15; 36; 42; 48; 81] in let assert_ds = assert_e_stub () in let assert_dhs = assert_e_stub () in - let dyn () = + let dyn () = let ds = E.switch x (switch x) in let dhs = E.switch x (switch (high_e x)) in assert_ds := occs ds [9; 12; 15; 36; 42; 48; 81]; assert_ds := occs dhs [9; 12; 15; 36; 42; 48; 81] in let create_dyn = E.map (fun v -> if v = 3 then dyn ()) x in - Gc.full_major (); + Gc.full_major (); List.iter send_x [1; 2; 3; 4; 5; 6; 7; 8; 9]; List.iter empty [assert_s; assert_hs; !assert_ds; !assert_dhs]; keep_eref create_dyn -let test_fix () = - let x, send_x = E.create () in +let test_fix () = + let x, send_x = E.create () in let c1 () = E.stamp x `C2 in let c2 () = E.stamp x `C1 in - let loop result = + let loop result = let switch = function `C1 -> c1 () | `C2 -> c2 () in let switcher = E.switch (c1 ()) (E.map switch result) in switcher, switcher @@ -330,74 +330,74 @@ let test_fix () = let l = E.fix loop in let assert_l = occs l [`C2; `C1; `C2] in let assert_dl = assert_e_stub () in - let dyn () = - let dl = E.fix loop in + let dyn () = + let dl = E.fix loop in assert_dl := occs dl [`C2; `C1]; in - let create_dyn = E.map (fun v -> if v = 2 then dyn ()) x in + let create_dyn = E.map (fun v -> if v = 2 then dyn ()) x in Gc.full_major (); List.iter send_x [1; 2; 3]; List.iter empty [assert_l; !assert_dl]; keep_eref create_dyn -let test_lifts () = - let x1, send_x1 = E.create () in - let x2, send_x2 = E.create () in - let x3, send_x3 = E.create () in - let x4, send_x4 = E.create () in - let x5, send_x5 = E.create () in - let x6, send_x6 = E.create () in +let test_lifts () = + let x1, send_x1 = E.create () in + let x2, send_x2 = E.create () in + let x3, send_x3 = E.create () in + let x4, send_x4 = E.create () in + let x5, send_x5 = E.create () in + let x6, send_x6 = E.create () in let f1 a = 1 + a in - let f2 a0 a1 = a0 + a1 in - let f3 a0 a1 a2 = a0 + a1 + a2 in - let f4 a0 a1 a2 a3 = a0 + a1 + a2 + a3 in - let f5 a0 a1 a2 a3 a4 = a0 + a1 + a2 + a3 + a4 in - let f6 a0 a1 a2 a3 a4 a5 = a0 + a1 + a2 + a3 + a4 + a5 in + let f2 a0 a1 = a0 + a1 in + let f3 a0 a1 a2 = a0 + a1 + a2 in + let f4 a0 a1 a2 a3 = a0 + a1 + a2 + a3 in + let f5 a0 a1 a2 a3 a4 = a0 + a1 + a2 + a3 + a4 in + let f6 a0 a1 a2 a3 a4 a5 = a0 + a1 + a2 + a3 + a4 + a5 in let v1 = E.l1 f1 x1 in let v2 = E.l2 f2 x1 x2 in let v3 = E.l3 f3 x1 x2 x3 in let v4 = E.l4 f4 x1 x2 x3 x4 in let v5 = E.l5 f5 x1 x2 x3 x4 x5 in let v6 = E.l6 f6 x1 x2 x3 x4 x5 x6 in - let a_v1 = occs v1 [2; 2; 2; 2; 2; 2;] in - let a_v2 = occs v2 [ 3; 3; 3; 3; 3;] in - let a_v3 = occs v3 [ 6; 6; 6; 6;] in - let a_v4 = occs v4 [ 10;10;10;] in - let a_v5 = occs v5 [ 15;15;] in - let a_v6 = occs v6 [ 21;] in - let with_step f = + let a_v1 = occs v1 [2; 2; 2; 2; 2; 2;] in + let a_v2 = occs v2 [ 3; 3; 3; 3; 3;] in + let a_v3 = occs v3 [ 6; 6; 6; 6;] in + let a_v4 = occs v4 [ 10;10;10;] in + let a_v5 = occs v5 [ 15;15;] in + let a_v6 = occs v6 [ 21;] in + let with_step f = let s = Step.create () in - f s; Step.execute s + f s; Step.execute s in - let s1 s = send_x1 ~step:s 1 in - let s2 s = s1 s; send_x2 ~step:s 2 in + let s1 s = send_x1 ~step:s 1 in + let s2 s = s1 s; send_x2 ~step:s 2 in let s3 s = s2 s; send_x3 ~step:s 3 in let s4 s = s3 s; send_x4 ~step:s 4 in let s5 s = s4 s; send_x5 ~step:s 5 in let s6 s = s5 s; send_x6 ~step:s 6 in - with_step s1; with_step s2; with_step s3; - with_step s4; with_step s5; with_step s6; - List.iter empty [ a_v1; a_v2; a_v3; a_v4; a_v5; a_v6;]; + with_step s1; with_step s2; with_step s3; + with_step s4; with_step s5; with_step s6; + List.iter empty [ a_v1; a_v2; a_v3; a_v4; a_v5; a_v6;]; () - -let test_option () = - let x, send_x = E.create () in - let s, set_s = S.create 4 in - let some = E.Option.some (S.changes s) in - let e0 = E.Option.value x in - let e1 = E.Option.value ~default:(S.const 2) x in - let e2 = E.Option.value ~default:s x in - let assert_some = occs some [ Some 42;] in - let assert_e0 = occs e0 [1; 5; ] in - let assert_e1 = occs e1 [1; 2; 5; 2] in - let assert_e2 = occs e2 [1; 4; 5; 42] in - send_x (Some 1); send_x None; set_s 42; - send_x (Some 5); send_x None; + +let test_option () = + let x, send_x = E.create () in + let s, set_s = S.create 4 in + let some = E.Option.some (S.changes s) in + let e0 = E.Option.value x in + let e1 = E.Option.value ~default:(S.const 2) x in + let e2 = E.Option.value ~default:s x in + let assert_some = occs some [ Some 42;] in + let assert_e0 = occs e0 [1; 5; ] in + let assert_e1 = occs e1 [1; 2; 5; 2] in + let assert_e2 = occs e2 [1; 4; 5; 42] in + send_x (Some 1); send_x None; set_s 42; + send_x (Some 5); send_x None; empty assert_some; List.iter empty [ assert_e0; assert_e1; assert_e2]; () -let test_events () = +let test_events () = test_no_leak (); test_once_drop_once (); test_app (); @@ -411,38 +411,38 @@ let test_events () = test_select (); test_merge (); test_switch (); - test_fix (); - test_lifts (); + test_fix (); + test_lifts (); test_option (); () (* Signal tests *) -let test_no_leak () = - let x, set_x = S.create 0 in +let test_no_leak () = + let x, set_x = S.create 0 in let count = ref 0 in - let w = - let w = Weak.create 1 in - let e = S.map (fun x -> incr count) x in + let w = + let w = Weak.create 1 in + let e = S.map (fun x -> incr count) x in Weak.set w 0 (Some e); w in List.iter set_x [ 0; 1; 2]; - Gc.full_major (); + Gc.full_major (); List.iter set_x [ 3; 4; 5]; (match Weak.get w 0 with None -> () | Some _ -> assert false); if !count > 3 then assert false else () -let test_hold () = +let test_hold () = let e, send_e = E.create () in let e', send_e' = E.create () in let he = high_e e in - let s = S.hold 1 e in + let s = S.hold 1 e in let assert_s = vals s [1; 2; 3; 4] in let assert_ds = assert_s_stub 0 in let assert_dhs = assert_s_stub 0 in - let assert_ds' = assert_s_stub 0 in - let dyn () = + let assert_ds' = assert_s_stub 0 in + let dyn () = let ds = S.hold 42 e in (* init value unused. *) let dhs = S.hold 44 he in (* init value unused. *) let ds' = S.hold 128 e' in (* init value used. *) @@ -455,20 +455,20 @@ let test_hold () = List.iter send_e [ 1; 1; 1; 1; 2; 2; 2; 3; 3; 3]; List.iter send_e' [2; 4]; List.iter send_e [4; 4; 4]; - List.iter empty [assert_s; !assert_ds; !assert_dhs; !assert_ds']; + List.iter empty [assert_s; !assert_ds; !assert_dhs; !assert_ds']; keep_sref create_dyn -let test_app () = - let f x y = x + y in - let fl x y = S.app (S.app ~eq:(==) (S.const f) x) y in +let test_app () = + let f x y = x + y in + let fl x y = S.app (S.app ~eq:(==) (S.const f) x) y in let x, set_x = S.create 0 in let y, set_y = S.create 0 in - let z = fl x y in + let z = fl x y in let assert_z = vals z [ 0; 1; 3; 4 ] in let assert_dz = assert_s_stub 0 in let assert_dhz = assert_s_stub 0 in - let dyn () = - let dz = fl x y in + let dyn () = + let dz = fl x y in let dhz = fl (high_s x) (high_s y) in assert_dz := vals dz [3; 4]; assert_dhz := vals dhz [3; 4]; @@ -479,13 +479,13 @@ let test_app () = List.iter empty [assert_z; !assert_dz; !assert_dhz]; keep_sref create_dyn -let test_map_filter_fmap () = - let even x = x mod 2 = 0 in +let test_map_filter_fmap () = + let even x = x mod 2 = 0 in let odd x = x mod 2 <> 0 in let meven x = if even x then Some (x * 2) else None in let modd x = if odd x then Some (x * 2) else None in let double x = 2 * x in - let x, set_x = S.create 1 in + let x, set_x = S.create 1 in let x2 = S.map double x in let fe = S.filter even 56 x in let fo = S.filter odd 56 x in @@ -498,7 +498,7 @@ let test_map_filter_fmap () = let assert_fmo = vals fmo [ 2; 6; 10;] in let assert_dx2 = assert_s_stub 0 in let assert_dhx2 = assert_s_stub 0 in - let assert_dfe = assert_s_stub 0 in + let assert_dfe = assert_s_stub 0 in let assert_dhfe = assert_s_stub 0 in let assert_dfo = assert_s_stub 0 in let assert_dhfo = assert_s_stub 0 in @@ -507,7 +507,7 @@ let test_map_filter_fmap () = let assert_dfmo = assert_s_stub 0 in let assert_dhfmo = assert_s_stub 0 in let dyn () = - let dx2 = S.map double x in + let dx2 = S.map double x in let dhx2 = S.map double (high_s x) in let dfe = S.filter even 56 x in let dhfe = S.filter even 56 (high_s x) in @@ -531,26 +531,26 @@ let test_map_filter_fmap () = in let create_dyn = S.map (fun v -> if v = 3 then dyn ()) x in Gc.full_major (); - List.iter set_x [ 1; 2; 3; 4; 4; 5; 5]; + List.iter set_x [ 1; 2; 3; 4; 4; 5; 5]; List.iter empty [assert_x2; assert_fe; assert_fo; assert_fme; - assert_fmo; !assert_dx2; !assert_dhx2; !assert_dfe; - !assert_dhfe; !assert_dfo ; !assert_dhfo; !assert_dfme ; + assert_fmo; !assert_dx2; !assert_dhx2; !assert_dfe; + !assert_dhfe; !assert_dfo ; !assert_dhfo; !assert_dfme ; !assert_dhfme ; !assert_dfmo ; !assert_dhfmo ]; keep_sref create_dyn -let test_diff_changes () = +let test_diff_changes () = let e, send_e = E.create () in let s = S.hold 1 e in - let d = S.diff (fun x y -> x - y) s in + let d = S.diff (fun x y -> x - y) s in let c = S.changes s in let assert_dd = assert_e_stub () in let assert_dhd = assert_e_stub () in let assert_dc = assert_e_stub () in let assert_dhc = assert_e_stub () in - let dyn () = - let dd = S.diff (fun x y -> x - y) s in - let dhd = S.diff (fun x y -> x - y) (high_s s) in + let dyn () = + let dd = S.diff (fun x y -> x - y) s in + let dhd = S.diff (fun x y -> x - y) (high_s s) in let dc = S.changes s in let dhc = S.changes (high_s s) in assert_dd := occs dd [1]; @@ -562,22 +562,22 @@ let test_diff_changes () = let assert_d = occs d [2; 1] in let assert_c = occs c [3; 4] in Gc.full_major (); - List.iter send_e [1; 1; 3; 3; 4; 4]; + List.iter send_e [1; 1; 3; 3; 4; 4]; List.iter empty [assert_d; assert_c; !assert_dd; !assert_dhd; !assert_dc; !assert_dhc]; keep_sref create_dyn -let test_sample () = +let test_sample () = let pair v v' = v, v' in - let e, send_e = E.create () in - let sampler () = E.filter (fun x -> x mod 2 = 0) e in - let s = S.hold 0 e in + let e, send_e = E.create () in + let sampler () = E.filter (fun x -> x mod 2 = 0) e in + let s = S.hold 0 e in let sam = S.sample pair (sampler ()) s in let ovals = [ (2, 2); (2, 2); (4, 4); (4, 4)] in let assert_sam = occs sam ovals in let assert_dsam = assert_e_stub () in let assert_dhsam = assert_e_stub () in - let dyn () = + let dyn () = let dsam = S.sample pair (sampler ()) s in let dhsam = S.sample pair (high_e (sampler ())) (high_s s) in assert_dsam := occs dsam ovals; @@ -590,18 +590,18 @@ let test_sample () = keep_sref create_dyn let test_on () = - let s, set_s = S.create 0 in - let ce = S.map (fun x -> x mod 2 = 0) s in + let s, set_s = S.create 0 in + let ce = S.map (fun x -> x mod 2 = 0) s in let co = S.map (fun x -> x mod 2 <> 0) s in - let se = S.on ce 42 s in - let so = S.on co 56 s in + let se = S.on ce 42 s in + let so = S.on co 56 s in let assert_se = vals se [ 0; 2; 4; 6; 4 ] in let assert_so = vals so [ 56; 1; 3; 1; 3 ] in let assert_dse = assert_s_stub 0 in let assert_dhse = assert_s_stub 0 in let assert_dso = assert_s_stub 0 in let assert_dhso = assert_s_stub 0 in - let dyn () = + let dyn () = let dse = S.on ce 42 s in let dhse = S.on ce 42 (high_s s) in let dso = S.on co 56 s in @@ -618,52 +618,52 @@ let test_on () = !assert_dso; !assert_dhso]; keep_sref create_dyn -let test_dismiss () = - let x, send_x = E.create () in - let y = E.fmap (fun x -> if x mod 2 = 0 then Some x else None) x in - let z = S.dismiss y 4 (S.hold 44 x) in +let test_dismiss () = + let x, send_x = E.create () in + let y = E.fmap (fun x -> if x mod 2 = 0 then Some x else None) x in + let z = S.dismiss y 4 (S.hold 44 x) in let assert_z = vals z [44; 1; 3; 5] in - let assert_dz = assert_s_stub 0 in - let dyn () = - let dz = S.dismiss y 4 (S.hold 44 x) in + let assert_dz = assert_s_stub 0 in + let dyn () = + let dz = S.dismiss y 4 (S.hold 44 x) in assert_dz := vals dz [4; 3; 5]; in - let create_dyn = E.map (fun v -> if v = 2 then dyn()) x in + let create_dyn = E.map (fun v -> if v = 2 then dyn()) x in Gc.full_major (); List.iter send_x [0; 1; 2; 3; 4; 5]; List.iter empty [assert_z; !assert_dz]; keep_eref create_dyn -let test_accum () = - let f, send_f = E.create () in - let a = S.accum f 0 in +let test_accum () = + let f, send_f = E.create () in + let a = S.accum f 0 in let assert_a = vals a [ 0; 2; -1; -2] in - let assert_da = assert_s_stub 0 in - let assert_dha = assert_s_stub 0 in - let dyn () = + let assert_da = assert_s_stub 0 in + let assert_dha = assert_s_stub 0 in + let dyn () = let da = S.accum f 3 in - let dha = S.accum (high_e f) 3 in + let dha = S.accum (high_e f) 3 in assert_da := vals da [-2; -4]; assert_dha := vals dha [-2; -4] in let create_dyn = - let count = ref 0 in + let count = ref 0 in E.map (fun _ -> incr count; if !count = 2 then dyn()) f in Gc.full_major (); List.iter send_f [( + ) 2; ( - ) 1; ( * ) 2]; List.iter empty [assert_a; !assert_da; !assert_dha]; keep_eref create_dyn - -let test_fold () = - let x, send_x = E.create () in - let c = S.fold ( + ) 0 x in - let assert_c = vals c [ 0; 1; 3; 6; 10] in + +let test_fold () = + let x, send_x = E.create () in + let c = S.fold ( + ) 0 x in + let assert_c = vals c [ 0; 1; 3; 6; 10] in let assert_dc = assert_s_stub 0 in let assert_dhc = assert_s_stub 0 in - let dyn () = - let dc = S.fold ( + ) 2 x in - let dhc = S.fold ( + ) 2 (high_e x) in + let dyn () = + let dc = S.fold ( + ) 2 x in + let dhc = S.fold ( + ) 2 (high_e x) in assert_dc := vals dc [4; 7; 11]; assert_dhc := vals dhc [4; 7; 11] in @@ -671,18 +671,18 @@ let test_fold () = Gc.full_major (); List.iter send_x [1; 2; 3; 4]; List.iter empty [assert_c; !assert_dc; !assert_dhc ]; - keep_eref create_dyn + keep_eref create_dyn -let test_merge () = +let test_merge () = let cons acc v = v :: acc in let w, set_w = S.create 0 in - let x, set_x = S.create 1 in + let x, set_x = S.create 1 in let y = S.map succ w in let z = S.map List.rev (S.merge cons [] [w; x; y]) in let assert_z = vals z [[0; 1; 1]; [1; 1; 2]; [1; 4; 2]; [2; 4; 3]] in let assert_dz = assert_s_stub [] in let assert_dhz = assert_s_stub [] in - let dyn () = + let dyn () = let dz = S.map List.rev (S.merge cons [] [w; x; y]) in let dhz = S.map List.rev (S.merge cons [] [(high_s w); x; y; S.const 2]) in assert_dz := vals dz [[1; 4; 2]; [2; 4; 3]]; @@ -695,38 +695,38 @@ let test_merge () = keep_sref create_dyn let esswitch s es = (* Pre 1.0.0 S.switch *) - S.switch (S.hold ~eq:( == ) s es) - + S.switch (S.hold ~eq:( == ) s es) + let test_switch () = let s, set_s = S.create 0 in - let switch s = - let map v = - if v mod 3 = 0 && v <> 0 then Some (S.map (( * ) v) s) else None + let switch s = + let map v = + if v mod 3 = 0 && v <> 0 then Some (S.map (( * ) v) s) else None in S.fmap ~eq:( == ) map s s in - let sw = S.switch (switch s) in - let hsw = S.switch (switch (high_s s)) in + let sw = S.switch (switch s) in + let hsw = S.switch (switch (high_s s)) in let assert_sw = vals sw [0; 1; 2; 9; 12; 15; 36; 42; 48; 81] in let assert_hsw = vals hsw [0; 1; 2; 9; 12; 15; 36; 42; 48; 81] in let assert_dsw = assert_s_stub 0 in let assert_dhsw = assert_s_stub 0 in - let dyn () = - let dsw = S.switch (switch s) in + let dyn () = + let dsw = S.switch (switch s) in let dhsw = S.switch (switch (high_s s)) in assert_dsw := vals dsw [9; 12; 15; 36; 42; 48; 81]; assert_dhsw := vals dhsw [9; 12; 15; 36; 42; 48; 81]; in - let create_dyn = S.map (fun v -> if v = 3 then dyn ()) s in - Gc.full_major (); + let create_dyn = S.map (fun v -> if v = 3 then dyn ()) s in + Gc.full_major (); List.iter set_s [1; 1; 2; 2; 3; 4; 4; 5; 5; 6; 6; 7; 7; 8; 8; 9; 9]; - List.iter empty [assert_sw; assert_hsw; !assert_dsw; !assert_dhsw ]; + List.iter empty [assert_sw; assert_hsw; !assert_dsw; !assert_dhsw ]; keep_sref create_dyn let test_esswitch () = - let x, send_x = E.create () in + let x, send_x = E.create () in let s = S.hold 0 x in - let switch s = + let switch s = E.fmap (fun v -> if v mod 3 = 0 then Some (S.map (( * ) v) s) else None) x in let sw = esswitch s (switch s) in @@ -735,45 +735,45 @@ let test_esswitch () = let assert_hsw = vals hsw [0; 1; 2; 9; 12; 15; 36; 42; 48; 81] in let assert_dsw = assert_s_stub 0 in let assert_dhsw = assert_s_stub 0 in - let dyn () = - let dsw = esswitch s (switch s) in + let dyn () = + let dsw = esswitch s (switch s) in let dhsw = esswitch s (switch (high_s s)) in assert_dsw := vals dsw [9; 12; 15; 36; 42; 48; 81]; assert_dhsw := vals dhsw [9; 12; 15; 36; 42; 48; 81]; in - let create_dyn = E.map (fun v -> if v = 3 then dyn ()) x in + let create_dyn = E.map (fun v -> if v = 3 then dyn ()) x in Gc.full_major (); List.iter send_x [1; 1; 2; 2; 3; 4; 4; 5; 5; 6; 6; 7; 7; 8; 8; 9; 9]; List.iter empty [assert_sw; assert_hsw; !assert_dsw; !assert_dhsw ]; keep_eref create_dyn let test_switch_const () = - let s, set_s = S.create 0 in + let s, set_s = S.create 0 in let switch = S.map (fun x -> S.const x) s in let sw = S.switch switch in let assert_sw = vals sw [0; 1; 2; 3] in - let assert_dsw = assert_s_stub 0 in - let dyn () = - let dsw = S.switch switch in + let assert_dsw = assert_s_stub 0 in + let dyn () = + let dsw = S.switch switch in assert_dsw := vals dsw [2; 3]; in - let create_dyn = S.map (fun v -> if v = 2 then dyn ()) s in + let create_dyn = S.map (fun v -> if v = 2 then dyn ()) s in Gc.full_major (); List.iter set_s [0; 1; 2; 3]; List.iter empty [assert_sw; !assert_dsw ]; keep_sref create_dyn -let test_esswitch_const () = - let x, send_x = E.create () in +let test_esswitch_const () = + let x, send_x = E.create () in let switch = E.map (fun x -> S.const x) x in let sw = esswitch (S.const 0) switch in let assert_sw = vals sw [0; 1; 2; 3] in - let assert_dsw = assert_s_stub 0 in - let dyn () = - let dsw = esswitch (S.const 0) switch in + let assert_dsw = assert_s_stub 0 in + let dyn () = + let dsw = esswitch (S.const 0) switch in assert_dsw := vals dsw [2; 3]; in - let create_dyn = E.map (fun v -> if v = 2 then dyn ()) x in + let create_dyn = E.map (fun v -> if v = 2 then dyn ()) x in Gc.full_major (); List.iter send_x [0; 1; 2; 3]; List.iter empty [assert_sw; !assert_dsw ]; @@ -781,48 +781,48 @@ let test_esswitch_const () = let test_switch1 () = (* dynamic creation depends on triggering prim. *) let x, set_x = S.create 0 in - let dcount = ref 0 in - let assert_d1 = assert_s_stub 0 in - let assert_d2 = assert_s_stub 0 in - let assert_d3 = assert_s_stub 0 in - let dyn v = + let dcount = ref 0 in + let assert_d1 = assert_s_stub 0 in + let assert_d2 = assert_s_stub 0 in + let assert_d3 = assert_s_stub 0 in + let dyn v = let d = S.map (fun x -> v * x) x in - begin match !dcount with + begin match !dcount with | 0 -> assert_d1 := vals d [9; 12; 15; 18; 21; 24; 27] | 1 -> assert_d2 := vals d [36; 42; 48; 54] | 2 -> assert_d3 := vals d [81] - | _ -> assert false + | _ -> assert false end; incr dcount; d in - let change x = if x mod 3 = 0 && x <> 0 then Some (dyn x) else None in - let s = S.switch (S.fmap change x x) in + let change x = if x mod 3 = 0 && x <> 0 then Some (dyn x) else None in + let s = S.switch (S.fmap change x x) in let assert_s = vals s [0; 1; 2; 9; 12; 15; 36; 42; 48; 81 ] in Gc.full_major (); List.iter set_x [1; 1; 2; 3; 3; 4; 5; 6; 6; 7; 8; 9; 9 ]; List.iter empty [assert_s; !assert_d1; !assert_d2; !assert_d3] - -let test_esswitch1 () = + +let test_esswitch1 () = let ex, send_x = E.create () in let x = S.hold 0 ex in - let dcount = ref 0 in - let assert_d1 = assert_s_stub 0 in - let assert_d2 = assert_s_stub 0 in - let assert_d3 = assert_s_stub 0 in - let dyn v = + let dcount = ref 0 in + let assert_d1 = assert_s_stub 0 in + let assert_d2 = assert_s_stub 0 in + let assert_d3 = assert_s_stub 0 in + let dyn v = let d = S.map (fun x -> v * x) x in - begin match !dcount with + begin match !dcount with | 0 -> assert_d1 := vals d [9; 12; 15; 18; 21; 24; 27] | 1 -> assert_d2 := vals d [36; 42; 48; 54] | 2 -> assert_d3 := vals d [81] - | _ -> assert false + | _ -> assert false end; incr dcount; d in - let change x = if x mod 3 = 0 then Some (dyn x) else None in - let s = esswitch x (E.fmap change (S.changes x)) in + let change x = if x mod 3 = 0 then Some (dyn x) else None in + let s = esswitch x (E.fmap change (S.changes x)) in let assert_s = vals s [0; 1; 2; 9; 12; 15; 36; 42; 48; 81 ] in Gc.full_major (); List.iter send_x [1; 1; 2; 3; 3; 4; 5; 6; 6; 7; 8; 9; 9 ]; @@ -831,23 +831,23 @@ let test_esswitch1 () = let test_switch2 () = (* test_switch1 + high rank. *) let x, set_x = S.create 0 in let high_x = high_s x in - let dcount = ref 0 in - let assert_d1 = assert_s_stub 0 in - let assert_d2 = assert_s_stub 0 in - let assert_d3 = assert_s_stub 0 in - let dyn v = + let dcount = ref 0 in + let assert_d1 = assert_s_stub 0 in + let assert_d2 = assert_s_stub 0 in + let assert_d3 = assert_s_stub 0 in + let dyn v = let d = S.map (fun x -> v * x) high_x in - begin match !dcount with + begin match !dcount with | 0 -> assert_d1 := vals d [9; 12; 15; 18; 21; 24; 27] | 1 -> assert_d2 := vals d [36; 42; 48; 54] | 2 -> assert_d3 := vals d [81] - | _ -> assert false + | _ -> assert false end; incr dcount; d in - let change x = if x mod 3 = 0 && x <> 0 then Some (dyn x) else None in - let s = S.switch (S.fmap change x x) in + let change x = if x mod 3 = 0 && x <> 0 then Some (dyn x) else None in + let s = S.switch (S.fmap change x x) in let assert_s = vals s [0; 1; 2; 9; 12; 15; 36; 42; 48; 81 ] in Gc.full_major (); List.iter set_x [1; 1; 2; 3; 3; 4; 5; 6; 6; 7; 8; 9; 9 ]; @@ -855,50 +855,50 @@ let test_switch2 () = (* test_switch1 + high rank. *) let test_esswitch2 () = (* test_esswitch1 + high rank. *) let ex, send_x = E.create () in - let x = S.hold 0 ex in + let x = S.hold 0 ex in let high_x = high_s x in - let dcount = ref 0 in - let assert_d1 = assert_s_stub 0 in - let assert_d2 = assert_s_stub 0 in - let assert_d3 = assert_s_stub 0 in - let dyn v = + let dcount = ref 0 in + let assert_d1 = assert_s_stub 0 in + let assert_d2 = assert_s_stub 0 in + let assert_d3 = assert_s_stub 0 in + let dyn v = let d = S.map (fun x -> v * x) high_x in - begin match !dcount with + begin match !dcount with | 0 -> assert_d1 := vals d [9; 12; 15; 18; 21; 24; 27] | 1 -> assert_d2 := vals d [36; 42; 48; 54] | 2 -> assert_d3 := vals d [81] - | _ -> assert false + | _ -> assert false end; incr dcount; d in - let change x = if x mod 3 = 0 then Some (dyn x) else None in - let s = esswitch x (E.fmap change (S.changes x)) in + let change x = if x mod 3 = 0 then Some (dyn x) else None in + let s = esswitch x (E.fmap change (S.changes x)) in let assert_s = vals s [0; 1; 2; 9; 12; 15; 36; 42; 48; 81 ] in Gc.full_major (); List.iter send_x [1; 1; 2; 2; 3; 3; 4; 4; 5; 5; 6; 6; 7; 7; 8; 8; 9; 9]; List.iter empty [assert_s; !assert_d1; !assert_d2; !assert_d3] -let test_switch3 () = (* dynamic creation does not depend on triggering +let test_switch3 () = (* dynamic creation does not depend on triggering prim. *) - let x, set_x = S.create 0 in + let x, set_x = S.create 0 in let y, set_y = S.create 0 in - let dcount = ref 0 in - let assert_d1 = assert_s_stub 0 in + let dcount = ref 0 in + let assert_d1 = assert_s_stub 0 in let assert_d2 = assert_s_stub 0 in let assert_d3 = assert_s_stub 0 in - let dyn v = + let dyn v = let d = S.map (fun y -> v * y) y in - begin match !dcount with + begin match !dcount with | 0 -> assert_d1 := vals d [6; 3; 6; 3; 6] | 1 -> assert_d2 := vals d [12; 6; 12] | 2 -> assert_d3 := vals d [18] - | _ -> assert false + | _ -> assert false end; incr dcount; d in - let change x = if x mod 3 = 0 && x <> 0 then Some (dyn x) else None in + let change x = if x mod 3 = 0 && x <> 0 then Some (dyn x) else None in let s = S.switch (S.fmap change y x) in let assert_s = vals s [0; 1; 2; 6; 3; 6; 12; 6; 12; 18] in Gc.full_major (); @@ -907,28 +907,28 @@ let test_switch3 () = (* dynamic creation does not depend on triggering List.iter set_y [1; 1; 2; 2]; List.iter set_x [7; 7; 8; 8; 9; 9]; List.iter empty [assert_s; !assert_d1; !assert_d2; !assert_d3] -let test_esswitch3 () = (* dynamic creation does not depend on triggering +let test_esswitch3 () = (* dynamic creation does not depend on triggering prim. *) - let ex, send_x = E.create () in + let ex, send_x = E.create () in let ey, send_y = E.create () in let x = S.hold 0 ex in let y = S.hold 0 ey in - let dcount = ref 0 in - let assert_d1 = assert_s_stub 0 in + let dcount = ref 0 in + let assert_d1 = assert_s_stub 0 in let assert_d2 = assert_s_stub 0 in let assert_d3 = assert_s_stub 0 in - let dyn v = + let dyn v = let d = S.map (fun y -> v * y) y in - begin match !dcount with + begin match !dcount with | 0 -> assert_d1 := vals d [6; 3; 6; 3; 6] | 1 -> assert_d2 := vals d [12; 6; 12] | 2 -> assert_d3 := vals d [18] - | _ -> assert false + | _ -> assert false end; incr dcount; d in - let change x = if x mod 3 = 0 then Some (dyn x) else None in + let change x = if x mod 3 = 0 then Some (dyn x) else None in let s = esswitch y (E.fmap change (S.changes x)) in let assert_s = vals s [0; 1; 2; 6; 3; 6; 12; 6; 12; 18] in Gc.full_major (); @@ -938,24 +938,24 @@ let test_esswitch3 () = (* dynamic creation does not depend on triggering List.iter empty [assert_s; !assert_d1; !assert_d2; !assert_d3] let test_switch4 () = (* test_switch3 + high rank. *) - let x, set_x = S.create 0 in + let x, set_x = S.create 0 in let y, set_y = S.create 0 in - let dcount = ref 0 in - let assert_d1 = assert_s_stub 0 in + let dcount = ref 0 in + let assert_d1 = assert_s_stub 0 in let assert_d2 = assert_s_stub 0 in let assert_d3 = assert_s_stub 0 in - let dyn v = + let dyn v = let d = S.map (fun y -> v * y) (high_s y) in - begin match !dcount with + begin match !dcount with | 0 -> assert_d1 := vals d [6; 3; 6; 3; 6] | 1 -> assert_d2 := vals d [12; 6; 12] | 2 -> assert_d3 := vals d [18] - | _ -> assert false + | _ -> assert false end; incr dcount; d in - let change x = if x mod 3 = 0 && x <> 0 then Some (dyn x) else None in + let change x = if x mod 3 = 0 && x <> 0 then Some (dyn x) else None in let s = S.switch (S.fmap change y x) in let assert_s = vals s [0; 1; 2; 6; 3; 6; 12; 6; 12; 18] in Gc.full_major (); @@ -965,26 +965,26 @@ let test_switch4 () = (* test_switch3 + high rank. *) List.iter empty [assert_s; !assert_d1; !assert_d2; !assert_d3] let test_esswitch4 () = (* test_esswitch3 + high rank. *) - let ex, set_x = E.create () in + let ex, set_x = E.create () in let ey, set_y = E.create () in let x = S.hold 0 ex in let y = S.hold 0 ey in - let dcount = ref 0 in + let dcount = ref 0 in let assert_d1 = assert_s_stub 0 in - let assert_d2 = assert_s_stub 0 in - let assert_d3 = assert_s_stub 0 in - let dyn v = + let assert_d2 = assert_s_stub 0 in + let assert_d3 = assert_s_stub 0 in + let dyn v = let d = S.map (fun y -> v * y) (high_s y) in - begin match !dcount with + begin match !dcount with | 0 -> assert_d1 := vals d [6; 3; 6; 3; 6] | 1 -> assert_d2 := vals d [12; 6; 12] | 2 -> assert_d3 := vals d [18] - | _ -> assert false + | _ -> assert false end; incr dcount; d in - let change x = if x mod 3 = 0 then Some (dyn x) else None in + let change x = if x mod 3 = 0 then Some (dyn x) else None in let s = esswitch y (E.fmap change (S.changes x)) in let assert_s = vals s [0; 1; 2; 6; 3; 6; 12; 6; 12; 18] in Gc.full_major (); @@ -993,12 +993,12 @@ let test_esswitch4 () = (* test_esswitch3 + high rank. *) List.iter set_y [1; 1; 2; 2]; List.iter set_x [7; 7; 8; 8; 9; 9]; List.iter empty [assert_s; !assert_d1; !assert_d2; !assert_d3] -let test_bind () = +let test_bind () = let e, set_e = E.create () in - let a = S.hold 0 e in - let b = S.hold 1 e in + let a = S.hold 0 e in + let b = S.hold 1 e in let s, set_s = S.create true in - let next = function + let next = function | true -> b | false -> a in @@ -1008,70 +1008,108 @@ let test_bind () = set_e 3; set_s true; List.iter empty [assert_bind] - + +let test_dyn_bind () = (* i.e. dyn switch *) + let s1, set_s1 = S.create true in + let s2, set_s2 = S.create 1 in + let bind1 = function + | true -> + let bind2 = function + | true -> s2 + | false -> S.const 2 + in + S.bind s1 bind2 + | false -> S.const 2 + in + let s = S.bind s1 bind1 in + let assert_bind = vals s [1; 2; 1 ] in + set_s1 true; + set_s1 false; + set_s1 true; + List.iter empty [assert_bind] + +let test_dyn_bind2 () = (* i.e. dyn switch *) + let s1, set_s1 = S.create true in + let s2, set_s2 = S.create true in + let bind1 = function + | true -> + let bind2 = function + | true -> (S.map (fun _ -> 3) s1) + | false -> S.const 2 + in + S.bind s2 bind2 + | false -> S.const 2 + in + let s = S.bind s1 bind1 in + let assert_bind = vals s [3; 2; 3 ] in + set_s1 true; + set_s1 false; + set_s1 true; + List.iter empty [assert_bind] + let test_fix () = let s, set_s = S.create 0 in - let history s = - let push v = function - | v' :: _ as l -> if v = v' then l else v :: l + let history s = + let push v = function + | v' :: _ as l -> if v = v' then l else v :: l | [] -> [ v ] in - let define h = - let h' = S.l2 push s h in + let define h = + let h' = S.l2 push s h in h', (h', S.map (fun x -> x) h) in - S.fix [] define + S.fix [] define in - let h, hm = history s in + let h, hm = history s in let assert_h = vals h [[0]; [1; 0;]; [2; 1; 0;]; [3; 2; 1; 0;]] in let assert_hm = vals hm [[0]; [1; 0;]; [2; 1; 0]; [3; 2; 1; 0;]] in - let assert_dh = assert_s_stub [] in - let assert_dhm = assert_s_stub [] in - let assert_dhh = assert_s_stub [] in - let assert_dhhm = assert_s_stub [] in + let assert_dh = assert_s_stub [] in + let assert_dhm = assert_s_stub [] in + let assert_dhh = assert_s_stub [] in + let assert_dhhm = assert_s_stub [] in let dyn () = - let dh, dhm = history s in + let dh, dhm = history s in let dhh, dhhm = history (high_s s) in assert_dh := vals dh [[1]; [2; 1]; [3; 2; 1]]; - assert_dhm := vals dhm [[]; [1]; [2; 1]; [3; 2; 1]]; + assert_dhm := vals dhm [[]; [1]; [2; 1]; [3; 2; 1]]; assert_dhh := vals dhh [[1]; [2; 1]; [3; 2; 1]]; assert_dhhm := vals dhhm [[]; [1]; [2; 1]; [3; 2; 1]]; in let create_dyn = S.map (fun v -> if v = 1 then dyn ()) s in Gc.full_major (); List.iter set_s [0; 1; 1; 2; 3]; - List.iter empty [assert_h; assert_hm; !assert_dh; !assert_dhm; + List.iter empty [assert_h; assert_hm; !assert_dh; !assert_dhm; !assert_dhh; !assert_dhhm]; keep_sref create_dyn -let test_fix' () = +let test_fix' () = let s, set_s = S.create 0 in let f, set_f = S.create 3 in let hs = high_s s in - let assert_cs = assert_s_stub 0 in - let assert_chs = assert_s_stub 0 in - let assert_cdhs = assert_s_stub 0 in - let assert_ss = assert_s_stub 0 in - let assert_shs = assert_s_stub 0 in - let assert_sdhs = assert_s_stub 0 in - let assert_fs = assert_s_stub 0 in - let assert_fhs = assert_s_stub 0 in - let assert_fdhs = assert_s_stub 0 in - let dyn () = + let assert_cs = assert_s_stub 0 in + let assert_chs = assert_s_stub 0 in + let assert_cdhs = assert_s_stub 0 in + let assert_ss = assert_s_stub 0 in + let assert_shs = assert_s_stub 0 in + let assert_sdhs = assert_s_stub 0 in + let assert_fs = assert_s_stub 0 in + let assert_fhs = assert_s_stub 0 in + let assert_fdhs = assert_s_stub 0 in + let dyn () = let cs = S.fix 0 (fun h -> S.const 2, S.Int.( + ) h s) in - let chs = S.fix 0 (fun h -> S.const 2, S.Int.( + ) h hs) in + let chs = S.fix 0 (fun h -> S.const 2, S.Int.( + ) h hs) in let cdhs = S.fix 0 (fun h -> S.const 2, S.Int.( + ) h (high_s s)) in let ss = S.fix 0 (fun h -> s, S.Int.( + ) h s) in - let shs = S.fix 0 (fun h -> s, S.Int.( + ) h hs) in + let shs = S.fix 0 (fun h -> s, S.Int.( + ) h hs) in let sdhs = S.fix 0 (fun h -> s, S.Int.( + ) h (high_s s)) in let fs = S.fix 0 (fun h -> f, S.Int.( + ) h s) in - let fhs = S.fix 0 (fun h -> f, S.Int.( + ) h hs) in + let fhs = S.fix 0 (fun h -> f, S.Int.( + ) h hs) in let fdhs = S.fix 0 (fun h -> f, S.Int.( + ) h (high_s s)) in let cs_vals = [1; 3; 4; 5; ] in assert_cs := vals cs cs_vals; assert_chs := vals chs cs_vals; assert_cdhs := vals cdhs cs_vals; - let ss_vals = [1; 2; 3; 4; 5; 6] in + let ss_vals = [1; 2; 3; 4; 5; 6] in assert_ss := vals ss ss_vals; assert_shs := vals shs ss_vals; assert_sdhs := vals sdhs ss_vals; @@ -1089,21 +1127,21 @@ let test_fix' () = !assert_fs; !assert_fhs; !assert_fdhs]; keep_sref create_dyn -let test_lifters () = - let f1 a = 1 + a in - let f2 a0 a1 = a0 + a1 in - let f3 a0 a1 a2 = a0 + a1 + a2 in - let f4 a0 a1 a2 a3 = a0 + a1 + a2 + a3 in - let f5 a0 a1 a2 a3 a4 = a0 + a1 + a2 + a3 + a4 in - let f6 a0 a1 a2 a3 a4 a5 = a0 + a1 + a2 + a3 + a4 + a5 in - let x, set_x = S.create 0 in +let test_lifters () = + let f1 a = 1 + a in + let f2 a0 a1 = a0 + a1 in + let f3 a0 a1 a2 = a0 + a1 + a2 in + let f4 a0 a1 a2 a3 = a0 + a1 + a2 + a3 in + let f5 a0 a1 a2 a3 a4 = a0 + a1 + a2 + a3 + a4 in + let f6 a0 a1 a2 a3 a4 a5 = a0 + a1 + a2 + a3 + a4 + a5 in + let x, set_x = S.create 0 in let x1 = S.l1 f1 x in let x2 = S.l2 f2 x x1 in - let x3 = S.l3 f3 x x1 x2 in - let x4 = S.l4 f4 x x1 x2 x3 in - let x5 = S.l5 f5 x x1 x2 x3 x4 in - let x6 = S.l6 f6 x x1 x2 x3 x4 x5 in - let a_x1 = vals x1 [1; 2] in + let x3 = S.l3 f3 x x1 x2 in + let x4 = S.l4 f4 x x1 x2 x3 in + let x5 = S.l5 f5 x x1 x2 x3 x4 in + let x6 = S.l6 f6 x x1 x2 x3 x4 x5 in + let a_x1 = vals x1 [1; 2] in let a_x2 = vals x2 [1; 3] in let a_x3 = vals x3 [2; 6] in let a_x4 = vals x4 [4; 12] in @@ -1118,8 +1156,8 @@ let test_lifters () = let dyn () = let dx1 = S.l1 f1 x in let dx2 = S.l2 f2 x x1 in - let dx3 = S.l3 f3 x x1 x2 in - let dx4 = S.l4 f4 x x1 x2 x3 in + let dx3 = S.l3 f3 x x1 x2 in + let dx4 = S.l4 f4 x x1 x2 x3 in let dx5 = S.l5 f5 x x1 x2 x3 x4 in let dx6 = S.l6 f6 x x1 x2 x3 x4 x5 in a_dx1 := vals dx1 [2]; @@ -1129,36 +1167,36 @@ let test_lifters () = a_dx5 := vals dx5 [24]; a_dx6 := vals dx6 [48] in - let create_dyn = S.map (fun v -> if v = 1 then dyn ()) x in + let create_dyn = S.map (fun v -> if v = 1 then dyn ()) x in Gc.full_major (); List.iter set_x [0; 1]; - List.iter empty [ a_x1; a_x2; a_x3; a_x4; a_x5; a_x6; !a_dx1; !a_dx2; !a_dx3; + List.iter empty [ a_x1; a_x2; a_x3; a_x4; a_x5; a_x6; !a_dx1; !a_dx2; !a_dx3; !a_dx4; !a_dx5; !a_dx6 ]; keep_sref create_dyn -let test_option () = - let b0, set_b0 = S.create None in - let b1, set_b1 = S.create (Some 1) in +let test_option () = + let b0, set_b0 = S.create None in + let b1, set_b1 = S.create (Some 1) in let b2 = S.const None in - let b3 = S.const (Some 3) in + let b3 = S.const (Some 3) in let d, set_d = S.create 512 in let dsome = S.Option.some d in - let s00 = S.Option.value ~default:(`Init (S.const 255)) b0 in - let s01 = S.Option.value ~default:(`Init (S.const 255)) b1 in - let s02 = S.Option.value ~default:(`Init (S.const 255)) b2 in - let s03 = S.Option.value ~default:(`Init (S.const 255)) b3 in - let s10 = S.Option.value ~default:(`Always (S.const 255)) b0 in - let s11 = S.Option.value ~default:(`Always (S.const 255)) b1 in - let s12 = S.Option.value ~default:(`Always (S.const 255)) b2 in - let s13 = S.Option.value ~default:(`Always (S.const 255)) b3 in - let s20 = S.Option.value ~default:(`Init d) b0 in - let s21 = S.Option.value ~default:(`Init d) b1 in - let s22 = S.Option.value ~default:(`Init d) b2 in - let s23 = S.Option.value ~default:(`Init d) b3 in - let s30 = S.Option.value ~default:(`Always d) b0 in - let s31 = S.Option.value ~default:(`Always d) b1 in - let s32 = S.Option.value ~default:(`Always d) b2 in - let s33 = S.Option.value ~default:(`Always d) b3 in + let s00 = S.Option.value ~default:(`Init (S.const 255)) b0 in + let s01 = S.Option.value ~default:(`Init (S.const 255)) b1 in + let s02 = S.Option.value ~default:(`Init (S.const 255)) b2 in + let s03 = S.Option.value ~default:(`Init (S.const 255)) b3 in + let s10 = S.Option.value ~default:(`Always (S.const 255)) b0 in + let s11 = S.Option.value ~default:(`Always (S.const 255)) b1 in + let s12 = S.Option.value ~default:(`Always (S.const 255)) b2 in + let s13 = S.Option.value ~default:(`Always (S.const 255)) b3 in + let s20 = S.Option.value ~default:(`Init d) b0 in + let s21 = S.Option.value ~default:(`Init d) b1 in + let s22 = S.Option.value ~default:(`Init d) b2 in + let s23 = S.Option.value ~default:(`Init d) b3 in + let s30 = S.Option.value ~default:(`Always d) b0 in + let s31 = S.Option.value ~default:(`Always d) b1 in + let s32 = S.Option.value ~default:(`Always d) b2 in + let s33 = S.Option.value ~default:(`Always d) b3 in let a_dsome = vals dsome [ Some 512; Some 1024; Some 2048;] in let a_s00 = vals s00 [255;3] in let a_s01 = vals s01 [1;] in @@ -1178,14 +1216,31 @@ let test_option () = let a_s33 = vals s33 [3] in set_b0 (Some 3); set_b1 None; set_d 1024; set_b0 None; set_d 2048; empty a_dsome; - List.iter empty [ a_s00; a_s01; a_s02; a_s03; - a_s10; a_s11; a_s12; a_s13; - a_s20; a_s21; a_s22; a_s23; + List.iter empty [ a_s00; a_s01; a_s02; a_s03; + a_s10; a_s11; a_s12; a_s13; + a_s20; a_s21; a_s22; a_s23; a_s30; a_s31; a_s32; a_s33; ]; () +let test_bool () = + let s, set_s = S.create false in + let a_zedge = occs (S.Bool.(edge zero)) [] in + let a_zrise = occs (S.Bool.(rise zero)) [] in + let a_zfall = occs (S.Bool.(fall zero)) [] in + let a_sedge = occs (S.Bool.edge s) [true; false] in + let a_srise = occs (S.Bool.rise s) [()] in + let a_rfall = occs (S.Bool.fall s) [()] in + let a_flip_never = vals (S.Bool.flip false E.never) [false] in + let a_flip = vals (S.Bool.flip true (S.changes s)) [true; false; true] in + let dyn_flip = S.bind s (fun _ -> S.Bool.flip true (S.changes s)) in + let a_dyn_flip = vals dyn_flip [true; false] in + set_s false; set_s true; set_s true; set_s false; + List.iter empty [a_zedge; a_sedge; ]; + List.iter empty [a_zrise; a_zfall; a_srise; a_rfall ]; + List.iter empty [a_flip_never; a_flip; a_dyn_flip ]; + () -let test_signals () = +let test_signals () = test_no_leak (); test_hold (); test_app (); @@ -1207,34 +1262,37 @@ let test_signals () = test_switch2 (); test_esswitch2 (); test_switch3 (); - test_esswitch3 (); + test_esswitch3 (); test_switch4 (); test_esswitch4 (); test_bind (); + test_dyn_bind (); + test_dyn_bind2 (); test_fix (); test_fix' (); test_lifters (); test_option (); + test_bool (); () -(* Test steps *) +(* Test steps *) -let test_executed_raise () = - let e, send = E.create () in +let test_executed_raise () = + let e, send = E.create () in let s, set = S.create 4 in - let step = Step.create () in + let step = Step.create () in Step.execute step; (try send ~step 3; assert false with Invalid_argument _ -> ()); (try set ~step 3; assert false with Invalid_argument _ -> ()); (try Step.execute step; assert false with Invalid_argument _ -> ()); () -let test_already_scheduled_raise () = - let e, send = E.create () in +let test_already_scheduled_raise () = + let e, send = E.create () in let s, set = S.create 4 in - let step = Step.create () in + let step = Step.create () in let step2 = Step.create () in - send ~step 3; + send ~step 3; (try send ~step 3; assert false with Invalid_argument _ -> ()); (try send ~step:step2 4; assert false with Invalid_argument _ -> ()); set ~step 5; @@ -1242,49 +1300,49 @@ let test_already_scheduled_raise () = (try set ~step 6; assert false with Invalid_argument _ -> ()); (try set ~step:step2 7; assert false with Invalid_argument _ -> ()); () - -let test_simultaneous () = - let e1, send1 = E.create () in - let e2, send2 = E.create () in - let s1, set1 = S.create 99 in - let s2, set2 = S.create 98 in - let never = E.dismiss e1 e2 in + +let test_simultaneous () = + let e1, send1 = E.create () in + let e2, send2 = E.create () in + let s1, set1 = S.create 99 in + let s2, set2 = S.create 98 in + let never = E.dismiss e1 e2 in let assert_never = occs never [] in - let merge = E.merge (fun acc o -> o :: acc) [] [e1; e2] in - let assert_merge = occs merge [[2; 1]] in + let merge = E.merge (fun acc o -> o :: acc) [] [e1; e2] in + let assert_merge = occs merge [[2; 1]] in let s1_value = S.sample (fun _ sv -> sv) e1 s1 in let assert_s1_value = occs s1_value [ 3 ] in let dismiss = S.dismiss e1 1 s1 in let assert_dismiss = vals dismiss [ 99 ] in - let on = S.on (S.map (( = ) 3) s1) 0 s2 in + let on = S.on (S.map (( = ) 3) s1) 0 s2 in let assert_on_ = vals on [0; 4] in - let step = Step.create () in - send1 ~step 1; - send2 ~step 2; - set1 ~step 3; - set2 ~step 4; + let step = Step.create () in + send1 ~step 1; + send2 ~step 2; + set1 ~step 3; + set2 ~step 4; Step.execute step; - empty assert_never; + empty assert_never; empty assert_merge; empty assert_s1_value; empty assert_dismiss; empty assert_on_; () -let test_multistep () = - let e, send = E.create () in - let s, set = S.create 0 in - let assert_e = occs e [1; 2] in - let assert_s = vals s [0; 1; 2] in - let step = Step.create () in - send ~step 1; +let test_multistep () = + let e, send = E.create () in + let s, set = S.create 0 in + let assert_e = occs e [1; 2] in + let assert_s = vals s [0; 1; 2] in + let step = Step.create () in + send ~step 1; set ~step 1; - Step.execute step; - let step = Step.create () in - send ~step 2; + Step.execute step; + let step = Step.create () in + send ~step 2; set ~step 2; Step.execute step; - empty assert_e; + empty assert_e; empty assert_s; () @@ -1294,7 +1352,7 @@ let test_steps () = test_simultaneous (); test_multistep (); () - + (* bug fixes *) let test_jake_heap_bug () = @@ -1302,54 +1360,127 @@ let test_jake_heap_bug () = let id x = x in let a, set_a = S.create 0 in (* rank 0 *) let _ = S.map (fun x -> if x = 2 then Gc.full_major ()) a in - let _ = - let a1 = S.map id a in + let _ = + let a1 = S.map id a in (S.l2 (fun x y -> (x + y)) a1 a), (* rank 2 *) (S.l2 (fun x y -> (x + y)) a1 a), (* rank 2 *) (S.l2 (fun x y -> (x + y)) a1 a) (* rank 2 *) in - let _ = + let _ = (S.l2 (fun x y -> (x + y)) a a), (* rank 1 *) (S.l2 (fun x y -> (x + y)) a a) (* rank 1 *) in - let d = S.map id (S.map id (S.map (fun x -> x + 1) a)) in (* rank 3 *) + let d = S.map id (S.map id (S.map (fun x -> x + 1) a)) in (* rank 3 *) let h = S.l2 (fun x y -> x + y) a d in (* rank 4 *) - let a_h = vals h [ 1; 5 ] in + let a_h = vals h [ 1; 5 ] in set_a 2; empty a_h -let test_sswitch_init_rank_bug () = +let test_sswitch_init_rank_bug () = let enabled, set_enabled = S.create true in (* let enabled = S.const true *) - let pos, set_pos = S.create () in - let down, send_down = E.create () in - let up, send_up = E.create () in - let hover enabled = match enabled with - | true -> S.map (fun a -> true) pos + let pos, set_pos = S.create () in + let down, send_down = E.create () in + let up, send_up = E.create () in + let hover enabled = match enabled with + | true -> S.map (fun a -> true) pos | false -> S.Bool.zero in - let used hover enabled = match enabled with - | true -> - let start = E.stamp (E.on hover down) true in - let stop = E.stamp up false in + let used hover enabled = match enabled with + | true -> + let start = E.stamp (E.on hover down) true in + let stop = E.stamp up false in let accum = E.select [ start; stop ] in - let s = S.hold false accum in + let s = S.hold false accum in s | false -> S.Bool.zero in let hover = S.bind enabled hover in let used = S.switch (S.map ~eq:( == ) (used hover) enabled) in - let activates = S.changes used in - let activates' = (E.map (fun _ -> (fun _ -> ())) activates) in + let activates = S.changes used in + let activates' = (E.map (fun _ -> (fun _ -> ())) activates) in let actuate = (E.app activates' up) in let actuate_assert = occs actuate [()] in send_down (); send_up (); empty actuate_assert -let test_misc () = - test_jake_heap_bug (); - test_sswitch_init_rank_bug () - -let main () = +let test_changes_end_of_step_add_bug () = + let s, set_s = S.create false in + let s1, set_s1 = S.create false in + let high_s1 = high_s s1 in + let e = S.changes s1 in + let assert_o = assert_e_stub () in + let bind = function + | true -> + let changing_rank = S.bind s @@ function + | true -> high_s1 + | false -> s1 + in + let o = E.l2 (fun _ _ -> ()) (S.changes changing_rank) e in + assert_o := occs o [ () ]; + S.const o + | false -> S.const E.never + in + let r = S.bind s bind in + set_s true; + set_s1 true; + List.iter empty [!assert_o;]; + keep_sref r + +let test_diff_end_of_step_add_bug () = + let s, set_s = S.create false in + let s1, set_s1 = S.create false in + let high_s1 = high_s s1 in + let e = S.changes s1 in + let assert_o = assert_e_stub () in + let bind = function + | true -> + let changing_rank = S.bind s @@ function + | true -> high_s1 + | false -> s1 + in + let o = E.l2 (fun _ _ -> ()) (S.diff (fun _ _ -> ()) changing_rank) e in + assert_o := occs o [ () ]; + S.const o + | false -> S.const E.never + in + let r = S.bind s bind in + set_s true; + set_s1 true; + List.iter empty [!assert_o;]; + keep_sref r + +let test_bool_rise_end_of_step_add_bug () = + let s, set_s = S.create false in + let s1, set_s1 = S.create false in + let high_s1 = high_s s1 in + let e = S.changes s1 in + let assert_o = assert_e_stub () in + let bind = function + | true -> + let changing_rank = S.bind s @@ function + | true -> high_s1 + | false -> s1 + in + let o = E.l2 (fun _ _ -> ()) (S.Bool.rise changing_rank) e in + assert_o := occs o [ () ]; + S.const o + | false -> S.const E.never + in + let r = S.bind s bind in + set_s true; + set_s1 true; + List.iter empty [!assert_o;]; + keep_sref r + +let test_misc () = + test_jake_heap_bug (); + test_sswitch_init_rank_bug (); + test_changes_end_of_step_add_bug (); + test_diff_end_of_step_add_bug (); + test_bool_rise_end_of_step_add_bug (); + () + +let main () = test_events (); test_signals (); test_steps (); @@ -1365,7 +1496,7 @@ let () = main () Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. @@ -1390,6 +1521,3 @@ let () = main () (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ---------------------------------------------------------------------------*) - - - |