elerea-examples 2.2.3 → 2.9.0

raw patch · 17 files changed

+1239/−1493 lines, 17 filesdep ~elereasetup-changed

Dependency ranges changed: elerea

Files

LICENSE +28/−28
README +16/−16
Setup.hs +3/−3
doc/Breakout.html +49/−238
doc/Chase.html +23/−97
doc/Makefile +10/−10
doc/hscolour.css +11/−11
elerea-examples.cabal +66/−66
src/Bounce/Event.hs +46/−46
src/Bounce/Main.hs +219/−216
src/Bounce/Math.hs +60/−60
src/Bounce/Util.hs +73/−73
src/Bounce/Vector.hs +53/−53
src/Breakout.lhs +364/−361
src/Chase.lhs +124/−121
src/Common/Utils.lhs +44/−44
src/Common/Vector.lhs +50/−50

LICENSE view

@@ -1,28 +1,28 @@-Copyright (c) 2009, Patai Gergely-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 the author nor the names of its contributors may be-   used to endorse or promote products derived from this software without-   specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 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.+Copyright (c) 2009, Patai Gergely
+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 the author nor the names of its contributors may be
+   used to endorse or promote products derived from this software without
+   specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 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.

README view

@@ -1,16 +1,16 @@-Example applications for Elerea. They are factored out into their own-package so as to avoid unnecessary dependencies in the library. Check-out the doc directory for the colourful literate sources.--The programs included are the following:--* bounce: an example for creating dynamic collections of signals; left-  click to create balls, drag existing balls with left button to-  propel them and drag with right to select balls for deletion (upon-  release);--* chase: a minimal example that demonstrates reactivity and mutually-  recursive signals;--* breakout: a not too fancy breakout clone; you can simply use the-  mouse to move the paddle.+Example applications for Elerea. They are factored out into their own
+package so as to avoid unnecessary dependencies in the library. Check
+out the doc directory for the colourful literate sources.
+
+The programs included are the following:
+
+* bounce: an example for creating dynamic collections of signals; left
+  click to create balls, drag existing balls with left button to
+  propel them and drag with right to select balls for deletion (upon
+  release);
+
+* chase: a minimal example that demonstrates reactivity and mutually
+  recursive signals;
+
+* breakout: a not too fancy breakout clone; you can simply use the
+  mouse to move the paddle.

Setup.hs view

@@ -1,3 +1,3 @@-import Distribution.Simple--main = defaultMain+import Distribution.Simple
+
+main = defaultMain

doc/Breakout.html view

@@ -1,27 +1,15 @@ <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> <html xmlns="http://www.w3.org/1999/xhtml"> <head>-  <title></title>   <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />+  <meta http-equiv="Content-Style-Type" content="text/css" />   <meta name="generator" content="pandoc" />-  <meta name="date" content="" />+  <title></title>+  <style type="text/css">code{white-space: pre;}</style>   <link rel="stylesheet" href="hscolour.css" type="text/css" /> </head> <body>-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">-<html>-<head>-<!-- Generated by HsColour, http://www.cs.york.ac.uk/fp/darcs/hscolour/ --><title>Haskell code</title> <link type='text/css' rel='stylesheet' href='hscolour.css' /></head>-<body><div id="elerea-breakout-example"-><h1-  >Elerea Breakout example</h1-  ><p-  >Breakout is one of the simplest test applications that brings up some problems with non-trivial solutions. In particular, there is a circular dependency between the position and the velocity of the ball. The position is the integral of the velocity, while velocity can have instantaneous changes due to collisions, which is a function of the position of the ball and the current state of the field. The field is dynamic, and it also forms a mutual dependency loop with the ball position. On top of these, part of the field (at least if we regard the paddle as part of it) depends on user input, and its effects start propagating in the game state as soon as the ball reaches the level of the paddle.</p-  ><p-  >Elerea lets us express all these circular dependencies in a natural way, by simply referring to the respective signals by their names. User input is also seen as a signal from inside the reactive part, while the imperative framework is given a sink fuction to update it as needed. Type safety is ensured all the way.</p-  ><img src="Breakout.png" alt="Elerea Breakout in action" /><p-  >Below follows the full source of the example.</p-  ><pre><span class='hs-varop'>&gt;</span> <span class='hs-comment'>{-# LANGUAGE DoRec #-}</span>+<?xml version="1.0" encoding="UTF-8"?><!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"><html><head><!-- Generated by HsColour, http://code.haskell.org/~malcolm/hscolour/ --><title>Haskell code</title><link type='text/css' rel='stylesheet' href='hscolour.css' /></head><body><h1 id="elerea-breakout-example">Elerea Breakout example</h1><p>Breakout is one of the simplest test applications that brings up some problems with non-trivial solutions. In particular, there is a circular dependency between the position and the velocity of the ball. The position is the integral of the velocity, while velocity can have instantaneous changes due to collisions, which is a function of the position of the ball and the current state of the field. The field is dynamic, and it also forms a mutual dependency loop with the ball position. On top of these, part of the field (at least if we regard the paddle as part of it) depends on user input, and its effects start propagating in the game state as soon as the ball reaches the level of the paddle.</p><p>Elerea lets us express all these circular dependencies in a natural way, by simply referring to the respective signals by their names. User input is also seen as a signal from inside the reactive part, while the imperative framework is given a sink fuction to update it as needed. Type safety is ensured all the way.</p><p><img src="Breakout.png" alt="Elerea Breakout in action" /></p><p>Below follows the full source of the example.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-comment'>{-# LANGUAGE DoRec #-}</span> <span class='hs-varop'>&gt;</span> <span class='hs-varop'>&gt;</span> <span class='hs-keyword'>module</span> <span class='hs-conid'>Main</span> <span class='hs-keyword'>where</span> <span class='hs-varop'>&gt;</span>@@ -37,69 +25,35 @@ <span class='hs-varop'>&gt;</span> <span class='hs-keyword'>import</span> <span class='hs-conid'>Graphics</span><span class='hs-varop'>.</span><span class='hs-conid'>Rendering</span><span class='hs-varop'>.</span><span class='hs-conid'>OpenGL</span> <span class='hs-varop'>&gt;</span> <span class='hs-keyword'>import</span> <span class='hs-conid'>System</span><span class='hs-varop'>.</span><span class='hs-conid'>Environment</span> <span class='hs-varop'>&gt;</span> <span class='hs-keyword'>import</span> <span class='hs-conid'>System</span><span class='hs-varop'>.</span><span class='hs-conid'>IO</span><span class='hs-varop'>.</span><span class='hs-conid'>Unsafe</span>-</pre>-<pre><span class='hs-varop'>&gt;</span> <span class='hs-keyword'>import</span> <span class='hs-conid'>Common</span><span class='hs-varop'>.</span><span class='hs-conid'>Utils</span>+</pre><pre><span class='hs-varop'>&gt;</span> <span class='hs-keyword'>import</span> <span class='hs-conid'>Common</span><span class='hs-varop'>.</span><span class='hs-conid'>Utils</span> <span class='hs-varop'>&gt;</span> <span class='hs-keyword'>import</span> <span class='hs-conid'>Common</span><span class='hs-varop'>.</span><span class='hs-conid'>Vector</span>-</pre><div id="global-constants"-  ><h2-    >Global constants</h2-    ><p-    >The dimensions of the ball, which behaves as a rectangle in collision detection, but is drawn as an ellipse.</p-    ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>ballW</span> <span class='hs-keyglyph'>=</span> <span class='hs-num'>0.04</span>-<span class='hs-varop'>&gt;</span> <span class='hs-varid'>ballH</span> <span class='hs-keyglyph'>=</span> <span class='hs-num'>0.04</span>-</pre><p-    >The initial position and velocity of the ball.</p-    ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>ballPos0</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>V</span> <span class='hs-num'>0</span> <span class='hs-layout'>(</span><span class='hs-comment'>-</span><span class='hs-num'>0.4</span><span class='hs-layout'>)</span>-<span class='hs-varop'>&gt;</span> <span class='hs-varid'>ballVel0</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>V</span> <span class='hs-layout'>(</span><span class='hs-comment'>-</span><span class='hs-num'>0.4</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-num'>0.35</span><span class='hs-layout'>)</span>-</pre><p-    >The dimensions and vertical position of the player.</p-    ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>playerW</span> <span class='hs-keyglyph'>=</span> <span class='hs-num'>0.2</span>-<span class='hs-varop'>&gt;</span> <span class='hs-varid'>playerH</span> <span class='hs-keyglyph'>=</span> <span class='hs-num'>0.03</span>-<span class='hs-varop'>&gt;</span> <span class='hs-varid'>playerY</span> <span class='hs-keyglyph'>=</span> <span class='hs-comment'>-</span><span class='hs-varid'>fieldH</span><span class='hs-varop'>+</span><span class='hs-num'>0.01</span>-</pre><p-    >The dimensions of the field.</p-    ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>fieldW</span> <span class='hs-keyglyph'>=</span> <span class='hs-num'>0.8</span>-<span class='hs-varop'>&gt;</span> <span class='hs-varid'>fieldH</span> <span class='hs-keyglyph'>=</span> <span class='hs-num'>0.5</span>-</pre><p-    >The dimensions of each brick.</p-    ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>brickW</span> <span class='hs-keyglyph'>=</span> <span class='hs-num'>0.05</span>-<span class='hs-varop'>&gt;</span> <span class='hs-varid'>brickH</span> <span class='hs-keyglyph'>=</span> <span class='hs-num'>0.03</span>-</pre><p-    >The data structure describing the state of each brick. A brick can either be alive or dying. Dying bricks also keep track of their fadeout level.</p-    ><pre><span class='hs-varop'>&gt;</span> <span class='hs-keyword'>data</span> <span class='hs-conid'>BrickState</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Live</span> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>Dying</span> <span class='hs-varop'>!</span><span class='hs-conid'>GLfloat</span> <span class='hs-keyword'>deriving</span> <span class='hs-layout'>(</span><span class='hs-conid'>Eq</span><span class='hs-layout'>,</span><span class='hs-conid'>Show</span><span class='hs-layout'>)</span>-</pre><p-    >The starting positions of the bricks.</p-    ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>brickPos0</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>distributeBricks</span> <span class='hs-layout'>(</span><span class='hs-comment'>-</span><span class='hs-num'>0.7</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-comment'>-</span><span class='hs-num'>0.1</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-num'>0.7</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-num'>0.4</span><span class='hs-layout'>)</span> <span class='hs-num'>18</span> <span class='hs-num'>10</span>+</pre><h2 id="global-constants">Global constants</h2><p>The dimensions of the ball, which behaves as a rectangle in collision detection, but is drawn as an ellipse.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>ballW</span> <span class='hs-keyglyph'>=</span> <span class='hs-num'>0.04</span>+<span class='hs-varop'>&gt;</span> <span class='hs-definition'>ballH</span> <span class='hs-keyglyph'>=</span> <span class='hs-num'>0.04</span>+</pre><p>The initial position and velocity of the ball.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>ballPos0</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>V</span> <span class='hs-num'>0</span> <span class='hs-layout'>(</span><span class='hs-comment'>-</span><span class='hs-num'>0.4</span><span class='hs-layout'>)</span>+<span class='hs-varop'>&gt;</span> <span class='hs-definition'>ballVel0</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>V</span> <span class='hs-layout'>(</span><span class='hs-comment'>-</span><span class='hs-num'>0.4</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-num'>0.35</span><span class='hs-layout'>)</span>+</pre><p>The dimensions and vertical position of the player.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>playerW</span> <span class='hs-keyglyph'>=</span> <span class='hs-num'>0.2</span>+<span class='hs-varop'>&gt;</span> <span class='hs-definition'>playerH</span> <span class='hs-keyglyph'>=</span> <span class='hs-num'>0.03</span>+<span class='hs-varop'>&gt;</span> <span class='hs-definition'>playerY</span> <span class='hs-keyglyph'>=</span> <span class='hs-comment'>-</span><span class='hs-varid'>fieldH</span><span class='hs-varop'>+</span><span class='hs-num'>0.01</span>+</pre><p>The dimensions of the field.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>fieldW</span> <span class='hs-keyglyph'>=</span> <span class='hs-num'>0.8</span>+<span class='hs-varop'>&gt;</span> <span class='hs-definition'>fieldH</span> <span class='hs-keyglyph'>=</span> <span class='hs-num'>0.5</span>+</pre><p>The dimensions of each brick.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>brickW</span> <span class='hs-keyglyph'>=</span> <span class='hs-num'>0.05</span>+<span class='hs-varop'>&gt;</span> <span class='hs-definition'>brickH</span> <span class='hs-keyglyph'>=</span> <span class='hs-num'>0.03</span>+</pre><p>The data structure describing the state of each brick. A brick can either be alive or dying. Dying bricks also keep track of their fadeout level.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-keyword'>data</span> <span class='hs-conid'>BrickState</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Live</span> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>Dying</span> <span class='hs-varop'>!</span><span class='hs-conid'>GLfloat</span> <span class='hs-keyword'>deriving</span> <span class='hs-layout'>(</span><span class='hs-conid'>Eq</span><span class='hs-layout'>,</span><span class='hs-conid'>Show</span><span class='hs-layout'>)</span>+</pre><p>The starting positions of the bricks.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>brickPos0</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>distributeBricks</span> <span class='hs-layout'>(</span><span class='hs-comment'>-</span><span class='hs-num'>0.7</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-comment'>-</span><span class='hs-num'>0.1</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-num'>0.7</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-num'>0.4</span><span class='hs-layout'>)</span> <span class='hs-num'>18</span> <span class='hs-num'>10</span> <span class='hs-varop'>&gt;</span>     <span class='hs-keyword'>where</span> <span class='hs-varid'>distributeBricks</span> <span class='hs-varid'>xmin</span> <span class='hs-varid'>ymin</span> <span class='hs-varid'>xmax</span> <span class='hs-varid'>ymax</span> <span class='hs-varid'>xn</span> <span class='hs-varid'>yn</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>xmin</span><span class='hs-varop'>+</span><span class='hs-varid'>xstep</span><span class='hs-varop'>*</span><span class='hs-varid'>x</span><span class='hs-layout'>,</span><span class='hs-varid'>ymin</span><span class='hs-varop'>+</span><span class='hs-varid'>ystep</span><span class='hs-varop'>*</span><span class='hs-varid'>y</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>|</span> <span class='hs-varop'>&gt;</span>                                                         <span class='hs-varid'>x</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-keyglyph'>[</span><span class='hs-num'>0</span><span class='hs-keyglyph'>..</span><span class='hs-varid'>xn</span><span class='hs-comment'>-</span><span class='hs-num'>1</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-varid'>y</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-keyglyph'>[</span><span class='hs-num'>0</span><span class='hs-keyglyph'>..</span><span class='hs-varid'>yn</span><span class='hs-comment'>-</span><span class='hs-num'>1</span><span class='hs-keyglyph'>]</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'>&gt;</span>               <span class='hs-keyword'>where</span> <span class='hs-varid'>xstep</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>xmax</span><span class='hs-comment'>-</span><span class='hs-varid'>xmin</span><span class='hs-comment'>-</span><span class='hs-varid'>xn</span><span class='hs-varop'>*</span><span class='hs-varid'>brickW</span><span class='hs-layout'>)</span><span class='hs-varop'>/</span><span class='hs-layout'>(</span><span class='hs-varid'>xn</span><span class='hs-comment'>-</span><span class='hs-num'>1</span><span class='hs-layout'>)</span><span class='hs-varop'>+</span><span class='hs-varid'>brickW</span> <span class='hs-varop'>&gt;</span>                     <span class='hs-varid'>ystep</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>ymax</span><span class='hs-comment'>-</span><span class='hs-varid'>ymin</span><span class='hs-comment'>-</span><span class='hs-varid'>yn</span><span class='hs-varop'>*</span><span class='hs-varid'>brickH</span><span class='hs-layout'>)</span><span class='hs-varop'>/</span><span class='hs-layout'>(</span><span class='hs-varid'>yn</span><span class='hs-comment'>-</span><span class='hs-num'>1</span><span class='hs-layout'>)</span><span class='hs-varop'>+</span><span class='hs-varid'>brickH</span>-</pre><p-    >The rate at which a brick fades out. The reciprocal of this value gives the fadeout time in seconds.</p-    ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>brickFade</span> <span class='hs-keyglyph'>=</span> <span class='hs-num'>0.5</span>-</pre></div-  ><div id="game-logic"-  ><h2-    >Game logic</h2-    ><p-    >The entry point performs some lightweight initialisation, and defines the two user-driven signals: window size and mouse position. The <code-      >external</code-      > function creates the signal and the corresponding sink at the same time.</p-    ><p-    >When all is done <code-      >driveNetwork</code-      > is invoked. It is not a library function, but part of the tiny <code-      >Utils</code-      > module .</p-    ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>main</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>+</pre><p>The rate at which a brick fades out. The reciprocal of this value gives the fadeout time in seconds.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>brickFade</span> <span class='hs-keyglyph'>=</span> <span class='hs-num'>0.5</span>+</pre><h2 id="game-logic">Game logic</h2><p>The entry point performs some lightweight initialisation, and defines the two user-driven signals: window size and mouse position. The <code>external</code> function creates the signal and the corresponding sink at the same time.</p><p>When all is done <code>driveNetwork</code> is invoked. It is not a library function, but part of the tiny <code>Utils</code> module .</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>main</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-varop'>&gt;</span>   <span class='hs-comment'>-- Creating a window without a depth buffer</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>initialize</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>openWindow</span> <span class='hs-layout'>(</span><span class='hs-conid'>Size</span> <span class='hs-num'>640</span> <span class='hs-num'>480</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>DisplayRGBBits</span> <span class='hs-num'>8</span> <span class='hs-num'>8</span> <span class='hs-num'>8</span><span class='hs-layout'>,</span> <span class='hs-conid'>DisplayAlphaBits</span> <span class='hs-num'>8</span><span class='hs-keyglyph'>]</span> <span class='hs-conid'>Window</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>windowTitle</span> <span class='hs-varop'>$=</span> <span class='hs-str'>"Elerea Breakout"</span> <span class='hs-varop'>&gt;</span> <span class='hs-varop'>&gt;</span>   <span class='hs-comment'>-- External signals available for the game logic</span>-<span class='hs-varop'>&gt;</span>   <span class='hs-layout'>(</span><span class='hs-varid'>windowSize</span><span class='hs-layout'>,</span><span class='hs-varid'>windowSizeSink</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>external</span> <span class='hs-varid'>vnull</span>-<span class='hs-varop'>&gt;</span>   <span class='hs-layout'>(</span><span class='hs-varid'>mousePosition</span><span class='hs-layout'>,</span><span class='hs-varid'>mousePositionSink</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>external</span> <span class='hs-varid'>vnull</span>+<span class='hs-varop'>&gt;</span>   <span class='hs-layout'>(</span><span class='hs-varid'>windowSizeGen</span><span class='hs-layout'>,</span><span class='hs-varid'>windowSizeSink</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>external</span> <span class='hs-varid'>vnull</span>+<span class='hs-varop'>&gt;</span>   <span class='hs-layout'>(</span><span class='hs-varid'>mousePositionGen</span><span class='hs-layout'>,</span><span class='hs-varid'>mousePositionSink</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>external</span> <span class='hs-varid'>vnull</span> <span class='hs-varop'>&gt;</span> <span class='hs-varop'>&gt;</span>   <span class='hs-comment'>-- Wrapping up the init phase</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>closed</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>newIORef</span> <span class='hs-conid'>False</span>@@ -109,51 +63,20 @@ <span class='hs-varop'>&gt;</span> <span class='hs-varop'>&gt;</span>   <span class='hs-comment'>-- All we need to get going is an IO-valued signal and an IO</span> <span class='hs-varop'>&gt;</span>   <span class='hs-comment'>-- function to update the external signals</span>-<span class='hs-varop'>&gt;</span>   <span class='hs-varid'>game</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>start</span> <span class='hs-layout'>(</span><span class='hs-varid'>breakout</span> <span class='hs-varid'>mousePosition</span> <span class='hs-varid'>windowSize</span><span class='hs-layout'>)</span>+<span class='hs-varop'>&gt;</span>   <span class='hs-varid'>game</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>start</span> <span class='hs-varop'>$</span> <span class='hs-keyword'>do</span>+<span class='hs-varop'>&gt;</span>     <span class='hs-varid'>mousePosition</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>mousePositionGen</span>+<span class='hs-varop'>&gt;</span>     <span class='hs-varid'>windowSize</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>windowSizeGen</span>+<span class='hs-varop'>&gt;</span>     <span class='hs-varid'>breakout</span> <span class='hs-varid'>mousePosition</span> <span class='hs-varid'>windowSize</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>driveNetwork</span> <span class='hs-varid'>game</span> <span class='hs-layout'>(</span><span class='hs-varid'>readInput</span> <span class='hs-varid'>mousePositionSink</span> <span class='hs-varid'>closed</span><span class='hs-layout'>)</span> <span class='hs-varop'>&gt;</span> <span class='hs-varop'>&gt;</span>   <span class='hs-comment'>-- The inevitable sad ending</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>closeWindow</span>-</pre><p-    >The <code-      >breakout</code-      > function creates a reactive signal that carries the rendering actions to be performed at each instant. The principal signals forming the game logic are the following:</p-    ><ul-    ><li-      ><code-	>playerX</code-	>: the position of the player, a direct function of the mouse position;</li-      ><li-      ><code-	>ballPos</code-	>: the position of the ball given as an integral of its velocity, <code-	>ballVel</code-	>;</li-      ><li-      ><code-	>bricks</code-	>: the collection of live and dying bricks along with collision information.</li-      ></ul-    ><p-    >The position and velocity of the ball form a circular dependency through the bricks, as velocity is changed whenever a collision is detected, which is a function of the position.</p-    ><p-    >The signal carrying the collection of the bricks is a higher-order signal, where each element of the list is a signal representing an individual brick. Bricks behave independently of each other: they are defined as separate transfer functions with the ball position as input signal. As soon as a brick is touched it enters the dying phase and fades out. Also, since other signals are mostly interested in the current state of the bricks, we have to define a flattened version, which carries the snapshots of all the brick signals. This is the <code-      >brickSamples</code-      > signal.</p-    ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>breakout</span> <span class='hs-varid'>mousePos</span> <span class='hs-varid'>windowSize</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>-</pre><p-    >User-driven player position:</p-    ><pre><span class='hs-varop'>&gt;</span>   <span class='hs-varid'>rec</span> <span class='hs-keyword'>let</span> <span class='hs-varid'>playerX</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>adjustPlayerPos</span> <span class='hs-varop'>&lt;$&gt;</span> <span class='hs-varid'>mousePos</span> <span class='hs-varop'>&lt;*&gt;</span> <span class='hs-varid'>windowSize</span>+</pre><p>The <code>breakout</code> function creates a reactive signal that carries the rendering actions to be performed at each instant. The principal signals forming the game logic are the following:</p><ul><li><code>playerX</code>: the position of the player, a direct function of the mouse position;</li><li><code>ballPos</code>: the position of the ball given as an integral of its velocity, <code>ballVel</code>;</li><li><code>bricks</code>: the collection of live and dying bricks along with collision information.</li></ul><p>The position and velocity of the ball form a circular dependency through the bricks, as velocity is changed whenever a collision is detected, which is a function of the position.</p><p>The signal carrying the collection of the bricks is a higher-order signal, where each element of the list is a signal representing an individual brick. Bricks behave independently of each other: they are defined as separate transfer functions with the ball position as input signal. As soon as a brick is touched it enters the dying phase and fades out. Also, since other signals are mostly interested in the current state of the bricks, we have to define a flattened version, which carries the snapshots of all the brick signals. This is the <code>brickSamples</code> signal.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>breakout</span> <span class='hs-varid'>mousePos</span> <span class='hs-varid'>windowSize</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>+</pre><p>User-driven player position:</p><pre><span class='hs-varop'>&gt;</span>   <span class='hs-varid'>rec</span> <span class='hs-keyword'>let</span> <span class='hs-varid'>playerX</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>adjustPlayerPos</span> <span class='hs-varop'>&lt;$&gt;</span> <span class='hs-varid'>mousePos</span> <span class='hs-varop'>&lt;*&gt;</span> <span class='hs-varid'>windowSize</span> <span class='hs-varop'>&gt;</span>           <span class='hs-varid'>adjustPlayerPos</span> <span class='hs-layout'>(</span><span class='hs-conid'>V</span> <span class='hs-varid'>x</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>V</span> <span class='hs-varid'>w</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>min</span> <span class='hs-layout'>(</span><span class='hs-varid'>fieldW</span><span class='hs-comment'>-</span><span class='hs-varid'>playerW</span><span class='hs-layout'>)</span> <span class='hs-varop'>$</span> <span class='hs-varid'>max</span> <span class='hs-layout'>(</span><span class='hs-comment'>-</span><span class='hs-varid'>fieldW</span><span class='hs-layout'>)</span> <span class='hs-varop'>$</span> <span class='hs-num'>2</span><span class='hs-varop'>*</span><span class='hs-varid'>x</span><span class='hs-varop'>/</span><span class='hs-varid'>w</span><span class='hs-comment'>-</span><span class='hs-num'>1</span><span class='hs-comment'>-</span><span class='hs-varid'>playerW</span><span class='hs-varop'>/</span><span class='hs-num'>2</span> <span class='hs-varop'>&gt;</span>           <span class='hs-layout'>(</span><span class='hs-varop'>||@</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>liftA2</span> <span class='hs-layout'>(</span><span class='hs-varop'>||</span><span class='hs-layout'>)</span> <span class='hs-varop'>&gt;</span>           <span class='hs-varid'>toMaybe</span> <span class='hs-varid'>c</span> <span class='hs-varid'>v</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>if</span> <span class='hs-varid'>c</span> <span class='hs-keyword'>then</span> <span class='hs-conid'>Just</span> <span class='hs-varid'>v</span> <span class='hs-keyword'>else</span> <span class='hs-conid'>Nothing</span>-</pre><p-    >Ball state: position and velocity. We use a combination of <code-      >storeJust</code-      > and <code-      >toMaybe</code-      > to produce a latcher element that stores the value of a certain signal whenever a boolean control signal yields true. We need to create delayed versions in order to have well-defined feedback loops.</p-    ><pre><span class='hs-varop'>&gt;</span>       <span class='hs-varid'>ballPos</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>integralVec</span> <span class='hs-varid'>ballPos0</span> <span class='hs-varid'>ballVel</span>+</pre><p>Ball state: position and velocity. We use a combination of <code>storeJust</code> and <code>toMaybe</code> to produce a latcher element that stores the value of a certain signal whenever a boolean control signal yields true. We need to create delayed versions in order to have well-defined feedback loops.</p><pre><span class='hs-varop'>&gt;</span>       <span class='hs-varid'>ballPos</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>integralVec</span> <span class='hs-varid'>ballPos0</span> <span class='hs-varid'>ballVel</span> <span class='hs-varop'>&gt;</span>       <span class='hs-varid'>ballVel</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>storeJust</span> <span class='hs-varid'>ballVel0</span> <span class='hs-varop'>$</span> <span class='hs-varop'>&gt;</span>                  <span class='hs-varid'>toMaybe</span> <span class='hs-varop'>&lt;$&gt;</span> <span class='hs-layout'>(</span><span class='hs-varid'>ballCollHorz</span> <span class='hs-varop'>||@</span> <span class='hs-varid'>ballCollVert</span> <span class='hs-varop'>||@</span> <span class='hs-varid'>ballCollPlayer</span><span class='hs-layout'>)</span> <span class='hs-varop'>&lt;*&gt;</span> <span class='hs-varop'>&gt;</span>                              <span class='hs-layout'>(</span><span class='hs-varid'>adjustVel</span> <span class='hs-varop'>&lt;$&gt;</span> <span class='hs-varid'>ballCollHorz</span> <span class='hs-varop'>&lt;*&gt;</span> <span class='hs-varid'>ballCollVert</span> <span class='hs-varop'>&lt;*&gt;</span> <span class='hs-varid'>ballCollPlayer</span> <span class='hs-varop'>&lt;*&gt;</span>@@ -161,19 +84,11 @@ <span class='hs-varop'>&gt;</span> <span class='hs-varop'>&gt;</span>       <span class='hs-varid'>ballPos'</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>delay</span> <span class='hs-varid'>ballPos0</span> <span class='hs-varid'>ballPos</span> <span class='hs-varop'>&gt;</span>       <span class='hs-varid'>ballVel'</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>delay</span> <span class='hs-varid'>ballVel0</span> <span class='hs-varid'>ballVel</span>-</pre><p-    >The <code-      >adjustVel</code-      > function calculates a candidate velocity for the next frame given collision information and the current velocity. Even though it would return the current speed if there are no collisions, we don’t evaluate it at all thanks to the laziness of applicative nodes. In the end, velocity is only recalculated when a collision is detected.</p-    ><pre><span class='hs-varop'>&gt;</span>       <span class='hs-keyword'>let</span> <span class='hs-varid'>adjustVel</span> <span class='hs-varid'>ch</span> <span class='hs-varid'>cv</span> <span class='hs-varid'>cp</span> <span class='hs-layout'>(</span><span class='hs-conid'>V</span> <span class='hs-varid'>bvx</span> <span class='hs-varid'>bvy</span><span class='hs-layout'>)</span> <span class='hs-varid'>bvx'</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>V</span> <span class='hs-varid'>x</span> <span class='hs-varid'>y</span>+</pre><p>The <code>adjustVel</code> function calculates a candidate velocity for the next frame given collision information and the current velocity. Even though it would return the current speed if there are no collisions, we don’t evaluate it at all thanks to the laziness of applicative nodes. In the end, velocity is only recalculated when a collision is detected.</p><pre><span class='hs-varop'>&gt;</span>       <span class='hs-keyword'>let</span> <span class='hs-varid'>adjustVel</span> <span class='hs-varid'>ch</span> <span class='hs-varid'>cv</span> <span class='hs-varid'>cp</span> <span class='hs-layout'>(</span><span class='hs-conid'>V</span> <span class='hs-varid'>bvx</span> <span class='hs-varid'>bvy</span><span class='hs-layout'>)</span> <span class='hs-varid'>bvx'</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>V</span> <span class='hs-varid'>x</span> <span class='hs-varid'>y</span> <span class='hs-varop'>&gt;</span>               <span class='hs-keyword'>where</span> <span class='hs-varid'>x</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-keyword'>if</span> <span class='hs-varid'>ch</span> <span class='hs-keyword'>then</span> <span class='hs-comment'>-</span><span class='hs-num'>1</span> <span class='hs-keyword'>else</span> <span class='hs-num'>1</span><span class='hs-layout'>)</span><span class='hs-varop'>*</span><span class='hs-layout'>(</span><span class='hs-keyword'>if</span> <span class='hs-varid'>cp</span> <span class='hs-keyword'>then</span> <span class='hs-varid'>bvx'</span><span class='hs-varop'>*</span><span class='hs-num'>4</span> <span class='hs-keyword'>else</span> <span class='hs-varid'>bvx</span><span class='hs-layout'>)</span> <span class='hs-varop'>&gt;</span>                     <span class='hs-varid'>y</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>if</span> <span class='hs-varid'>cv</span> <span class='hs-varop'>||</span> <span class='hs-varid'>cp</span> <span class='hs-keyword'>then</span> <span class='hs-comment'>-</span><span class='hs-varid'>bvy</span> <span class='hs-keyword'>else</span> <span class='hs-varid'>bvy</span> <span class='hs-varop'>&gt;</span>           <span class='hs-varid'>ballNewVelX</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>getX</span> <span class='hs-varop'>&lt;$&gt;</span> <span class='hs-varid'>ballPos'</span><span class='hs-layout'>)</span><span class='hs-comment'>-</span><span class='hs-varid'>playerX</span><span class='hs-comment'>-</span><span class='hs-varid'>pure</span> <span class='hs-layout'>(</span><span class='hs-varid'>playerW</span><span class='hs-varop'>/</span><span class='hs-num'>2</span><span class='hs-layout'>)</span>-</pre><p-    >Collision events are modelled with bool signals that turn true while the ball overlaps the offending surface and approaches it at the same time. Collision response will make sure that the second condition does not hold in the next instant, so there is no need to push these through an <code-      >edge</code-      > transfer function.</p-    ><pre><span class='hs-varop'>&gt;</span>           <span class='hs-varid'>ballCollHorz</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>any</span> <span class='hs-varid'>getBrickHColl</span> <span class='hs-varop'>&lt;$&gt;</span> <span class='hs-varid'>brickSamples'</span><span class='hs-layout'>)</span>+</pre><p>Collision events are modelled with bool signals that turn true while the ball overlaps the offending surface and approaches it at the same time. Collision response will make sure that the second condition does not hold in the next instant, so there is no need to push these through an <code>edge</code> transfer function.</p><pre><span class='hs-varop'>&gt;</span>           <span class='hs-varid'>ballCollHorz</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>any</span> <span class='hs-varid'>getBrickHColl</span> <span class='hs-varop'>&lt;$&gt;</span> <span class='hs-varid'>brickSamples'</span><span class='hs-layout'>)</span> <span class='hs-varop'>&gt;</span>                          <span class='hs-varop'>||@</span> <span class='hs-layout'>(</span><span class='hs-varid'>check</span> <span class='hs-varop'>&lt;$&gt;</span> <span class='hs-varid'>ballPos'</span> <span class='hs-varop'>&lt;*&gt;</span> <span class='hs-varid'>ballVel'</span><span class='hs-layout'>)</span> <span class='hs-varop'>&gt;</span>               <span class='hs-keyword'>where</span> <span class='hs-varid'>check</span> <span class='hs-layout'>(</span><span class='hs-conid'>V</span> <span class='hs-varid'>bx</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>V</span> <span class='hs-varid'>bvx</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>bx</span> <span class='hs-varop'>&lt;</span> <span class='hs-comment'>-</span><span class='hs-varid'>fieldW</span> <span class='hs-varop'>&amp;&amp;</span> <span class='hs-varid'>bvx</span> <span class='hs-varop'>&lt;</span> <span class='hs-num'>0</span><span class='hs-layout'>)</span> <span class='hs-varop'>||</span> <span class='hs-varop'>&gt;</span>                                                <span class='hs-layout'>(</span><span class='hs-varid'>bx</span> <span class='hs-varop'>&gt;</span> <span class='hs-varid'>fieldW</span><span class='hs-comment'>-</span><span class='hs-varid'>ballW</span> <span class='hs-varop'>&amp;&amp;</span> <span class='hs-varid'>bvx</span> <span class='hs-varop'>&gt;</span> <span class='hs-num'>0</span><span class='hs-layout'>)</span>@@ -183,11 +98,7 @@ <span class='hs-varop'>&gt;</span>           <span class='hs-varid'>ballCollPlayer</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>check</span> <span class='hs-varop'>&lt;$&gt;</span> <span class='hs-varid'>ballPos'</span> <span class='hs-varop'>&lt;*&gt;</span> <span class='hs-varid'>ballVel'</span> <span class='hs-varop'>&lt;*&gt;</span> <span class='hs-varid'>playerX</span> <span class='hs-varop'>&gt;</span>               <span class='hs-keyword'>where</span> <span class='hs-varid'>check</span> <span class='hs-layout'>(</span><span class='hs-conid'>V</span> <span class='hs-varid'>bx</span> <span class='hs-varid'>by</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>V</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>bvy</span><span class='hs-layout'>)</span> <span class='hs-varid'>px</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>bvy</span> <span class='hs-varop'>&lt;</span> <span class='hs-num'>0</span> <span class='hs-varop'>&amp;&amp;</span> <span class='hs-varop'>&gt;</span>                        <span class='hs-varid'>doRectsIntersect</span> <span class='hs-varid'>bx</span> <span class='hs-varid'>by</span> <span class='hs-varid'>ballW</span> <span class='hs-varid'>ballH</span> <span class='hs-varid'>px</span> <span class='hs-varid'>playerY</span> <span class='hs-varid'>playerW</span> <span class='hs-varid'>playerH</span>-</pre><p-    >Bricks are defined by the updater function <code-      >evolveBrick</code-      > as a transformer of the ball position. The transfer function takes care of fading and checking collision. Collision information is part of the state of the transfer function, even though it is strictly a function of the brick data and the ball position at the moment. However, since we need to check collisions in order to update the state of the brick, it’s simpler and more efficient to let the outer world see the results of these checks instead of having to recalculate them.</p-    ><pre><span class='hs-varop'>&gt;</span>       <span class='hs-keyword'>let</span> <span class='hs-varid'>brick</span> <span class='hs-layout'>(</span><span class='hs-varid'>x</span><span class='hs-layout'>,</span><span class='hs-varid'>y</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>transfer</span> <span class='hs-layout'>(</span><span class='hs-varid'>x</span><span class='hs-layout'>,</span><span class='hs-varid'>y</span><span class='hs-layout'>,</span><span class='hs-conid'>Live</span><span class='hs-layout'>,</span><span class='hs-conid'>False</span><span class='hs-layout'>,</span><span class='hs-conid'>False</span><span class='hs-layout'>)</span> <span class='hs-varid'>evolveBrick</span> <span class='hs-varid'>ballPos</span>+</pre><p>Bricks are defined by the updater function <code>evolveBrick</code> as a transformer of the ball position. The transfer function takes care of fading and checking collision. Collision information is part of the state of the transfer function, even though it is strictly a function of the brick data and the ball position at the moment. However, since we need to check collisions in order to update the state of the brick, it’s simpler and more efficient to let the outer world see the results of these checks instead of having to recalculate them.</p><pre><span class='hs-varop'>&gt;</span>       <span class='hs-keyword'>let</span> <span class='hs-varid'>brick</span> <span class='hs-layout'>(</span><span class='hs-varid'>x</span><span class='hs-layout'>,</span><span class='hs-varid'>y</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>transfer</span> <span class='hs-layout'>(</span><span class='hs-varid'>x</span><span class='hs-layout'>,</span><span class='hs-varid'>y</span><span class='hs-layout'>,</span><span class='hs-conid'>Live</span><span class='hs-layout'>,</span><span class='hs-conid'>False</span><span class='hs-layout'>,</span><span class='hs-conid'>False</span><span class='hs-layout'>)</span> <span class='hs-varid'>evolveBrick</span> <span class='hs-varid'>ballPos</span> <span class='hs-varop'>&gt;</span>           <span class='hs-varid'>getBrickData</span> <span class='hs-layout'>(</span><span class='hs-varid'>x</span><span class='hs-layout'>,</span><span class='hs-varid'>y</span><span class='hs-layout'>,</span><span class='hs-varid'>s</span><span class='hs-layout'>,</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>x</span><span class='hs-layout'>,</span><span class='hs-varid'>y</span><span class='hs-layout'>,</span><span class='hs-varid'>s</span><span class='hs-layout'>)</span> <span class='hs-varop'>&gt;</span>           <span class='hs-varid'>getBrickHColl</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-varid'>c</span><span class='hs-layout'>,</span><span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>c</span> <span class='hs-varop'>&gt;</span>           <span class='hs-varid'>getBrickVColl</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-varid'>c</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>c</span>@@ -201,51 +112,19 @@ <span class='hs-varop'>&gt;</span>                     <span class='hs-varid'>isHorz</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>xDist</span><span class='hs-varop'>/</span><span class='hs-varid'>brickW</span> <span class='hs-varop'>&gt;</span> <span class='hs-varid'>yDist</span><span class='hs-varop'>/</span><span class='hs-varid'>brickH</span> <span class='hs-varop'>&gt;</span>                         <span class='hs-keyword'>where</span> <span class='hs-varid'>xDist</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>abs</span> <span class='hs-layout'>(</span><span class='hs-layout'>(</span><span class='hs-varid'>x</span><span class='hs-varop'>+</span><span class='hs-varid'>brickW</span><span class='hs-varop'>/</span><span class='hs-num'>2</span><span class='hs-layout'>)</span><span class='hs-comment'>-</span><span class='hs-layout'>(</span><span class='hs-varid'>bx</span><span class='hs-varop'>+</span><span class='hs-varid'>ballW</span><span class='hs-varop'>/</span><span class='hs-num'>2</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-varop'>&gt;</span>                               <span class='hs-varid'>yDist</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>abs</span> <span class='hs-layout'>(</span><span class='hs-layout'>(</span><span class='hs-varid'>y</span><span class='hs-varop'>+</span><span class='hs-varid'>brickH</span><span class='hs-varop'>/</span><span class='hs-num'>2</span><span class='hs-layout'>)</span><span class='hs-comment'>-</span><span class='hs-layout'>(</span><span class='hs-varid'>by</span><span class='hs-varop'>+</span><span class='hs-varid'>ballH</span><span class='hs-varop'>/</span><span class='hs-num'>2</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>-</pre><p-    >The <code-      >isBrickNeeded</code-      > function is used to decide whether a brick should be kept in the collection. As soon as it turns false, the brick in question is removed from the <code-      >bricks</code-      > signal.</p-    ><pre><span class='hs-varop'>&gt;</span>           <span class='hs-varid'>isBrickNeeded</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-conid'>Dying</span> <span class='hs-varid'>a</span><span class='hs-layout'>,</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>a</span> <span class='hs-varop'>&gt;</span> <span class='hs-num'>0</span>+</pre><p>The <code>isBrickNeeded</code> function is used to decide whether a brick should be kept in the collection. As soon as it turns false, the brick in question is removed from the <code>bricks</code> signal.</p><pre><span class='hs-varop'>&gt;</span>           <span class='hs-varid'>isBrickNeeded</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-conid'>Dying</span> <span class='hs-varid'>a</span><span class='hs-layout'>,</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>a</span> <span class='hs-varop'>&gt;</span> <span class='hs-num'>0</span> <span class='hs-varop'>&gt;</span>           <span class='hs-varid'>isBrickNeeded</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-conid'>Live</span>   <span class='hs-layout'>,</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>True</span>-</pre><p-    >The <code-      >brickSamples</code-      > signal contains a snapshot of every brick, and it’s obtained simply by traversing the collection (this is equivalent to rebuilding the structure with lifted constructors), then applying a sampler, which collapses the two signal layers into one. We take advantage of the fact that lists are instances of Traversable.</p-    ><pre><span class='hs-varop'>&gt;</span>           <span class='hs-varid'>brickSamples</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>join</span> <span class='hs-layout'>(</span><span class='hs-varid'>sequenceA</span> <span class='hs-varop'>&lt;$&gt;</span> <span class='hs-varid'>bricks</span><span class='hs-layout'>)</span>+</pre><p>The <code>brickSamples</code> signal contains a snapshot of every brick, and it’s obtained simply by traversing the collection (this is equivalent to rebuilding the structure with lifted constructors), then applying a sampler, which collapses the two signal layers into one. We take advantage of the fact that lists are instances of Traversable.</p><pre><span class='hs-varop'>&gt;</span>           <span class='hs-varid'>brickSamples</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>join</span> <span class='hs-layout'>(</span><span class='hs-varid'>sequenceA</span> <span class='hs-varop'>&lt;$&gt;</span> <span class='hs-varid'>bricks</span><span class='hs-layout'>)</span> <span class='hs-varop'>&gt;</span> <span class='hs-varop'>&gt;</span>       <span class='hs-varid'>brickSamples'</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>delay</span> <span class='hs-conid'>[]</span> <span class='hs-varid'>brickSamples</span>-</pre><p-    >The <code-      >bricks</code-      > signal carries the dynamic list of bricks along with ball-brick collision information, all of which are updated in each frame. We start out with a number of live bricks in the positions given by the <code-      >brickPos0</code-      > list, and derive the list of the next frame from the current one by filtering out the bricks for which <code-      >isBrickNeeded</code-      > evaluates to false. These updates are made explicit by using <code-      >delay</code-      > to define the dynamic collection.</p-    ><pre><span class='hs-varop'>&gt;</span>       <span class='hs-varid'>bricks</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-keyword'>do</span>+</pre><p>The <code>bricks</code> signal carries the dynamic list of bricks along with ball-brick collision information, all of which are updated in each frame. We start out with a number of live bricks in the positions given by the <code>brickPos0</code> list, and derive the list of the next frame from the current one by filtering out the bricks for which <code>isBrickNeeded</code> evaluates to false. These updates are made explicit by using <code>delay</code> to define the dynamic collection.</p><pre><span class='hs-varop'>&gt;</span>       <span class='hs-varid'>bricks</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-keyword'>do</span> <span class='hs-varop'>&gt;</span>         <span class='hs-varid'>bricksInit</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>mapM</span> <span class='hs-varid'>brick</span> <span class='hs-varid'>brickPos0</span> <span class='hs-varop'>&gt;</span>         <span class='hs-keyword'>let</span> <span class='hs-varid'>bricksNext</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>map</span> <span class='hs-varid'>snd</span> <span class='hs-varop'>.</span> <span class='hs-varid'>filter</span> <span class='hs-layout'>(</span><span class='hs-varid'>isBrickNeeded</span> <span class='hs-varop'>.</span> <span class='hs-varid'>fst</span><span class='hs-layout'>)</span> <span class='hs-varop'>&lt;$&gt;</span> <span class='hs-layout'>(</span><span class='hs-varid'>zip</span> <span class='hs-varop'>&lt;$&gt;</span> <span class='hs-varid'>brickSamples</span> <span class='hs-varop'>&lt;*&gt;</span> <span class='hs-varid'>bricks</span><span class='hs-layout'>)</span> <span class='hs-varop'>&gt;</span>         <span class='hs-varid'>delay</span> <span class='hs-varid'>bricksInit</span> <span class='hs-varid'>bricksNext</span>-</pre><p-    >And knowing all these signals we can finally assemble the signal of rendering actions, i.e. the animation:</p-    ><pre><span class='hs-varop'>&gt;</span>   <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-varid'>renderLevel</span> <span class='hs-varop'>&lt;$&gt;</span> <span class='hs-varid'>playerX</span> <span class='hs-varop'>&lt;*&gt;</span> <span class='hs-varid'>ballPos</span> <span class='hs-varop'>&lt;*&gt;</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>getBrickData</span> <span class='hs-varop'>&lt;$&gt;</span> <span class='hs-varid'>brickSamples</span><span class='hs-layout'>)</span>-</pre><p-    >The <code-      >doRectsIntersect</code-      > function decides whether two rectangles defined by their top left corners and dimensions overlap.</p-    ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>doRectsIntersect</span> <span class='hs-varid'>x1</span> <span class='hs-varid'>y1</span> <span class='hs-varid'>sx1</span> <span class='hs-varid'>sy1</span> <span class='hs-varid'>x2</span> <span class='hs-varid'>y2</span> <span class='hs-varid'>sx2</span> <span class='hs-varid'>sy2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>collIV</span> <span class='hs-varid'>x1</span> <span class='hs-varid'>sx1</span> <span class='hs-varid'>x2</span> <span class='hs-varid'>sx2</span> <span class='hs-varop'>&amp;&amp;</span> <span class='hs-varid'>collIV</span> <span class='hs-varid'>y1</span> <span class='hs-varid'>sy1</span> <span class='hs-varid'>y2</span> <span class='hs-varid'>sy2</span>+</pre><p>And knowing all these signals we can finally assemble the signal of rendering actions, i.e. the animation:</p><pre><span class='hs-varop'>&gt;</span>   <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-varid'>renderLevel</span> <span class='hs-varop'>&lt;$&gt;</span> <span class='hs-varid'>playerX</span> <span class='hs-varop'>&lt;*&gt;</span> <span class='hs-varid'>ballPos</span> <span class='hs-varop'>&lt;*&gt;</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>getBrickData</span> <span class='hs-varop'>&lt;$&gt;</span> <span class='hs-varid'>brickSamples</span><span class='hs-layout'>)</span>+</pre><p>The <code>doRectsIntersect</code> function decides whether two rectangles defined by their top left corners and dimensions overlap.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>doRectsIntersect</span> <span class='hs-varid'>x1</span> <span class='hs-varid'>y1</span> <span class='hs-varid'>sx1</span> <span class='hs-varid'>sy1</span> <span class='hs-varid'>x2</span> <span class='hs-varid'>y2</span> <span class='hs-varid'>sx2</span> <span class='hs-varid'>sy2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>collIV</span> <span class='hs-varid'>x1</span> <span class='hs-varid'>sx1</span> <span class='hs-varid'>x2</span> <span class='hs-varid'>sx2</span> <span class='hs-varop'>&amp;&amp;</span> <span class='hs-varid'>collIV</span> <span class='hs-varid'>y1</span> <span class='hs-varid'>sy1</span> <span class='hs-varid'>y2</span> <span class='hs-varid'>sy2</span> <span class='hs-varop'>&gt;</span>     <span class='hs-keyword'>where</span> <span class='hs-varid'>collIV</span> <span class='hs-varid'>p1</span> <span class='hs-varid'>s1</span> <span class='hs-varid'>p2</span> <span class='hs-varid'>s2</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>p1</span> <span class='hs-varop'>&lt;=</span> <span class='hs-varid'>p2</span> <span class='hs-varop'>&amp;&amp;</span> <span class='hs-varid'>p2</span> <span class='hs-varop'>&lt;=</span> <span class='hs-varid'>p1</span><span class='hs-varop'>+</span><span class='hs-varid'>s1</span><span class='hs-layout'>)</span> <span class='hs-varop'>||</span> <span class='hs-layout'>(</span><span class='hs-varid'>p2</span> <span class='hs-varop'>&lt;=</span> <span class='hs-varid'>p1</span> <span class='hs-varop'>&amp;&amp;</span> <span class='hs-varid'>p1</span> <span class='hs-varop'>&lt;=</span> <span class='hs-varid'>p2</span><span class='hs-varop'>+</span><span class='hs-varid'>s2</span><span class='hs-layout'>)</span>-</pre><p-    >The <code-      >renderLevel</code-      > function takes a snapshot of the game and turns it into an IO action that displays this snapshot on the screen. The <code-      >breakout</code-      > signal is the time-varying version of this IO action.</p-    ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>renderLevel</span> <span class='hs-varid'>playerX</span> <span class='hs-layout'>(</span><span class='hs-conid'>V</span> <span class='hs-varid'>ballX</span> <span class='hs-varid'>ballY</span><span class='hs-layout'>)</span> <span class='hs-varid'>bricks</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>+</pre><p>The <code>renderLevel</code> function takes a snapshot of the game and turns it into an IO action that displays this snapshot on the screen. The <code>breakout</code> signal is the time-varying version of this IO action.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>renderLevel</span> <span class='hs-varid'>playerX</span> <span class='hs-layout'>(</span><span class='hs-conid'>V</span> <span class='hs-varid'>ballX</span> <span class='hs-varid'>ballY</span><span class='hs-layout'>)</span> <span class='hs-varid'>bricks</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-varop'>&gt;</span>   <span class='hs-keyword'>let</span> <span class='hs-varid'>drawRect</span> <span class='hs-varid'>x</span> <span class='hs-varid'>y</span> <span class='hs-varid'>xs</span> <span class='hs-varid'>ys</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-varop'>&gt;</span>         <span class='hs-varid'>loadIdentity</span> <span class='hs-varop'>&gt;</span>         <span class='hs-varid'>renderPrimitive</span> <span class='hs-conid'>Quads</span> <span class='hs-varop'>$</span> <span class='hs-keyword'>do</span>@@ -281,27 +160,7 @@ <span class='hs-varop'>&gt;</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>flush</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>swapBuffers</span>-</pre></div-  ><div id="backend"-  ><h2-    >Backend</h2-    ><p-    >The <code-      >readInput</code-      > function has two responsibilities: it provides input for the <code-      >mousePosition</code-      > peripheral signal through its associated sink, and also feeds the time difference between two states into the system, deciding when to exit altogether (by returning <code-      >Nothing</code-      > instead of the current <code-      >dt</code-      > value wrapped in <code-      >Just</code-      >).</p-    ><p-    >The <code-      >threadDelay</code-      > call at the beginning is just a trick to give the scheduler a breath. It will cause a wait equal to a scheduler tick, which is 20ms by default. The program can run perfectly without it, but it eats up all the free CPU to produce an unnecessarily high frame rate.</p-    ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>readInput</span> <span class='hs-varid'>mousePos</span> <span class='hs-varid'>closed</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>+</pre><h2 id="backend">Backend</h2><p>The <code>readInput</code> function has two responsibilities: it provides input for the <code>mousePosition</code> peripheral signal through its associated sink, and also feeds the time difference between two states into the system, deciding when to exit altogether (by returning <code>Nothing</code> instead of the current <code>dt</code> value wrapped in <code>Just</code>).</p><p>The <code>threadDelay</code> call at the beginning is just a trick to give the scheduler a breath. It will cause a wait equal to a scheduler tick, which is 20ms by default. The program can run perfectly without it, but it eats up all the free CPU to produce an unnecessarily high frame rate.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>readInput</span> <span class='hs-varid'>mousePos</span> <span class='hs-varid'>closed</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>threadDelay</span> <span class='hs-num'>0</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>t</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>get</span> <span class='hs-conid'>GLFW</span><span class='hs-varop'>.</span><span class='hs-varid'>time</span> <span class='hs-varop'>&gt;</span>   <span class='hs-conid'>GLFW</span><span class='hs-varop'>.</span><span class='hs-varid'>time</span> <span class='hs-varop'>$=</span> <span class='hs-num'>0</span>@@ -310,20 +169,12 @@ <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>k</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>getKey</span> <span class='hs-conid'>ESC</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>c</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>readIORef</span> <span class='hs-varid'>closed</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-keyword'>if</span> <span class='hs-varid'>c</span> <span class='hs-varop'>||</span> <span class='hs-varid'>k</span> <span class='hs-varop'>==</span> <span class='hs-conid'>Press</span> <span class='hs-keyword'>then</span> <span class='hs-conid'>Nothing</span> <span class='hs-keyword'>else</span> <span class='hs-conid'>Just</span> <span class='hs-varid'>t</span><span class='hs-layout'>)</span>-</pre><p-    >The <code-      >initGL</code-      > function sets up almost nothing, which means that most functionality is turned off. Only alpha blending is enabled to provide some minimalistic eye candy.</p-    ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>initGL</span> <span class='hs-varid'>width</span> <span class='hs-varid'>height</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>+</pre><p>The <code>initGL</code> function sets up almost nothing, which means that most functionality is turned off. Only alpha blending is enabled to provide some minimalistic eye candy.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>initGL</span> <span class='hs-varid'>width</span> <span class='hs-varid'>height</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>clearColor</span> <span class='hs-varop'>$=</span> <span class='hs-conid'>Color4</span> <span class='hs-num'>0</span> <span class='hs-num'>0</span> <span class='hs-num'>0</span> <span class='hs-num'>1</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>blend</span> <span class='hs-varop'>$=</span> <span class='hs-conid'>Enabled</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>blendFunc</span> <span class='hs-varop'>$=</span> <span class='hs-layout'>(</span><span class='hs-conid'>SrcAlpha</span><span class='hs-layout'>,</span><span class='hs-conid'>OneMinusSrcAlpha</span><span class='hs-layout'>)</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>cullFace</span> <span class='hs-varop'>$=</span> <span class='hs-conid'>Just</span> <span class='hs-conid'>Back</span>-</pre><p-    >The resize callback feeds the <code-      >windowSize</code-      > signal through its sink besides adjusting the projection matrix.</p-    ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>resizeGLScene</span> <span class='hs-varid'>winSize</span> <span class='hs-varid'>size</span><span class='hs-keyglyph'>@</span><span class='hs-layout'>(</span><span class='hs-conid'>Size</span> <span class='hs-varid'>w</span> <span class='hs-varid'>h</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>+</pre><p>The resize callback feeds the <code>windowSize</code> signal through its sink besides adjusting the projection matrix.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>resizeGLScene</span> <span class='hs-varid'>winSize</span> <span class='hs-varid'>size</span><span class='hs-keyglyph'>@</span><span class='hs-layout'>(</span><span class='hs-conid'>Size</span> <span class='hs-varid'>w</span> <span class='hs-varid'>h</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>winSize</span> <span class='hs-layout'>(</span><span class='hs-conid'>V</span> <span class='hs-layout'>(</span><span class='hs-varid'>fromIntegral</span> <span class='hs-varid'>w</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>fromIntegral</span> <span class='hs-varid'>h</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-varop'>&gt;</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>viewport</span> <span class='hs-varop'>$=</span> <span class='hs-layout'>(</span><span class='hs-conid'>Position</span> <span class='hs-num'>0</span> <span class='hs-num'>0</span><span class='hs-layout'>,</span><span class='hs-varid'>size</span><span class='hs-layout'>)</span>@@ -333,63 +184,28 @@ <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>scale</span> <span class='hs-num'>1</span> <span class='hs-layout'>(</span><span class='hs-varid'>fromIntegral</span> <span class='hs-varid'>w</span><span class='hs-varop'>/</span><span class='hs-varid'>fromIntegral</span> <span class='hs-varid'>h</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-num'>1</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>GLfloat</span><span class='hs-layout'>)</span> <span class='hs-varop'>&gt;</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>matrixMode</span> <span class='hs-varop'>$=</span> <span class='hs-conid'>Modelview</span> <span class='hs-num'>0</span>-</pre></div-  ></div-><div id="utils-module"-><h1-  >Utils module</h1-  ><p-  >This module contains some functions that might make it into the core library eventually.</p-  ><pre><span class='hs-varop'>&gt;</span> <span class='hs-keyword'>module</span> <span class='hs-conid'>Common</span><span class='hs-varop'>.</span><span class='hs-conid'>Utils</span> <span class='hs-keyword'>where</span>+</pre><h1 id="utils-module">Utils module</h1><p>This module contains some functions that might make it into the core library eventually.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-keyword'>module</span> <span class='hs-conid'>Common</span><span class='hs-varop'>.</span><span class='hs-conid'>Utils</span> <span class='hs-keyword'>where</span> <span class='hs-varop'>&gt;</span> <span class='hs-varop'>&gt;</span> <span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Applicative</span> <span class='hs-varop'>&gt;</span> <span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span> <span class='hs-varop'>&gt;</span> <span class='hs-keyword'>import</span> <span class='hs-conid'>FRP</span><span class='hs-varop'>.</span><span class='hs-conid'>Elerea</span><span class='hs-varop'>.</span><span class='hs-conid'>Param</span> <span class='hs-varop'>&gt;</span> <span class='hs-varop'>&gt;</span> <span class='hs-keyword'>import</span> <span class='hs-conid'>Common</span><span class='hs-varop'>.</span><span class='hs-conid'>Vector</span>-</pre><p-  >The <code-    >driveNetwork</code-    > function simply executes the supersteps while the <code-    >driver</code-    > function keeps returning valid delta time values.</p-  ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>driveNetwork</span> <span class='hs-varid'>network</span> <span class='hs-varid'>driver</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>+</pre><p>The <code>driveNetwork</code> function simply executes the supersteps while the <code>driver</code> function keeps returning valid delta time values.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>driveNetwork</span> <span class='hs-varid'>network</span> <span class='hs-varid'>driver</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>dt</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>driver</span> <span class='hs-varop'>&gt;</span>   <span class='hs-keyword'>case</span> <span class='hs-varid'>dt</span> <span class='hs-keyword'>of</span> <span class='hs-varop'>&gt;</span>     <span class='hs-conid'>Just</span> <span class='hs-varid'>dt</span> <span class='hs-keyglyph'>&rarr;</span> <span class='hs-keyword'>do</span> <span class='hs-varid'>join</span> <span class='hs-layout'>(</span><span class='hs-varid'>network</span> <span class='hs-varid'>dt</span><span class='hs-layout'>)</span> <span class='hs-varop'>&gt;</span>                   <span class='hs-varid'>driveNetwork</span> <span class='hs-varid'>network</span> <span class='hs-varid'>driver</span> <span class='hs-varop'>&gt;</span>     <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>&rarr;</span> <span class='hs-varid'>return</span> <span class='hs-conid'>()</span>-</pre><p-  >A scalar integral function for <code-    >Fractional</code-    > instances.</p-  ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>integral</span> <span class='hs-varid'>v0</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>transfer</span> <span class='hs-varid'>v0</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-varid'>dt</span> <span class='hs-varid'>v</span> <span class='hs-varid'>v0</span> <span class='hs-keyglyph'>&rarr;</span> <span class='hs-varid'>v0</span><span class='hs-varop'>+</span><span class='hs-varid'>v</span><span class='hs-varop'>*</span><span class='hs-varid'>realToFrac</span> <span class='hs-varid'>dt</span><span class='hs-layout'>)</span> <span class='hs-varid'>s</span>-</pre><p-  >An integral function for two-dimensional vectors defined in the <code-    >Vector</code-    > module.</p-  ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>integralVec</span> <span class='hs-varid'>v0</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>transfer</span> <span class='hs-varid'>v0</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-varid'>dt</span> <span class='hs-varid'>v</span> <span class='hs-varid'>v0</span> <span class='hs-keyglyph'>&rarr;</span> <span class='hs-varid'>v0</span><span class='hs-varop'>^+^</span><span class='hs-layout'>(</span><span class='hs-varid'>v</span><span class='hs-varop'>^*.</span><span class='hs-varid'>realToFrac</span> <span class='hs-varid'>dt</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-varid'>s</span>-</pre><p-  >A rising edge detector.</p-  ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>edge</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>+</pre><p>A scalar integral function for <code>Fractional</code> instances.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>integral</span> <span class='hs-varid'>v0</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>transfer</span> <span class='hs-varid'>v0</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-varid'>dt</span> <span class='hs-varid'>v</span> <span class='hs-varid'>v0</span> <span class='hs-keyglyph'>&rarr;</span> <span class='hs-varid'>v0</span><span class='hs-varop'>+</span><span class='hs-varid'>v</span><span class='hs-varop'>*</span><span class='hs-varid'>realToFrac</span> <span class='hs-varid'>dt</span><span class='hs-layout'>)</span> <span class='hs-varid'>s</span>+</pre><p>An integral function for two-dimensional vectors defined in the <code>Vector</code> module.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>integralVec</span> <span class='hs-varid'>v0</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>transfer</span> <span class='hs-varid'>v0</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-varid'>dt</span> <span class='hs-varid'>v</span> <span class='hs-varid'>v0</span> <span class='hs-keyglyph'>&rarr;</span> <span class='hs-varid'>v0</span><span class='hs-varop'>^+^</span><span class='hs-layout'>(</span><span class='hs-varid'>v</span><span class='hs-varop'>^*.</span><span class='hs-varid'>realToFrac</span> <span class='hs-varid'>dt</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-varid'>s</span>+</pre><p>A rising edge detector.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>edge</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>s'</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>delay</span> <span class='hs-conid'>False</span> <span class='hs-varid'>s</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-varid'>s'</span> <span class='hs-varop'>&gt;&gt;=</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>x</span> <span class='hs-keyglyph'>&rarr;</span> <span class='hs-keyword'>if</span> <span class='hs-varid'>x</span> <span class='hs-keyword'>then</span> <span class='hs-varid'>return</span> <span class='hs-conid'>False</span> <span class='hs-keyword'>else</span> <span class='hs-varid'>s</span>-</pre><p-  >A latch that always remembers the last value of a <code-    >Maybe</code-    > signal wrapped in <code-    >Just</code-    >.</p-  ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>storeJust</span> <span class='hs-varid'>x0</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>transfer</span> <span class='hs-varid'>x0</span> <span class='hs-varid'>store</span> <span class='hs-varid'>s</span>+</pre><p>A latch that always remembers the last value of a <code>Maybe</code> signal wrapped in <code>Just</code>.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>storeJust</span> <span class='hs-varid'>x0</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>transfer</span> <span class='hs-varid'>x0</span> <span class='hs-varid'>store</span> <span class='hs-varid'>s</span> <span class='hs-varop'>&gt;</span>     <span class='hs-keyword'>where</span> <span class='hs-varid'>store</span> <span class='hs-keyword'>_</span> <span class='hs-conid'>Nothing</span>  <span class='hs-varid'>x</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>x</span> <span class='hs-varop'>&gt;</span>           <span class='hs-varid'>store</span> <span class='hs-keyword'>_</span> <span class='hs-layout'>(</span><span class='hs-conid'>Just</span> <span class='hs-varid'>x</span><span class='hs-layout'>)</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>x</span>-</pre></div-><div id="vector-module"-><h1-  >Vector module</h1-  ><p-  >This module contains a class for two-dimensional vectors, a strict datatype to instantiate it, and another instance for signals of the same type.</p-  ><pre><span class='hs-varop'>&gt;</span> <span class='hs-comment'>{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, TypeSynonymInstances #-}</span>+</pre><h1 id="vector-module">Vector module</h1><p>This module contains a class for two-dimensional vectors, a strict datatype to instantiate it, and another instance for signals of the same type.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-comment'>{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, TypeSynonymInstances #-}</span> <span class='hs-varop'>&gt;</span> <span class='hs-varop'>&gt;</span> <span class='hs-keyword'>module</span> <span class='hs-conid'>Common</span><span class='hs-varop'>.</span><span class='hs-conid'>Vector</span> <span class='hs-keyword'>where</span> <span class='hs-varop'>&gt;</span>@@ -432,11 +248,6 @@ <span class='hs-varop'>&gt;</span>     <span class='hs-varid'>vnull</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>pure</span> <span class='hs-varid'>vnull</span> <span class='hs-varop'>&gt;</span>     <span class='hs-varid'>dot</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>liftA2</span> <span class='hs-varid'>dot</span> <span class='hs-varop'>&gt;</span>     <span class='hs-varid'>cross</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>liftA2</span> <span class='hs-varid'>cross</span>-</pre></body>-</html>--</div->+</pre></body></html> </body> </html>-

doc/Chase.html view

@@ -1,27 +1,15 @@ <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> <html xmlns="http://www.w3.org/1999/xhtml"> <head>-  <title></title>   <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />+  <meta http-equiv="Content-Style-Type" content="text/css" />   <meta name="generator" content="pandoc" />-  <meta name="date" content="" />+  <title></title>+  <style type="text/css">code{white-space: pre;}</style>   <link rel="stylesheet" href="hscolour.css" type="text/css" /> </head> <body>-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">-<html>-<head>-<!-- Generated by HsColour, http://www.cs.york.ac.uk/fp/darcs/hscolour/ --><title>Haskell code</title> <link type='text/css' rel='stylesheet' href='hscolour.css' /></head>-<body><div id="elerea-chase-example"-><h1-  >Elerea Chase example</h1-  ><p-  >This is a minimal example to show how to define signals that can be mutually recursive and can optionally depend on user input too. The grey square accelerates towards the red square at a rate proportional to their relative position, and it can be given a momentary impulse with the left mouse button.</p-  ><p-  >For a slightly more complex example check out <code-    >Breakout.lhs</code-    >.</p-  ><pre><span class='hs-varop'>&gt;</span> <span class='hs-comment'>{-# LANGUAGE DoRec #-}</span>+<?xml version="1.0" encoding="UTF-8"?><!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"><html><head><!-- Generated by HsColour, http://code.haskell.org/~malcolm/hscolour/ --><title>Haskell code</title><link type='text/css' rel='stylesheet' href='hscolour.css' /></head><body><h1 id="elerea-chase-example">Elerea Chase example</h1><p>This is a minimal example to show how to define signals that can be mutually recursive and can optionally depend on user input too. The grey square accelerates towards the red square at a rate proportional to their relative position, and it can be given a momentary impulse with the left mouse button.</p><p>For a slightly more complex example check out <code>Breakout.lhs</code>.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-comment'>{-# LANGUAGE DoRec #-}</span> <span class='hs-varop'>&gt;</span> <span class='hs-varop'>&gt;</span> <span class='hs-keyword'>module</span> <span class='hs-conid'>Main</span> <span class='hs-keyword'>where</span> <span class='hs-varop'>&gt;</span>@@ -34,22 +22,14 @@ <span class='hs-varop'>&gt;</span> <span class='hs-varop'>&gt;</span> <span class='hs-keyword'>import</span> <span class='hs-conid'>Common</span><span class='hs-varop'>.</span><span class='hs-conid'>Utils</span> <span class='hs-varop'>&gt;</span> <span class='hs-keyword'>import</span> <span class='hs-conid'>Common</span><span class='hs-varop'>.</span><span class='hs-conid'>Vector</span>-</pre><p-  >The <code-    >main</code-    > function contains the whole reactive logic. Note that <code-    >driveNetwork</code-    > is just a simple loop, and you can see its source below in the <code-    >Utils</code-    > module.</p-  ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>main</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>+</pre><p>The <code>main</code> function contains the whole reactive logic. Note that <code>driveNetwork</code> is just a simple loop, and you can see its source below in the <code>Utils</code> module.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>main</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-varop'>&gt;</span>     <span class='hs-varid'>initialize</span> <span class='hs-varop'>&gt;</span>     <span class='hs-varid'>openWindow</span> <span class='hs-layout'>(</span><span class='hs-conid'>Size</span> <span class='hs-num'>640</span> <span class='hs-num'>480</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>DisplayRGBBits</span> <span class='hs-num'>8</span> <span class='hs-num'>8</span> <span class='hs-num'>8</span><span class='hs-layout'>,</span> <span class='hs-conid'>DisplayAlphaBits</span> <span class='hs-num'>8</span><span class='hs-layout'>,</span> <span class='hs-conid'>DisplayDepthBits</span> <span class='hs-num'>24</span><span class='hs-keyglyph'>]</span> <span class='hs-conid'>Window</span> <span class='hs-varop'>&gt;</span>     <span class='hs-varid'>windowTitle</span> <span class='hs-varop'>$=</span> <span class='hs-str'>"Elerea Chase"</span> <span class='hs-varop'>&gt;</span>-<span class='hs-varop'>&gt;</span>     <span class='hs-layout'>(</span><span class='hs-varid'>windowSize</span><span class='hs-layout'>,</span><span class='hs-varid'>windowSizeSink</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>external</span> <span class='hs-varid'>vnull</span>-<span class='hs-varop'>&gt;</span>     <span class='hs-layout'>(</span><span class='hs-varid'>mousePosition</span><span class='hs-layout'>,</span><span class='hs-varid'>mousePositionSink</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>external</span> <span class='hs-varid'>vnull</span>-<span class='hs-varop'>&gt;</span>     <span class='hs-layout'>(</span><span class='hs-varid'>mousePress</span><span class='hs-layout'>,</span><span class='hs-varid'>mousePressSink</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>external</span> <span class='hs-conid'>False</span>+<span class='hs-varop'>&gt;</span>     <span class='hs-layout'>(</span><span class='hs-varid'>windowSizeGen</span><span class='hs-layout'>,</span><span class='hs-varid'>windowSizeSink</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>external</span> <span class='hs-varid'>vnull</span>+<span class='hs-varop'>&gt;</span>     <span class='hs-layout'>(</span><span class='hs-varid'>mousePositionGen</span><span class='hs-layout'>,</span><span class='hs-varid'>mousePositionSink</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>external</span> <span class='hs-varid'>vnull</span>+<span class='hs-varop'>&gt;</span>     <span class='hs-layout'>(</span><span class='hs-varid'>mousePressGen</span><span class='hs-layout'>,</span><span class='hs-varid'>mousePressSink</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>external</span> <span class='hs-conid'>False</span> <span class='hs-varop'>&gt;</span> <span class='hs-varop'>&gt;</span>     <span class='hs-varid'>closed</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>newIORef</span> <span class='hs-conid'>False</span> <span class='hs-varop'>&gt;</span>     <span class='hs-varid'>windowSizeCallback</span> <span class='hs-varop'>$=</span> <span class='hs-varid'>resizeGLScene</span> <span class='hs-varid'>windowSizeSink</span>@@ -57,6 +37,9 @@ <span class='hs-varop'>&gt;</span>     <span class='hs-varid'>initGL</span> <span class='hs-num'>640</span> <span class='hs-num'>480</span> <span class='hs-varop'>&gt;</span> <span class='hs-varop'>&gt;</span>     <span class='hs-varid'>network</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>start</span> <span class='hs-varop'>$</span> <span class='hs-keyword'>do</span>+<span class='hs-varop'>&gt;</span>         <span class='hs-varid'>mousePress</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>mousePressGen</span>+<span class='hs-varop'>&gt;</span>         <span class='hs-varid'>mousePosition</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>mousePositionGen</span>+<span class='hs-varop'>&gt;</span>         <span class='hs-varid'>windowSize</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>windowSizeGen</span> <span class='hs-varop'>&gt;</span>         <span class='hs-varid'>mouseClick</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>edge</span> <span class='hs-varid'>mousePress</span> <span class='hs-varop'>&gt;</span>         <span class='hs-varid'>rec</span> <span class='hs-keyword'>let</span> <span class='hs-varid'>newVel</span> <span class='hs-varid'>clk</span> <span class='hs-varid'>v0</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>clk</span> <span class='hs-keyword'>of</span> <span class='hs-varop'>&gt;</span>                     <span class='hs-conid'>True</span> <span class='hs-keyglyph'>&rarr;</span> <span class='hs-conid'>Just</span> <span class='hs-varop'>&lt;$&gt;</span> <span class='hs-varid'>integralVec</span> <span class='hs-varid'>v0</span> <span class='hs-varid'>acc</span>@@ -72,13 +55,7 @@ <span class='hs-varop'>&gt;</span>     <span class='hs-varid'>driveNetwork</span> <span class='hs-varid'>network</span> <span class='hs-layout'>(</span><span class='hs-varid'>readInput</span> <span class='hs-varid'>mousePositionSink</span> <span class='hs-varid'>mousePressSink</span> <span class='hs-varid'>closed</span><span class='hs-layout'>)</span> <span class='hs-varop'>&gt;</span> <span class='hs-varop'>&gt;</span>     <span class='hs-varid'>closeWindow</span>-</pre><p-  >The <code-    >render</code-    > function takes a snapshot of the system (window size and the positions of the squares) and turns it into OpenGL calls. The signal executed by the <code-    >driveNetwork</code-    > function is the time-varying version of the IO action returned here.</p-  ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>render</span> <span class='hs-layout'>(</span><span class='hs-conid'>V</span> <span class='hs-varid'>w</span> <span class='hs-varid'>h</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>V</span> <span class='hs-varid'>cx</span> <span class='hs-varid'>cy</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>V</span> <span class='hs-varid'>ox</span> <span class='hs-varid'>oy</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>+</pre><p>The <code>render</code> function takes a snapshot of the system (window size and the positions of the squares) and turns it into OpenGL calls. The signal executed by the <code>driveNetwork</code> function is the time-varying version of the IO action returned here.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>render</span> <span class='hs-layout'>(</span><span class='hs-conid'>V</span> <span class='hs-varid'>w</span> <span class='hs-varid'>h</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>V</span> <span class='hs-varid'>cx</span> <span class='hs-varid'>cy</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>V</span> <span class='hs-varid'>ox</span> <span class='hs-varid'>oy</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-varop'>&gt;</span>   <span class='hs-keyword'>let</span> <span class='hs-varid'>drawSquare</span> <span class='hs-varid'>x</span> <span class='hs-varid'>y</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-varop'>&gt;</span>         <span class='hs-varid'>loadIdentity</span> <span class='hs-varop'>&gt;</span>         <span class='hs-varid'>translate</span> <span class='hs-varop'>$</span> <span class='hs-conid'>Vector3</span> <span class='hs-layout'>(</span><span class='hs-varid'>x</span><span class='hs-varop'>/</span><span class='hs-varid'>w</span><span class='hs-varop'>*</span><span class='hs-num'>2</span><span class='hs-comment'>-</span><span class='hs-num'>1</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>h</span><span class='hs-varop'>/</span><span class='hs-varid'>w</span><span class='hs-comment'>-</span><span class='hs-varid'>y</span><span class='hs-varop'>/</span><span class='hs-varid'>w</span><span class='hs-varop'>*</span><span class='hs-num'>2</span><span class='hs-layout'>)</span> <span class='hs-num'>0</span>@@ -97,13 +74,7 @@ <span class='hs-varop'>&gt;</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>flush</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>swapBuffers</span>-</pre><p-  >The <code-    >readInput</code-    > function provides the driver layer. It feeds the peripheral-bound signals and also decides when to stop execution by returning <code-    >Nothing</code-    > instead of the time elapsed since its last call.</p-  ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>readInput</span> <span class='hs-varid'>mousePos</span> <span class='hs-varid'>mouseBut</span> <span class='hs-varid'>closed</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>+</pre><p>The <code>readInput</code> function provides the driver layer. It feeds the peripheral-bound signals and also decides when to stop execution by returning <code>Nothing</code> instead of the time elapsed since its last call.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>readInput</span> <span class='hs-varid'>mousePos</span> <span class='hs-varid'>mouseBut</span> <span class='hs-varid'>closed</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>t</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>get</span> <span class='hs-conid'>GLFW</span><span class='hs-varop'>.</span><span class='hs-varid'>time</span> <span class='hs-varop'>&gt;</span>   <span class='hs-conid'>GLFW</span><span class='hs-varop'>.</span><span class='hs-varid'>time</span> <span class='hs-varop'>$=</span> <span class='hs-num'>0</span> <span class='hs-varop'>&gt;</span>   <span class='hs-conid'>Position</span> <span class='hs-varid'>x</span> <span class='hs-varid'>y</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>get</span> <span class='hs-conid'>GLFW</span><span class='hs-varop'>.</span><span class='hs-varid'>mousePos</span>@@ -113,17 +84,11 @@ <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>k</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>getKey</span> <span class='hs-conid'>ESC</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>c</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>readIORef</span> <span class='hs-varid'>closed</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-keyword'>if</span> <span class='hs-varid'>c</span> <span class='hs-varop'>||</span> <span class='hs-varid'>k</span> <span class='hs-varop'>==</span> <span class='hs-conid'>Press</span> <span class='hs-keyword'>then</span> <span class='hs-conid'>Nothing</span> <span class='hs-keyword'>else</span> <span class='hs-conid'>Just</span> <span class='hs-varid'>t</span><span class='hs-layout'>)</span>-</pre><p-  >OpenGL is initialised with practically everything turned off. Only alpha blending is needed to be able to use translucent colours.</p-  ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>initGL</span> <span class='hs-varid'>width</span> <span class='hs-varid'>height</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>+</pre><p>OpenGL is initialised with practically everything turned off. Only alpha blending is needed to be able to use translucent colours.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>initGL</span> <span class='hs-varid'>width</span> <span class='hs-varid'>height</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>clearColor</span> <span class='hs-varop'>$=</span> <span class='hs-conid'>Color4</span> <span class='hs-num'>0</span> <span class='hs-num'>0</span> <span class='hs-num'>0</span> <span class='hs-num'>1</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>blend</span> <span class='hs-varop'>$=</span> <span class='hs-conid'>Enabled</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>blendFunc</span> <span class='hs-varop'>$=</span> <span class='hs-layout'>(</span><span class='hs-conid'>SrcAlpha</span><span class='hs-layout'>,</span><span class='hs-conid'>OneMinusSrcAlpha</span><span class='hs-layout'>)</span>-</pre><p-  >The window size callback takes care of the <code-    >windowSize</code-    > signal and the projection matrix.</p-  ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>resizeGLScene</span> <span class='hs-varid'>winSize</span> <span class='hs-varid'>size</span><span class='hs-keyglyph'>@</span><span class='hs-layout'>(</span><span class='hs-conid'>Size</span> <span class='hs-varid'>w</span> <span class='hs-varid'>h</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>+</pre><p>The window size callback takes care of the <code>windowSize</code> signal and the projection matrix.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>resizeGLScene</span> <span class='hs-varid'>winSize</span> <span class='hs-varid'>size</span><span class='hs-keyglyph'>@</span><span class='hs-layout'>(</span><span class='hs-conid'>Size</span> <span class='hs-varid'>w</span> <span class='hs-varid'>h</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>winSize</span> <span class='hs-layout'>(</span><span class='hs-conid'>V</span> <span class='hs-layout'>(</span><span class='hs-varid'>fromIntegral</span> <span class='hs-varid'>w</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>fromIntegral</span> <span class='hs-varid'>h</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-varop'>&gt;</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>viewport</span> <span class='hs-varop'>$=</span> <span class='hs-layout'>(</span><span class='hs-conid'>Position</span> <span class='hs-num'>0</span> <span class='hs-num'>0</span><span class='hs-layout'>,</span><span class='hs-varid'>size</span><span class='hs-layout'>)</span>@@ -133,62 +98,28 @@ <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>scale</span> <span class='hs-num'>1</span> <span class='hs-layout'>(</span><span class='hs-varid'>fromIntegral</span> <span class='hs-varid'>w</span><span class='hs-varop'>/</span><span class='hs-varid'>fromIntegral</span> <span class='hs-varid'>h</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-num'>1</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>GLfloat</span><span class='hs-layout'>)</span> <span class='hs-varop'>&gt;</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>matrixMode</span> <span class='hs-varop'>$=</span> <span class='hs-conid'>Modelview</span> <span class='hs-num'>0</span>-</pre></div-><div id="utils-module"-><h1-  >Utils module</h1-  ><p-  >This module contains some functions that might make it into the core library eventually.</p-  ><pre><span class='hs-varop'>&gt;</span> <span class='hs-keyword'>module</span> <span class='hs-conid'>Common</span><span class='hs-varop'>.</span><span class='hs-conid'>Utils</span> <span class='hs-keyword'>where</span>+</pre><h1 id="utils-module">Utils module</h1><p>This module contains some functions that might make it into the core library eventually.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-keyword'>module</span> <span class='hs-conid'>Common</span><span class='hs-varop'>.</span><span class='hs-conid'>Utils</span> <span class='hs-keyword'>where</span> <span class='hs-varop'>&gt;</span> <span class='hs-varop'>&gt;</span> <span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Applicative</span> <span class='hs-varop'>&gt;</span> <span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span> <span class='hs-varop'>&gt;</span> <span class='hs-keyword'>import</span> <span class='hs-conid'>FRP</span><span class='hs-varop'>.</span><span class='hs-conid'>Elerea</span><span class='hs-varop'>.</span><span class='hs-conid'>Param</span> <span class='hs-varop'>&gt;</span> <span class='hs-varop'>&gt;</span> <span class='hs-keyword'>import</span> <span class='hs-conid'>Common</span><span class='hs-varop'>.</span><span class='hs-conid'>Vector</span>-</pre><p-  >The <code-    >driveNetwork</code-    > function simply executes the supersteps while the <code-    >driver</code-    > function keeps returning valid delta time values.</p-  ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>driveNetwork</span> <span class='hs-varid'>network</span> <span class='hs-varid'>driver</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>+</pre><p>The <code>driveNetwork</code> function simply executes the supersteps while the <code>driver</code> function keeps returning valid delta time values.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>driveNetwork</span> <span class='hs-varid'>network</span> <span class='hs-varid'>driver</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>dt</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>driver</span> <span class='hs-varop'>&gt;</span>   <span class='hs-keyword'>case</span> <span class='hs-varid'>dt</span> <span class='hs-keyword'>of</span> <span class='hs-varop'>&gt;</span>     <span class='hs-conid'>Just</span> <span class='hs-varid'>dt</span> <span class='hs-keyglyph'>&rarr;</span> <span class='hs-keyword'>do</span> <span class='hs-varid'>join</span> <span class='hs-layout'>(</span><span class='hs-varid'>network</span> <span class='hs-varid'>dt</span><span class='hs-layout'>)</span> <span class='hs-varop'>&gt;</span>                   <span class='hs-varid'>driveNetwork</span> <span class='hs-varid'>network</span> <span class='hs-varid'>driver</span> <span class='hs-varop'>&gt;</span>     <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>&rarr;</span> <span class='hs-varid'>return</span> <span class='hs-conid'>()</span>-</pre><p-  >A scalar integral function for <code-    >Fractional</code-    > instances.</p-  ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>integral</span> <span class='hs-varid'>v0</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>transfer</span> <span class='hs-varid'>v0</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-varid'>dt</span> <span class='hs-varid'>v</span> <span class='hs-varid'>v0</span> <span class='hs-keyglyph'>&rarr;</span> <span class='hs-varid'>v0</span><span class='hs-varop'>+</span><span class='hs-varid'>v</span><span class='hs-varop'>*</span><span class='hs-varid'>realToFrac</span> <span class='hs-varid'>dt</span><span class='hs-layout'>)</span> <span class='hs-varid'>s</span>-</pre><p-  >An integral function for two-dimensional vectors defined in the <code-    >Vector</code-    > module.</p-  ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>integralVec</span> <span class='hs-varid'>v0</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>transfer</span> <span class='hs-varid'>v0</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-varid'>dt</span> <span class='hs-varid'>v</span> <span class='hs-varid'>v0</span> <span class='hs-keyglyph'>&rarr;</span> <span class='hs-varid'>v0</span><span class='hs-varop'>^+^</span><span class='hs-layout'>(</span><span class='hs-varid'>v</span><span class='hs-varop'>^*.</span><span class='hs-varid'>realToFrac</span> <span class='hs-varid'>dt</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-varid'>s</span>-</pre><p-  >A rising edge detector.</p-  ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>edge</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>+</pre><p>A scalar integral function for <code>Fractional</code> instances.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>integral</span> <span class='hs-varid'>v0</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>transfer</span> <span class='hs-varid'>v0</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-varid'>dt</span> <span class='hs-varid'>v</span> <span class='hs-varid'>v0</span> <span class='hs-keyglyph'>&rarr;</span> <span class='hs-varid'>v0</span><span class='hs-varop'>+</span><span class='hs-varid'>v</span><span class='hs-varop'>*</span><span class='hs-varid'>realToFrac</span> <span class='hs-varid'>dt</span><span class='hs-layout'>)</span> <span class='hs-varid'>s</span>+</pre><p>An integral function for two-dimensional vectors defined in the <code>Vector</code> module.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>integralVec</span> <span class='hs-varid'>v0</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>transfer</span> <span class='hs-varid'>v0</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-varid'>dt</span> <span class='hs-varid'>v</span> <span class='hs-varid'>v0</span> <span class='hs-keyglyph'>&rarr;</span> <span class='hs-varid'>v0</span><span class='hs-varop'>^+^</span><span class='hs-layout'>(</span><span class='hs-varid'>v</span><span class='hs-varop'>^*.</span><span class='hs-varid'>realToFrac</span> <span class='hs-varid'>dt</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-varid'>s</span>+</pre><p>A rising edge detector.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>edge</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>s'</span> <span class='hs-keyglyph'>&larr;</span> <span class='hs-varid'>delay</span> <span class='hs-conid'>False</span> <span class='hs-varid'>s</span> <span class='hs-varop'>&gt;</span>   <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-varid'>s'</span> <span class='hs-varop'>&gt;&gt;=</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>x</span> <span class='hs-keyglyph'>&rarr;</span> <span class='hs-keyword'>if</span> <span class='hs-varid'>x</span> <span class='hs-keyword'>then</span> <span class='hs-varid'>return</span> <span class='hs-conid'>False</span> <span class='hs-keyword'>else</span> <span class='hs-varid'>s</span>-</pre><p-  >A latch that always remembers the last value of a <code-    >Maybe</code-    > signal wrapped in <code-    >Just</code-    >.</p-  ><pre><span class='hs-varop'>&gt;</span> <span class='hs-varid'>storeJust</span> <span class='hs-varid'>x0</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>transfer</span> <span class='hs-varid'>x0</span> <span class='hs-varid'>store</span> <span class='hs-varid'>s</span>+</pre><p>A latch that always remembers the last value of a <code>Maybe</code> signal wrapped in <code>Just</code>.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-definition'>storeJust</span> <span class='hs-varid'>x0</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>transfer</span> <span class='hs-varid'>x0</span> <span class='hs-varid'>store</span> <span class='hs-varid'>s</span> <span class='hs-varop'>&gt;</span>     <span class='hs-keyword'>where</span> <span class='hs-varid'>store</span> <span class='hs-keyword'>_</span> <span class='hs-conid'>Nothing</span>  <span class='hs-varid'>x</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>x</span> <span class='hs-varop'>&gt;</span>           <span class='hs-varid'>store</span> <span class='hs-keyword'>_</span> <span class='hs-layout'>(</span><span class='hs-conid'>Just</span> <span class='hs-varid'>x</span><span class='hs-layout'>)</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>x</span>-</pre></div-><div id="vector-module"-><h1-  >Vector module</h1-  ><p-  >This module contains a class for two-dimensional vectors, a strict datatype to instantiate it, and another instance for signals of the same type.</p-  ><pre><span class='hs-varop'>&gt;</span> <span class='hs-comment'>{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, TypeSynonymInstances #-}</span>+</pre><h1 id="vector-module">Vector module</h1><p>This module contains a class for two-dimensional vectors, a strict datatype to instantiate it, and another instance for signals of the same type.</p><pre><span class='hs-varop'>&gt;</span> <span class='hs-comment'>{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, TypeSynonymInstances #-}</span> <span class='hs-varop'>&gt;</span> <span class='hs-varop'>&gt;</span> <span class='hs-keyword'>module</span> <span class='hs-conid'>Common</span><span class='hs-varop'>.</span><span class='hs-conid'>Vector</span> <span class='hs-keyword'>where</span> <span class='hs-varop'>&gt;</span>@@ -231,11 +162,6 @@ <span class='hs-varop'>&gt;</span>     <span class='hs-varid'>vnull</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>pure</span> <span class='hs-varid'>vnull</span> <span class='hs-varop'>&gt;</span>     <span class='hs-varid'>dot</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>liftA2</span> <span class='hs-varid'>dot</span> <span class='hs-varop'>&gt;</span>     <span class='hs-varid'>cross</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>liftA2</span> <span class='hs-varid'>cross</span>-</pre></body>-</html>--</div->+</pre></body></html> </body> </html>-

doc/Makefile view

@@ -1,10 +1,10 @@-.SUFFIXES: .lhs .html--PANDOC := pandoc --no-wrap -s -S-HSCOLOUR := HsColour -lit-UNIOPS := sed "s/>&lt;-</>\&larr;</g" | sed "s/>-&gt;</>\&rarr;</g" | sed "s/varid'>mdo/keyword'>mdo/g"--all: ../src/Breakout.html ../src/Chase.html--.lhs.html:-	cat $< $(dir $<)Common/*lhs | $(HSCOLOUR) -css | $(PANDOC) -t html -c hscolour.css | $(UNIOPS) > $(notdir $@)+.SUFFIXES: .lhs .html
+
+PANDOC := pandoc --no-wrap -s -S
+HSCOLOUR := HsColour -lit
+UNIOPS := sed "s/>&lt;-</>\&larr;</g" | sed "s/>-&gt;</>\&rarr;</g" | sed "s/varid'>mdo/keyword'>mdo/g"
+
+all: ../src/Breakout.html ../src/Chase.html
+
+.lhs.html:
+	cat $< $(dir $<)Common/*lhs | $(HSCOLOUR) -css | $(PANDOC) -t html -c hscolour.css | $(UNIOPS) > $(notdir $@)

doc/hscolour.css view

@@ -1,11 +1,11 @@-.hs-keyword { color: #000; font-weight: bold }--.hs-keyglyph { color: #033 }--.hs-varid { color: #00c }--.hs-varop { color: #990 }--.hs-conid { color: #080 }--.hs-comment { color: #a00 }+.hs-keyword { color: #000; font-weight: bold }
+
+.hs-keyglyph { color: #033 }
+
+.hs-varid { color: #00c }
+
+.hs-varop { color: #990 }
+
+.hs-conid { color: #080 }
+
+.hs-comment { color: #a00 }

elerea-examples.cabal view

@@ -1,66 +1,66 @@-Name:                elerea-examples-Version:             2.2.3-Cabal-Version:       >= 1.2-Synopsis:            Example applications for Elerea-Category:            reactivity, FRP-Description:--  Example applications for Elerea. They are factored out into their-  own package so as to avoid unnecessary dependencies in the-  library. Check out the @doc@ directory for the colourful literate-  sources.-  .-  The programs included are the following:-  .-  * bounce: an example for creating dynamic collections of signals;-    left click to create balls, drag existing balls with left button-    to propel them and drag with right to select balls for deletion-    (upon release);-  .-  * chase: a minimal example that demonstrates reactivity and mutually-    recursive signals;-  .-  * breakout: a not too fancy breakout clone; you can simply use the-    mouse to move the paddle.--Author:              Patai Gergely-Maintainer:          Patai Gergely (patai@iit.bme.hu)-Copyright:           (c) 2009-2012, Patai Gergely-License:             BSD3-License-File:        LICENSE-Stability:           experimental-Build-Type:          Simple-Extra-Source-Files:-  src/Common/Vector.lhs-  src/Common/Utils.lhs--  src/Bounce/Event.hs-  src/Bounce/Math.hs-  src/Bounce/Util.hs-  src/Bounce/Vector.hs--  doc/Breakout.html-  doc/Breakout.png-  doc/Chase.html-  doc/hscolour.css-  doc/Makefile--  README--Executable elerea-bounce-  HS-Source-Dirs:    src/Bounce-  Main-IS:           Main.hs-  Build-Depends:     base >= 3 && < 5, elerea >= 2.2.0, OpenGL, GLFW >= 0.5 && < 0.6-  GHC-Options:       -O2 -fno-warn-deprecated-flags--Executable elerea-breakout-  HS-Source-Dirs:    src-  Main-IS:           Breakout.lhs-  Build-Depends:     base >= 3 && < 5, elerea >= 2.2.0, OpenGL, GLFW >= 0.5 && < 0.6-  GHC-Options:       -O2 -fno-warn-deprecated-flags--Executable elerea-chase-  HS-Source-Dirs:    src-  Main-IS:           Chase.lhs-  Build-Depends:     base >= 3 && < 5, elerea >= 2.2.0, OpenGL, GLFW >= 0.5 && < 0.6-  GHC-Options:       -O2 -fno-warn-deprecated-flags+Name:                elerea-examples
+Version:             2.9.0
+Cabal-Version:       >= 1.6
+Synopsis:            Example applications for Elerea
+Category:            reactivity, FRP
+Description:
+
+  Example applications for Elerea. They are factored out into their
+  own package so as to avoid unnecessary dependencies in the
+  library. Check out the @doc@ directory for the colourful literate
+  sources.
+  .
+  The programs included are the following:
+  .
+  * bounce: an example for creating dynamic collections of signals;
+    left click to create balls, drag existing balls with left button
+    to propel them and drag with right to select balls for deletion
+    (upon release);
+  .
+  * chase: a minimal example that demonstrates reactivity and mutually
+    recursive signals;
+  .
+  * breakout: a not too fancy breakout clone; you can simply use the
+    mouse to move the paddle.
+
+Author:              Patai Gergely
+Maintainer:          Patai Gergely (patai@iit.bme.hu)
+Copyright:           (c) 2009-2012, Patai Gergely
+License:             BSD3
+License-File:        LICENSE
+Stability:           experimental
+Build-Type:          Simple
+Extra-Source-Files:
+  src/Common/Vector.lhs
+  src/Common/Utils.lhs
+
+  src/Bounce/Event.hs
+  src/Bounce/Math.hs
+  src/Bounce/Util.hs
+  src/Bounce/Vector.hs
+
+  doc/Breakout.html
+  doc/Breakout.png
+  doc/Chase.html
+  doc/hscolour.css
+  doc/Makefile
+
+  README
+
+Executable elerea-bounce
+  HS-Source-Dirs:    src/Bounce
+  Main-IS:           Main.hs
+  Build-Depends:     base >= 3 && < 5, elerea == 2.9.*, OpenGL, GLFW >= 0.5 && < 0.6
+  GHC-Options:       -O2 -fno-warn-deprecated-flags
+
+Executable elerea-breakout
+  HS-Source-Dirs:    src
+  Main-IS:           Breakout.lhs
+  Build-Depends:     base >= 3 && < 5, elerea == 2.9.*, OpenGL, GLFW >= 0.5 && < 0.6
+  GHC-Options:       -O2 -fno-warn-deprecated-flags
+
+Executable elerea-chase
+  HS-Source-Dirs:    src
+  Main-IS:           Chase.lhs
+  Build-Depends:     base >= 3 && < 5, elerea == 2.9.*, OpenGL, GLFW >= 0.5 && < 0.6
+  GHC-Options:       -O2 -fno-warn-deprecated-flags

src/Bounce/Event.hs view

@@ -1,46 +1,46 @@-{-# LANGUAGE DoRec #-}--module Event where--import Control.Applicative-import Control.Monad-import Control.Monad.Fix-import Data.Maybe-import FRP.Elerea.Param--import Util---- | Events are signals with an option type.-type Event a = Signal (Maybe a)---- | Sample a signal whenever a changing condition is true.-ifE :: Signal Bool -> Signal a -> Event a-ifE c s = c >>= \b -> if b then Just <$> s else return Nothing---- | Left-biased merge.-leftE :: Event a -> Event a -> Event a-leftE e1 e2 = e1 >>= maybeE e2---- | Right-biased merge.-rightE :: Event a -> Event a -> Event a-rightE e1 e2 = e2 >>= maybeE e1---- | Left-biased merge of several events.-mergeE :: [Event a] -> Event a-mergeE []     = return Nothing-mergeE (e:es) = e >>= maybeE (mergeE es)---- | Maintain a changing list of entities fed in as events along with--- a function to derive the corresponding signal of the removal--- condition (the signal is removed when the associated removal signal--- is 'True' for the first time).-collectE :: Event a -> (a -> Signal Bool) -> SignalGen p (Signal [a])-collectE e f = do-  rec col <- delay [] col'-      col' <- memo $ filterM (fmap not . f) =<< liftM2 ((++).maybeToList) e col-  return col'---- | A helper function equivalent to @flip maybe (return.Just)@.-maybeE :: Event a -> Maybe a -> Event a-maybeE e Nothing = e-maybeE _ jx      = return jx+{-# LANGUAGE DoRec #-}
+
+module Event where
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Fix
+import Data.Maybe
+import FRP.Elerea.Param
+
+import Util
+
+-- | Events are signals with an option type.
+type Event a = Signal (Maybe a)
+
+-- | Sample a signal whenever a changing condition is true.
+ifE :: Signal Bool -> Signal a -> Event a
+ifE c s = c >>= \b -> if b then Just <$> s else return Nothing
+
+-- | Left-biased merge.
+leftE :: Event a -> Event a -> Event a
+leftE e1 e2 = e1 >>= maybeE e2
+
+-- | Right-biased merge.
+rightE :: Event a -> Event a -> Event a
+rightE e1 e2 = e2 >>= maybeE e1
+
+-- | Left-biased merge of several events.
+mergeE :: [Event a] -> Event a
+mergeE []     = return Nothing
+mergeE (e:es) = e >>= maybeE (mergeE es)
+
+-- | Maintain a changing list of entities fed in as events along with
+-- a function to derive the corresponding signal of the removal
+-- condition (the signal is removed when the associated removal signal
+-- is 'True' for the first time).
+collectE :: Event a -> (a -> Signal Bool) -> SignalGen p (Signal [a])
+collectE e f = do
+  rec col <- delay [] col'
+      col' <- memo $ filterM (fmap not . f) =<< liftM2 ((++).maybeToList) e col
+  return col'
+
+-- | A helper function equivalent to @flip maybe (return.Just)@.
+maybeE :: Event a -> Maybe a -> Event a
+maybeE e Nothing = e
+maybeE _ jx      = return jx

src/Bounce/Main.hs view

@@ -1,216 +1,219 @@-{-# LANGUAGE DoRec, NoMonomorphismRestriction #-}--module Main where--import Control.Applicative-import Control.Monad-import Data.IORef-import Data.List-import Data.Maybe-import FRP.Elerea.Param-import Graphics.UI.GLFW as GLFW-import Graphics.Rendering.OpenGL--import Event-import Math-import Util-import Vector--frameThickness = 0.05--ballSize = 0.05--ballFade = 2--data Ball = Ball { ballPos :: Vec-                 , ballCol :: Maybe GLfloat-                 , ballDrag :: Bool-                 }---- A box with bouncing balls inside:--- * left click creates a new ball,--- * existing balls can be dragged and propelled with the left button,--- * dragging with the right button creates a rectangle; every ball---   within the rectangle is deleted when the button is released.-bounceDemo renderFun mousePos mousePress = do-  rec leftPress <- memo $ fst <$> mousePress-      rightPress <- memo $ snd <$> mousePress--      (killDrag,killNow) <- dragRectangle mousePos rightPress-      killRect <- (vnull,vnull) --> killDrag-      let within (V tlx tly,V brx bry) (V x y) = x > min tlx brx && x < max tlx brx &&-                                                 y > min tly bry && y < max tly bry--      ballList <- collectE newBallE' $ \bs -> killNow &&@ (within <$> killRect <*> (ballPos <$> bs))-      ballData <- memo $ sequence =<< ballList-      -- Change edge to memo below to be able to add lots of balls with ease!-      newBallCond <- edge $ leftPress &&@ (all (not.ballDrag) <$> ballData)-      newBallE <- generator $ newBall <$> mousePos <*> newBallCond-      newBallE' <- delay Nothing newBallE-      let newBall pos cond = if cond-                             then Just <$> ball pos mousePos leftPress-                             else return Nothing--      frameCount <- stateful 0 (const (+1))-      fps <- derivT 2 frameCount--  return $ renderFun <$> ballData <*> killDrag <*> fps---- Flipflop signal: turns true when the first event fires, turns false--- when the second fires.-flipflop te fe = False --> leftE (ifE te (pure True)) (ifE fe (pure False))---- A rectangle created by dragging. When active, the coordinates of--- its opposing corners are wrapped in a Just, otherwise the data is--- Nothing. Also returns the event ending the drag.-dragRectangle mousePos mousePress = do-  dragBegin <- edge mousePress-  dragEnd <- edge (not <$> mousePress)-  drag <- flipflop dragBegin dragEnd-  topLeft <- vnull --> ifE dragBegin mousePos-  return (ifE drag ((,) <$> topLeft <*> mousePos), dragEnd)---- A ball that bounces within the box and can be dragged. It flashes--- every time its velocity changes.-ball initPos mousePos mousePress = do-  rec mouseDown <- edge mousePress-      let dragBegin = mouseDown &&@ (vlen (pos'^-^mousePos) <@ ballSize/2)-      dragEnd <- edge (not <$> mousePress)-      drag <- flipflop dragBegin dragEnd-      dragVel <- derivTV 0.05 mousePos--      let collHorz (V vx _) (V px _) = collFrame vx px-          collVert (V _ vy) (V _ py) = collFrame vy py-          collFrame v p = abs (p-0.5) > 0.5-(frameThickness+ballSize/2) && (p-0.5)*v > 0-      pos <- integralV initPos vel-      pos' <- delay initPos pos-      vel <- vnull --> velE-      vel' <- delay vnull vel-      velE <- memo $ mergeE [ifE drag dragVel,-                             ifE (collHorz <$> vel' <*> pos') (mul (V (-1) 1) <$> vel'),-                             ifE (collVert <$> vel' <*> pos') (mul (V 1 (-1)) <$> vel')]--  colour <- ballColour (isJust <$> velE)--  return $ Ball <$> pos <*> colour <*> drag---- A signal describing the colour of a ball. Nothing means normal--- state, Just denotes flashing.-ballColour hit = transfer Nothing update hit-  where update dt True  _    = Just 1-        update dt False prev = do t <- prev-                                  guard (t > 0)-                                  return (t-dt*ballFade)--driveNetwork network driver = do-  dt <- driver-  case dt of-    Just dt -> do join $ network dt-                  driveNetwork network driver-    Nothing -> return ()--main = do-  initialize-  openWindow (Size 640 480) [DisplayRGBBits 8 8 8, DisplayAlphaBits 8, DisplayDepthBits 24] Window-  windowTitle $= "Elerea Bounce"--  (mousePosition,mousePositionSink) <- external vnull-  (mousePress,mousePressSink) <- external (False,False)--  closed <- newIORef False-  windowSizeCallback $= resizeGLScene-  windowCloseCallback $= (writeIORef closed True >> return True)-  initGL 800 800--  unitCircle <- defineNewList Compile $ renderPrimitive TriangleStrip $ forM_ [0..20] $ \i -> do-    let a = 2*pi*i/20-    vertex $ Vertex3 (0.5*sin a) (0.5*cos a) (0 :: GLfloat)-    vertex $ Vertex3 0 0 (0 :: GLfloat)--  demo <- start $ bounceDemo (render unitCircle) mousePosition mousePress-  time $= 0-  driveNetwork demo (readInput mousePositionSink mousePressSink closed)--  closeWindow--initGL width height = do-  clearColor $= Color4 0 0 0 1-  blend $= Enabled-  blendFunc $= (SrcAlpha,OneMinusSrcAlpha)--resizeGLScene size@(Size w h) = do-  let r = 2*fromIntegral w/fromIntegral h-      r' = 2*fromIntegral h/fromIntegral w--  viewport $= (Position 0 0,size)--  matrixMode $= Projection-  loadIdentity-  scale (min 2 r') (min 2 r) (1 :: GLfloat)-  translate $ Vector3 (-0.5) (-0.5) (0 :: GLfloat)--  matrixMode $= Modelview 0--render unitCircle bs rect fps = do-  let drawRectangle x y sx sy = do-        renderPrimitive Quads $ do-          vertex $ Vertex3 (x)    (y)    (0 :: GLfloat)-          vertex $ Vertex3 (x+sx) (y)    (0 :: GLfloat)-          vertex $ Vertex3 (x+sx) (y+sy) (0 :: GLfloat)-          vertex $ Vertex3 (x)    (y+sy) (0 :: GLfloat)-      drawEllipse xc yc xs ys n = preservingMatrix $ do-        translate $ Vector3 xc yc (0 :: GLfloat)-        scale xs ys (1 :: GLfloat)-        callList unitCircle--  clear [ColorBuffer]-  loadIdentity--  color $ Color4 0.6 0.6 0.6 (1 :: GLfloat)-  drawRectangle 0 0 1 frameThickness-  drawRectangle 0 (1-frameThickness) 1 frameThickness-  drawRectangle 0 0 frameThickness 1-  drawRectangle (1-frameThickness) 0 frameThickness 1--  forM_ bs $ \b -> do-    case ballCol b of-      Nothing -> color $ Color4 0 0 0.7 (1 :: GLfloat)-      Just t -> color $ Color4 (0.9*t) (0.9*t) (0.7*(1-t)) (1 :: GLfloat)--    let V x y = ballPos b-    drawEllipse x y ballSize ballSize 20--  case rect of-    Nothing -> return ()-    Just (V tlx tly,V brx bry) -> do-      color $ Color4 1 0 0 (0.4 :: GLfloat)-      drawRectangle tlx tly (brx-tlx) (bry-tly)--  scale 0.003 0.003 (1 :: GLfloat)-  color $ Color4 1 1 1 (1 :: GLfloat)-  renderString Fixed8x16 $ " FPS: " ++ show fps ++ " balls: " ++ show (length bs)--  flush-  swapBuffers--readInput mousePos mouseBut closed = do-  t <- get time-  time $= 0--  Position x y <- get GLFW.mousePos-  Size w h <- get windowSize-  let x' = fromIntegral x-      y' = fromIntegral y-      w' = fromIntegral w-      h' = fromIntegral h-      mx = (x'-max 0 (w'-h')/2)/min w' h'-      my = (y'-max 0 (h'-w')/2)/min w' h'-  mousePos (V mx (1-my))--  bl <- getMouseButton ButtonLeft-  br <- getMouseButton ButtonRight-  mouseBut (bl == Press, br == Press)-  k <- getKey ESC-  c <- readIORef closed--  return (if c || k == Press then Nothing else Just (realToFrac t))+{-# LANGUAGE DoRec, NoMonomorphismRestriction #-}
+
+module Main where
+
+import Control.Applicative
+import Control.Monad
+import Data.IORef
+import Data.List
+import Data.Maybe
+import FRP.Elerea.Param
+import Graphics.UI.GLFW as GLFW
+import Graphics.Rendering.OpenGL
+
+import Event
+import Math
+import Util
+import Vector
+
+frameThickness = 0.05
+
+ballSize = 0.05
+
+ballFade = 2
+
+data Ball = Ball { ballPos :: Vec
+                 , ballCol :: Maybe GLfloat
+                 , ballDrag :: Bool
+                 }
+
+-- A box with bouncing balls inside:
+-- * left click creates a new ball,
+-- * existing balls can be dragged and propelled with the left button,
+-- * dragging with the right button creates a rectangle; every ball
+--   within the rectangle is deleted when the button is released.
+bounceDemo renderFun mousePos mousePress = do
+  rec leftPress <- memo $ fst <$> mousePress
+      rightPress <- memo $ snd <$> mousePress
+
+      (killDrag,killNow) <- dragRectangle mousePos rightPress
+      killRect <- (vnull,vnull) --> killDrag
+      let within (V tlx tly,V brx bry) (V x y) = x > min tlx brx && x < max tlx brx &&
+                                                 y > min tly bry && y < max tly bry
+
+      ballList <- collectE newBallE' $ \bs -> killNow &&@ (within <$> killRect <*> (ballPos <$> bs))
+      ballData <- memo $ sequence =<< ballList
+      -- Change edge to memo below to be able to add lots of balls with ease!
+      newBallCond <- edge $ leftPress &&@ (all (not.ballDrag) <$> ballData)
+      newBallE <- generator $ newBall <$> mousePos <*> newBallCond
+      newBallE' <- delay Nothing newBallE
+      let newBall pos cond = if cond
+                             then Just <$> ball pos mousePos leftPress
+                             else return Nothing
+
+      frameCount <- stateful 0 (const (+1))
+      fps <- derivT 2 frameCount
+
+  return $ renderFun <$> ballData <*> killDrag <*> fps
+
+-- Flipflop signal: turns true when the first event fires, turns false
+-- when the second fires.
+flipflop te fe = False --> leftE (ifE te (pure True)) (ifE fe (pure False))
+
+-- A rectangle created by dragging. When active, the coordinates of
+-- its opposing corners are wrapped in a Just, otherwise the data is
+-- Nothing. Also returns the event ending the drag.
+dragRectangle mousePos mousePress = do
+  dragBegin <- edge mousePress
+  dragEnd <- edge (not <$> mousePress)
+  drag <- flipflop dragBegin dragEnd
+  topLeft <- vnull --> ifE dragBegin mousePos
+  return (ifE drag ((,) <$> topLeft <*> mousePos), dragEnd)
+
+-- A ball that bounces within the box and can be dragged. It flashes
+-- every time its velocity changes.
+ball initPos mousePos mousePress = do
+  rec mouseDown <- edge mousePress
+      let dragBegin = mouseDown &&@ (vlen (pos'^-^mousePos) <@ ballSize/2)
+      dragEnd <- edge (not <$> mousePress)
+      drag <- flipflop dragBegin dragEnd
+      dragVel <- derivTV 0.05 mousePos
+
+      let collHorz (V vx _) (V px _) = collFrame vx px
+          collVert (V _ vy) (V _ py) = collFrame vy py
+          collFrame v p = abs (p-0.5) > 0.5-(frameThickness+ballSize/2) && (p-0.5)*v > 0
+      pos <- integralV initPos vel
+      pos' <- delay initPos pos
+      vel <- vnull --> velE
+      vel' <- delay vnull vel
+      velE <- memo $ mergeE [ifE drag dragVel,
+                             ifE (collHorz <$> vel' <*> pos') (mul (V (-1) 1) <$> vel'),
+                             ifE (collVert <$> vel' <*> pos') (mul (V 1 (-1)) <$> vel')]
+
+  colour <- ballColour (isJust <$> velE)
+
+  return $ Ball <$> pos <*> colour <*> drag
+
+-- A signal describing the colour of a ball. Nothing means normal
+-- state, Just denotes flashing.
+ballColour hit = transfer Nothing update hit
+  where update dt True  _    = Just 1
+        update dt False prev = do t <- prev
+                                  guard (t > 0)
+                                  return (t-dt*ballFade)
+
+driveNetwork network driver = do
+  dt <- driver
+  case dt of
+    Just dt -> do join $ network dt
+                  driveNetwork network driver
+    Nothing -> return ()
+
+main = do
+  initialize
+  openWindow (Size 640 480) [DisplayRGBBits 8 8 8, DisplayAlphaBits 8, DisplayDepthBits 24] Window
+  windowTitle $= "Elerea Bounce"
+
+  (mousePositionGen,mousePositionSink) <- external vnull
+  (mousePressGen,mousePressSink) <- external (False,False)
+
+  closed <- newIORef False
+  windowSizeCallback $= resizeGLScene
+  windowCloseCallback $= (writeIORef closed True >> return True)
+  initGL 800 800
+
+  unitCircle <- defineNewList Compile $ renderPrimitive TriangleStrip $ forM_ [0..20] $ \i -> do
+    let a = 2*pi*i/20
+    vertex $ Vertex3 (0.5*sin a) (0.5*cos a) (0 :: GLfloat)
+    vertex $ Vertex3 0 0 (0 :: GLfloat)
+
+  demo <- start $ do
+    mousePosition <- mousePositionGen
+    mousePress <- mousePressGen
+    bounceDemo (render unitCircle) mousePosition mousePress
+  time $= 0
+  driveNetwork demo (readInput mousePositionSink mousePressSink closed)
+
+  closeWindow
+
+initGL width height = do
+  clearColor $= Color4 0 0 0 1
+  blend $= Enabled
+  blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
+
+resizeGLScene size@(Size w h) = do
+  let r = 2*fromIntegral w/fromIntegral h
+      r' = 2*fromIntegral h/fromIntegral w
+
+  viewport $= (Position 0 0,size)
+
+  matrixMode $= Projection
+  loadIdentity
+  scale (min 2 r') (min 2 r) (1 :: GLfloat)
+  translate $ Vector3 (-0.5) (-0.5) (0 :: GLfloat)
+
+  matrixMode $= Modelview 0
+
+render unitCircle bs rect fps = do
+  let drawRectangle x y sx sy = do
+        renderPrimitive Quads $ do
+          vertex $ Vertex3 (x)    (y)    (0 :: GLfloat)
+          vertex $ Vertex3 (x+sx) (y)    (0 :: GLfloat)
+          vertex $ Vertex3 (x+sx) (y+sy) (0 :: GLfloat)
+          vertex $ Vertex3 (x)    (y+sy) (0 :: GLfloat)
+      drawEllipse xc yc xs ys n = preservingMatrix $ do
+        translate $ Vector3 xc yc (0 :: GLfloat)
+        scale xs ys (1 :: GLfloat)
+        callList unitCircle
+
+  clear [ColorBuffer]
+  loadIdentity
+
+  color $ Color4 0.6 0.6 0.6 (1 :: GLfloat)
+  drawRectangle 0 0 1 frameThickness
+  drawRectangle 0 (1-frameThickness) 1 frameThickness
+  drawRectangle 0 0 frameThickness 1
+  drawRectangle (1-frameThickness) 0 frameThickness 1
+
+  forM_ bs $ \b -> do
+    case ballCol b of
+      Nothing -> color $ Color4 0 0 0.7 (1 :: GLfloat)
+      Just t -> color $ Color4 (0.9*t) (0.9*t) (0.7*(1-t)) (1 :: GLfloat)
+
+    let V x y = ballPos b
+    drawEllipse x y ballSize ballSize 20
+
+  case rect of
+    Nothing -> return ()
+    Just (V tlx tly,V brx bry) -> do
+      color $ Color4 1 0 0 (0.4 :: GLfloat)
+      drawRectangle tlx tly (brx-tlx) (bry-tly)
+
+  scale 0.003 0.003 (1 :: GLfloat)
+  color $ Color4 1 1 1 (1 :: GLfloat)
+  renderString Fixed8x16 $ " FPS: " ++ show fps ++ " balls: " ++ show (length bs)
+
+  flush
+  swapBuffers
+
+readInput mousePos mouseBut closed = do
+  t <- get time
+  time $= 0
+
+  Position x y <- get GLFW.mousePos
+  Size w h <- get windowSize
+  let x' = fromIntegral x
+      y' = fromIntegral y
+      w' = fromIntegral w
+      h' = fromIntegral h
+      mx = (x'-max 0 (w'-h')/2)/min w' h'
+      my = (y'-max 0 (h'-w')/2)/min w' h'
+  mousePos (V mx (1-my))
+
+  bl <- getMouseButton ButtonLeft
+  br <- getMouseButton ButtonRight
+  mouseBut (bl == Press, br == Press)
+  k <- getKey ESC
+  c <- readIORef closed
+
+  return (if c || k == Press then Nothing else Just (realToFrac t))

src/Bounce/Math.hs view

@@ -1,60 +1,60 @@-{-# LANGUAGE NoMonomorphismRestriction #-}--module Math where--import Control.Applicative-import Data.List-import FRP.Elerea.Param--import Vector-import Util--{-| Scalar integral. -}-integral :: (Num a) => a -> Signal a -> SignalGen a (Signal a)-integral v0 s = transfer v0 (\dt v v0 -> v0+v*dt) s--{-| Vector integral. -}-integralV :: (Vector2D v c) => v -> Signal v -> SignalGen c (Signal v)-integralV v0 s = transfer v0 (\dt v v0 -> v0^+^(v^*.dt)) s--{-| Scalar derivative by the last two values. -}-deriv :: (Fractional a) => Signal a -> SignalGen a (Signal a)-deriv s = do-  sig <- transfer (0,0,1) (\dt v (v0,_,_) -> (v,v0,dt)) s-  initSignal 0 (d <$> sig)-  where d (x',x,dt) = (x'-x)/dt--{-| Vector derivative by the last two values. -}-derivV :: (Vector2D v c, Num c) => Signal v -> SignalGen c (Signal v)-derivV s = do-  sig <- transfer (vnull,vnull,1) (\dt v (v0,_,_) -> (v,v0,dt)) s-  initSignal vnull (d <$> sig)-  where d (x',x,dt) = (x'^-^x)^/.dt--{-| Scalar derivative by a given time period. -}-derivT :: (Fractional a, Ord a) => a -> Signal a -> SignalGen a (Signal a)-derivT wt s = do-  sig <- transfer (0,(0,0)) d s-  return (fst <$> sig)-  where d dt v (x,(v0,t)) = if t' > wt then ((v-v0)/t',(v,0)) else (x,(v0,t'))-          where t' = dt+t--{-| Vector derivative by a given time period. -}-derivTV :: (Vector2D v c, Ord c, Num c) => c -> Signal v -> SignalGen c (Signal v)-derivTV wt s = do-  sig <- transfer (vnull,(vnull,0)) d s-  return (fst <$> sig)-  where d dt v (x,(v0,t)) = if t' > wt then ((v^-^v0)^/.t',(v,0)) else (x,(v0,t'))-          where t' = dt+t--{-| Scalar moving average of a given number of recent samples. -}-movingAvg :: (Eq a, Fractional a) => a -> Signal a -> SignalGen p (Signal a)-movingAvg n s = do-  sig <- scanM n (delay 0) s-  return $ ((/n).sum) <$> sequence sig--{-| Vector moving average of a given number of recent samples. -}-movingAvgV :: (Eq c, Vector2D v c, Num c) => c -> Signal v -> SignalGen p (Signal v)-movingAvgV n s = do-  sig <- scanM n (delay vnull) s-  return $ ((^/.n).foldl1' (^+^)) <$> sequence sig+{-# LANGUAGE NoMonomorphismRestriction #-}
+
+module Math where
+
+import Control.Applicative
+import Data.List
+import FRP.Elerea.Param
+
+import Vector
+import Util
+
+{-| Scalar integral. -}
+integral :: (Num a) => a -> Signal a -> SignalGen a (Signal a)
+integral v0 s = transfer v0 (\dt v v0 -> v0+v*dt) s
+
+{-| Vector integral. -}
+integralV :: (Vector2D v c) => v -> Signal v -> SignalGen c (Signal v)
+integralV v0 s = transfer v0 (\dt v v0 -> v0^+^(v^*.dt)) s
+
+{-| Scalar derivative by the last two values. -}
+deriv :: (Fractional a) => Signal a -> SignalGen a (Signal a)
+deriv s = do
+  sig <- transfer (0,0,1) (\dt v (v0,_,_) -> (v,v0,dt)) s
+  initSignal 0 (d <$> sig)
+  where d (x',x,dt) = (x'-x)/dt
+
+{-| Vector derivative by the last two values. -}
+derivV :: (Vector2D v c, Num c) => Signal v -> SignalGen c (Signal v)
+derivV s = do
+  sig <- transfer (vnull,vnull,1) (\dt v (v0,_,_) -> (v,v0,dt)) s
+  initSignal vnull (d <$> sig)
+  where d (x',x,dt) = (x'^-^x)^/.dt
+
+{-| Scalar derivative by a given time period. -}
+derivT :: (Fractional a, Ord a) => a -> Signal a -> SignalGen a (Signal a)
+derivT wt s = do
+  sig <- transfer (0,(0,0)) d s
+  return (fst <$> sig)
+  where d dt v (x,(v0,t)) = if t' > wt then ((v-v0)/t',(v,0)) else (x,(v0,t'))
+          where t' = dt+t
+
+{-| Vector derivative by a given time period. -}
+derivTV :: (Vector2D v c, Ord c, Num c) => c -> Signal v -> SignalGen c (Signal v)
+derivTV wt s = do
+  sig <- transfer (vnull,(vnull,0)) d s
+  return (fst <$> sig)
+  where d dt v (x,(v0,t)) = if t' > wt then ((v^-^v0)^/.t',(v,0)) else (x,(v0,t'))
+          where t' = dt+t
+
+{-| Scalar moving average of a given number of recent samples. -}
+movingAvg :: (Eq a, Fractional a) => a -> Signal a -> SignalGen p (Signal a)
+movingAvg n s = do
+  sig <- scanM n (delay 0) s
+  return $ ((/n).sum) <$> sequence sig
+
+{-| Vector moving average of a given number of recent samples. -}
+movingAvgV :: (Eq c, Vector2D v c, Num c) => c -> Signal v -> SignalGen p (Signal v)
+movingAvgV n s = do
+  sig <- scanM n (delay vnull) s
+  return $ ((^/.n).foldl1' (^+^)) <$> sequence sig

src/Bounce/Util.hs view

@@ -1,73 +1,73 @@-module Util where--import Control.Applicative-import FRP.Elerea.Param---- Lifted conditional.-ifS c s1 s2 = c >>= \b -> if b then s1 else s2---- Override the first output of a signal.-initSignal x s = do-  c <- stateful True (const (const False))-  return $ ifS c (pure x) s--scanM 0 _ _ = return []-scanM n f m = do-  x <- f m-  xs <- scanM (n-1) f x-  return (x:xs)---- Functions moved over from the old Experimental top module--infix  4 ==@, /=@, <@, <=@, >=@, >@-infixr 3 &&@-infixr 2 ||@-infix  2 -->---- | The 'edge' transfer function takes a bool signal and emits--- another bool signal that turns true only at the moment when there--- is a rising edge on the input.-edge :: Signal Bool -> SignalGen p (Signal Bool)-edge b = delay True b >>= \db -> return $ (not <$> db) &&@ b---- | The '-->' transfer function behaves as a latch on a 'Maybe'--- input: it keeps its state when the input is 'Nothing', and replaces--- it with the input otherwise.-(-->) :: a                       -- ^ Initial output-      -> Signal (Maybe a)        -- ^ Maybe signal to latch on-      -> SignalGen p (Signal a)-x0 --> s = transfer x0 store s-    where store _ Nothing  x = x-          store _ (Just x) _ = x---- | Point-wise equality of two signals.-(==@) :: Eq a => Signal a -> Signal a -> Signal Bool-(==@) = liftA2 (==)---- | Point-wise inequality of two signals.-(/=@) :: Eq a => Signal a -> Signal a -> Signal Bool-(/=@) = liftA2 (/=)---- | Point-wise comparison of two signals.-(<@) :: Ord a => Signal a -> Signal a -> Signal Bool-(<@) = liftA2 (<)---- | Point-wise comparison of two signals.-(<=@) :: Ord a => Signal a -> Signal a -> Signal Bool-(<=@) = liftA2 (<=)---- | Point-wise comparison of two signals.-(>=@) :: Ord a => Signal a -> Signal a -> Signal Bool-(>=@) = liftA2 (>=)---- | Point-wise comparison of two signals.-(>@) :: Ord a => Signal a -> Signal a -> Signal Bool-(>@) = liftA2 (>)---- | Point-wise OR of two boolean signals.-(||@) :: Signal Bool -> Signal Bool -> Signal Bool-s1 ||@ s2 = s1 >>= \b -> if b then return True else s2---- | Point-wise AND of two boolean signals.-(&&@) :: Signal Bool -> Signal Bool -> Signal Bool-s1 &&@ s2 = s1 >>= \b -> if b then s2 else return False+module Util where
+
+import Control.Applicative
+import FRP.Elerea.Param
+
+-- Lifted conditional.
+ifS c s1 s2 = c >>= \b -> if b then s1 else s2
+
+-- Override the first output of a signal.
+initSignal x s = do
+  c <- stateful True (const (const False))
+  return $ ifS c (pure x) s
+
+scanM 0 _ _ = return []
+scanM n f m = do
+  x <- f m
+  xs <- scanM (n-1) f x
+  return (x:xs)
+
+-- Functions moved over from the old Experimental top module
+
+infix  4 ==@, /=@, <@, <=@, >=@, >@
+infixr 3 &&@
+infixr 2 ||@
+infix  2 -->
+
+-- | The 'edge' transfer function takes a bool signal and emits
+-- another bool signal that turns true only at the moment when there
+-- is a rising edge on the input.
+edge :: Signal Bool -> SignalGen p (Signal Bool)
+edge b = delay True b >>= \db -> return $ (not <$> db) &&@ b
+
+-- | The '-->' transfer function behaves as a latch on a 'Maybe'
+-- input: it keeps its state when the input is 'Nothing', and replaces
+-- it with the input otherwise.
+(-->) :: a                       -- ^ Initial output
+      -> Signal (Maybe a)        -- ^ Maybe signal to latch on
+      -> SignalGen p (Signal a)
+x0 --> s = transfer x0 store s
+    where store _ Nothing  x = x
+          store _ (Just x) _ = x
+
+-- | Point-wise equality of two signals.
+(==@) :: Eq a => Signal a -> Signal a -> Signal Bool
+(==@) = liftA2 (==)
+
+-- | Point-wise inequality of two signals.
+(/=@) :: Eq a => Signal a -> Signal a -> Signal Bool
+(/=@) = liftA2 (/=)
+
+-- | Point-wise comparison of two signals.
+(<@) :: Ord a => Signal a -> Signal a -> Signal Bool
+(<@) = liftA2 (<)
+
+-- | Point-wise comparison of two signals.
+(<=@) :: Ord a => Signal a -> Signal a -> Signal Bool
+(<=@) = liftA2 (<=)
+
+-- | Point-wise comparison of two signals.
+(>=@) :: Ord a => Signal a -> Signal a -> Signal Bool
+(>=@) = liftA2 (>=)
+
+-- | Point-wise comparison of two signals.
+(>@) :: Ord a => Signal a -> Signal a -> Signal Bool
+(>@) = liftA2 (>)
+
+-- | Point-wise OR of two boolean signals.
+(||@) :: Signal Bool -> Signal Bool -> Signal Bool
+s1 ||@ s2 = s1 >>= \b -> if b then return True else s2
+
+-- | Point-wise AND of two boolean signals.
+(&&@) :: Signal Bool -> Signal Bool -> Signal Bool
+s1 &&@ s2 = s1 >>= \b -> if b then s2 else return False

src/Bounce/Vector.hs view

@@ -1,53 +1,53 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, TypeSynonymInstances #-}--module Vector where--import Control.Applicative-import FRP.Elerea.Param-import Graphics.Rendering.OpenGL--data Vec = V { getX :: {-# UNPACK #-} !GLfloat, getY :: {-# UNPACK #-} !GLfloat }--infixl 7 ^*.-infixl 7 .*^-infixl 7 ^/.-infixl 7 `dot`-infixl 7 `cross`-infixl 6 ^+^-infixl 6 ^-^--class Vector2D v c | v -> c where-  (^+^) :: v -> v -> v-  (^-^) :: v -> v -> v-  (^*.) :: v -> c -> v-  (.*^) :: c -> v -> v-  (^/.) :: v -> c -> v-  vnull :: v-  dot :: v -> v -> c-  cross :: v -> v -> c-  vlen :: v -> c-  mul :: v -> v -> v--instance Vector2D Vec GLfloat where-  V x1 y1 ^+^ V x2 y2 = V (x1+x2) (y1+y2)-  V x1 y1 ^-^ V x2 y2 = V (x1-x2) (y1-y2)-  V x y ^*. t = V (x*t) (y*t)-  t .*^ V x y = V (x*t) (y*t)-  V x y ^/. t = V (x/t) (y/t)-  vnull = V 0 0-  V x1 y1 `dot` V x2 y2 = x1*x2+y1*y2-  V x1 y1 `cross` V x2 y2 = x1*y2-x2*y1-  vlen (V x y) = sqrt (x*x+y*y)-  V x1 y1 `mul` V x2 y2 = V (x1*x2) (y1*y2)--instance Vector2D (Signal Vec) (Signal GLfloat) where-  (^+^) = liftA2 (^+^)-  (^-^) = liftA2 (^-^)-  (^*.) = liftA2 (^*.)-  (.*^) = liftA2 (.*^)-  (^/.) = liftA2 (^/.)-  vnull = pure vnull-  dot = liftA2 dot-  cross = liftA2 cross-  vlen = fmap vlen-  mul = liftA2 mul+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, TypeSynonymInstances #-}
+
+module Vector where
+
+import Control.Applicative
+import FRP.Elerea.Param
+import Graphics.Rendering.OpenGL
+
+data Vec = V { getX :: {-# UNPACK #-} !GLfloat, getY :: {-# UNPACK #-} !GLfloat }
+
+infixl 7 ^*.
+infixl 7 .*^
+infixl 7 ^/.
+infixl 7 `dot`
+infixl 7 `cross`
+infixl 6 ^+^
+infixl 6 ^-^
+
+class Vector2D v c | v -> c where
+  (^+^) :: v -> v -> v
+  (^-^) :: v -> v -> v
+  (^*.) :: v -> c -> v
+  (.*^) :: c -> v -> v
+  (^/.) :: v -> c -> v
+  vnull :: v
+  dot :: v -> v -> c
+  cross :: v -> v -> c
+  vlen :: v -> c
+  mul :: v -> v -> v
+
+instance Vector2D Vec GLfloat where
+  V x1 y1 ^+^ V x2 y2 = V (x1+x2) (y1+y2)
+  V x1 y1 ^-^ V x2 y2 = V (x1-x2) (y1-y2)
+  V x y ^*. t = V (x*t) (y*t)
+  t .*^ V x y = V (x*t) (y*t)
+  V x y ^/. t = V (x/t) (y/t)
+  vnull = V 0 0
+  V x1 y1 `dot` V x2 y2 = x1*x2+y1*y2
+  V x1 y1 `cross` V x2 y2 = x1*y2-x2*y1
+  vlen (V x y) = sqrt (x*x+y*y)
+  V x1 y1 `mul` V x2 y2 = V (x1*x2) (y1*y2)
+
+instance Vector2D (Signal Vec) (Signal GLfloat) where
+  (^+^) = liftA2 (^+^)
+  (^-^) = liftA2 (^-^)
+  (^*.) = liftA2 (^*.)
+  (.*^) = liftA2 (.*^)
+  (^/.) = liftA2 (^/.)
+  vnull = pure vnull
+  dot = liftA2 dot
+  cross = liftA2 cross
+  vlen = fmap vlen
+  mul = liftA2 mul

src/Breakout.lhs view

@@ -1,361 +1,364 @@-Elerea Breakout example-=======================--Breakout is one of the simplest test applications that brings up some-problems with non-trivial solutions.  In particular, there is a-circular dependency between the position and the velocity of the ball.-The position is the integral of the velocity, while velocity can have-instantaneous changes due to collisions, which is a function of the-position of the ball and the current state of the field.  The field is-dynamic, and it also forms a mutual dependency loop with the ball-position.  On top of these, part of the field (at least if we regard-the paddle as part of it) depends on user input, and its effects start-propagating in the game state as soon as the ball reaches the level of-the paddle.--Elerea lets us express all these circular dependencies in a natural-way, by simply referring to the respective signals by their names.-User input is also seen as a signal from inside the reactive part,-while the imperative framework is given a sink fuction to update it as-needed.  Type safety is ensured all the way.--<img src="Breakout.png" alt="Elerea Breakout in action" />--Below follows the full source of the example.--> {-# LANGUAGE DoRec #-}->-> module Main where->-> import Control.Applicative-> import Control.Concurrent-> import Control.Monad-> import Data.IORef-> import Data.List-> import Data.Maybe-> import Data.Traversable hiding (mapM)-> import FRP.Elerea.Param-> import Graphics.UI.GLFW as GLFW-> import Graphics.Rendering.OpenGL-> import System.Environment-> import System.IO.Unsafe--> import Common.Utils-> import Common.Vector--Global constants-------------------The dimensions of the ball, which behaves as a rectangle in collision-detection, but is drawn as an ellipse.--> ballW = 0.04-> ballH = 0.04--The initial position and velocity of the ball.--> ballPos0 = V 0 (-0.4)-> ballVel0 = V (-0.4) (0.35)--The dimensions and vertical position of the player.--> playerW = 0.2-> playerH = 0.03-> playerY = -fieldH+0.01--The dimensions of the field.--> fieldW = 0.8-> fieldH = 0.5--The dimensions of each brick.--> brickW = 0.05-> brickH = 0.03--The data structure describing the state of each brick.  A brick can-either be alive or dying.  Dying bricks also keep track of their-fadeout level.--> data BrickState = Live | Dying !GLfloat deriving (Eq,Show)--The starting positions of the bricks.--> brickPos0 = distributeBricks (-0.7) (-0.1) (0.7) (0.4) 18 10->     where distributeBricks xmin ymin xmax ymax xn yn = [(xmin+xstep*x,ymin+ystep*y) |->                                                         x <- [0..xn-1], y <- [0..yn-1]]->               where xstep = (xmax-xmin-xn*brickW)/(xn-1)+brickW->                     ystep = (ymax-ymin-yn*brickH)/(yn-1)+brickH--The rate at which a brick fades out.  The reciprocal of this value-gives the fadeout time in seconds.--> brickFade = 0.5--Game logic-------------The entry point performs some lightweight initialisation, and defines-the two user-driven signals: window size and mouse position.  The-`external` function creates the signal and the corresponding sink at-the same time.--When all is done `driveNetwork` is invoked.  It is not a library-function, but part of the tiny `Utils` module .--> main = do->   -- Creating a window without a depth buffer->   initialize->   openWindow (Size 640 480) [DisplayRGBBits 8 8 8, DisplayAlphaBits 8] Window->   windowTitle $= "Elerea Breakout"->->   -- External signals available for the game logic->   (windowSize,windowSizeSink) <- external vnull->   (mousePosition,mousePositionSink) <- external vnull->->   -- Wrapping up the init phase->   closed <- newIORef False->   windowSizeCallback $= resizeGLScene windowSizeSink->   windowCloseCallback $= (writeIORef closed True >> return True)->   initGL 640 480->->   -- All we need to get going is an IO-valued signal and an IO->   -- function to update the external signals->   game <- start (breakout mousePosition windowSize)->   driveNetwork game (readInput mousePositionSink closed)->->   -- The inevitable sad ending->   closeWindow--The `breakout` function creates a reactive signal that carries the-rendering actions to be performed at each instant.  The principal-signals forming the game logic are the following:--* `playerX`: the position of the player, a direct function of the-   mouse position;-* `ballPos`: the position of the ball given as an integral of its-   velocity, `ballVel`;-* `bricks`: the collection of live and dying bricks along with-   collision information.--The position and velocity of the ball form a circular dependency-through the bricks, as velocity is changed whenever a collision is-detected, which is a function of the position.--The signal carrying the collection of the bricks is a higher-order-signal, where each element of the list is a signal representing an-individual brick.  Bricks behave independently of each other: they are-defined as separate transfer functions with the ball position as input-signal.  As soon as a brick is touched it enters the dying phase and-fades out.  Also, since other signals are mostly interested in the-current state of the bricks, we have to define a flattened version,-which carries the snapshots of all the brick signals.  This is the-`brickSamples` signal.--> breakout mousePos windowSize = do--User-driven player position:-->   rec let playerX = adjustPlayerPos <$> mousePos <*> windowSize->           adjustPlayerPos (V x _) (V w _) = min (fieldW-playerW) $ max (-fieldW) $ 2*x/w-1-playerW/2->           (||@) = liftA2 (||)->           toMaybe c v = if c then Just v else Nothing--Ball state: position and velocity.  We use a combination of-`storeJust` and `toMaybe` to produce a latcher element that stores the-value of a certain signal whenever a boolean control signal yields-true.  We need to create delayed versions in order to have-well-defined feedback loops.-->       ballPos <- integralVec ballPos0 ballVel->       ballVel <- storeJust ballVel0 $->                  toMaybe <$> (ballCollHorz ||@ ballCollVert ||@ ballCollPlayer) <*>->                              (adjustVel <$> ballCollHorz <*> ballCollVert <*> ballCollPlayer <*>->                               ballVel' <*> ballNewVelX)->->       ballPos' <- delay ballPos0 ballPos->       ballVel' <- delay ballVel0 ballVel--The `adjustVel` function calculates a candidate velocity for the next-frame given collision information and the current velocity.  Even-though it would return the current speed if there are no collisions,-we don't evaluate it at all thanks to the laziness of applicative-nodes.  In the end, velocity is only recalculated when a collision is-detected.-->       let adjustVel ch cv cp (V bvx bvy) bvx' = V x y->               where x = (if ch then -1 else 1)*(if cp then bvx'*4 else bvx)->                     y = if cv || cp then -bvy else bvy->           ballNewVelX = (getX <$> ballPos')-playerX-pure (playerW/2)--Collision events are modelled with bool signals that turn true while-the ball overlaps the offending surface and approaches it at the same-time.  Collision response will make sure that the second condition-does not hold in the next instant, so there is no need to push these-through an `edge` transfer function.-->           ballCollHorz = (any getBrickHColl <$> brickSamples')->                          ||@ (check <$> ballPos' <*> ballVel')->               where check (V bx _) (V bvx _) = (bx < -fieldW && bvx < 0) ||->                                                (bx > fieldW-ballW && bvx > 0)->           ballCollVert = (any getBrickVColl <$> brickSamples')->                          ||@ (check <$> ballPos' <*> ballVel')->               where check (V _ by) (V _ bvy) = by > fieldH-ballH && bvy > 0->           ballCollPlayer = check <$> ballPos' <*> ballVel' <*> playerX->               where check (V bx by) (V _ bvy) px = bvy < 0 &&->                        doRectsIntersect bx by ballW ballH px playerY playerW playerH--Bricks are defined by the updater function `evolveBrick` as a-transformer of the ball position.  The transfer function takes care of-fading and checking collision.  Collision information is part of the-state of the transfer function, even though it is strictly a function-of the brick data and the ball position at the moment.  However, since-we need to check collisions in order to update the state of the brick,-it's simpler and more efficient to let the outer world see the results-of these checks instead of having to recalculate them.-->       let brick (x,y) = transfer (x,y,Live,False,False) evolveBrick ballPos->           getBrickData (x,y,s,_,_) = (x,y,s)->           getBrickHColl (_,_,_,c,_) = c->           getBrickVColl (_,_,_,_,c) = c->->           evolveBrick dt _   (x,y,Dying a,_,_) = (x,y,Dying (a-realToFrac dt*brickFade),False,False)->           evolveBrick dt (V bx by) (x,y,_,_,_) = (x,y,if isKilled then Dying 1 else Live,collHorz,collVert)->               where isKilled = isHit || by < -fieldH-ballH->                     isHit = doRectsIntersect bx by ballW ballH x y brickW brickH->                     collHorz = isHit && isHorz->                     collVert = isHit && not isHorz->                     isHorz = xDist/brickW > yDist/brickH->                         where xDist = abs ((x+brickW/2)-(bx+ballW/2))->                               yDist = abs ((y+brickH/2)-(by+ballH/2))--The `isBrickNeeded` function is used to decide whether a brick should-be kept in the collection.  As soon as it turns false, the brick in-question is removed from the `bricks` signal.-->           isBrickNeeded (_,_,Dying a,_,_) = a > 0->           isBrickNeeded (_,_,Live   ,_,_) = True--The `brickSamples` signal contains a snapshot of every brick, and it's-obtained simply by traversing the collection (this is equivalent to-rebuilding the structure with lifted constructors), then applying a-sampler, which collapses the two signal layers into one.  We take-advantage of the fact that lists are instances of Traversable.-->           brickSamples = join (sequenceA <$> bricks)->->       brickSamples' <- delay [] brickSamples--The `bricks` signal carries the dynamic list of bricks along with-ball-brick collision information, all of which are updated in each-frame.  We start out with a number of live bricks in the positions-given by the `brickPos0` list, and derive the list of the next frame-from the current one by filtering out the bricks for which-`isBrickNeeded` evaluates to false.  These updates are made explicit-by using `delay` to define the dynamic collection.-->       bricks <- do->         bricksInit <- mapM brick brickPos0->         let bricksNext = map snd . filter (isBrickNeeded . fst) <$> (zip <$> brickSamples <*> bricks)->         delay bricksInit bricksNext--And knowing all these signals we can finally assemble the signal of-rendering actions, i.e. the animation:-->   return $ renderLevel <$> playerX <*> ballPos <*> (map getBrickData <$> brickSamples)--The `doRectsIntersect` function decides whether two rectangles defined-by their top left corners and dimensions overlap.--> doRectsIntersect x1 y1 sx1 sy1 x2 y2 sx2 sy2 = collIV x1 sx1 x2 sx2 && collIV y1 sy1 y2 sy2->     where collIV p1 s1 p2 s2 = (p1 <= p2 && p2 <= p1+s1) || (p2 <= p1 && p1 <= p2+s2)--The `renderLevel` function takes a snapshot of the game and turns it-into an IO action that displays this snapshot on the screen.  The-`breakout` signal is the time-varying version of this IO action.--> renderLevel playerX (V ballX ballY) bricks = do->   let drawRect x y xs ys = do->         loadIdentity->         renderPrimitive Quads $ do->           vertex $ Vertex3 (x)    (y)    (0 :: GLfloat)->           vertex $ Vertex3 (x+xs) (y)    (0 :: GLfloat)->           vertex $ Vertex3 (x+xs) (y+ys) (0 :: GLfloat)->           vertex $ Vertex3 (x)    (y+ys) (0 :: GLfloat)->       drawEllipse x y xs ys n = do->         let xc = x+xs/2->             yc = y+ys/2->         loadIdentity->         renderPrimitive TriangleStrip $ forM_ [0..n] $ \i -> do->           let a = 2*pi*fromIntegral i/fromIntegral n->           vertex $ Vertex3 (xc+xs/2*sin a) (yc+ys/2*cos a) (0 :: GLfloat)->           vertex $ Vertex3 xc yc (0 :: GLfloat)->->   clear [ColorBuffer]->->   color $ Color4 0.2 0.2 0.2 (1 :: GLfloat)->   drawRect (-fieldW) (-fieldH) (fieldW*2) (fieldH*2)->->   forM_ bricks $ \(x,y,s) -> do->     case s of->       Live    -> color $ Color4 0.8 0.5 0.5 (0.6 :: GLfloat)->       Dying a -> color $ Color4 0.9 0.9 0.2 a->     drawRect x y brickW brickH->->   color $ Color4 1 1 1 (0.6 :: GLfloat)->   drawEllipse ballX ballY ballW ballH 20->->   color $ Color4 0.3 0.4 0.8 (0.5 :: GLfloat)->   drawRect playerX playerY playerW playerH->->   flush->   swapBuffers--Backend----------The `readInput` function has two responsibilities: it provides input-for the `mousePosition` peripheral signal through its associated sink,-and also feeds the time difference between two states into the system,-deciding when to exit altogether (by returning `Nothing` instead of-the current `dt` value wrapped in `Just`).--The `threadDelay` call at the beginning is just a trick to give the-scheduler a breath.  It will cause a wait equal to a scheduler tick,-which is 20ms by default.  The program can run perfectly without it,-but it eats up all the free CPU to produce an unnecessarily high frame-rate.--> readInput mousePos closed = do->   threadDelay 0->   t <- get GLFW.time->   GLFW.time $= 0->   Position x y <- get GLFW.mousePos->   mousePos (V (fromIntegral x) (fromIntegral y))->   k <- getKey ESC->   c <- readIORef closed->   return (if c || k == Press then Nothing else Just t)--The `initGL` function sets up almost nothing, which means that most-functionality is turned off.  Only alpha blending is enabled to-provide some minimalistic eye candy.--> initGL width height = do->   clearColor $= Color4 0 0 0 1->   blend $= Enabled->   blendFunc $= (SrcAlpha,OneMinusSrcAlpha)->   cullFace $= Just Back--The resize callback feeds the `windowSize` signal through its sink-besides adjusting the projection matrix.--> resizeGLScene winSize size@(Size w h) = do->   winSize (V (fromIntegral w) (fromIntegral h))->->   viewport $= (Position 0 0,size)->->   matrixMode $= Projection->   loadIdentity->   scale 1 (fromIntegral w/fromIntegral h) (1 :: GLfloat)->->   matrixMode $= Modelview 0+Elerea Breakout example
+=======================
+
+Breakout is one of the simplest test applications that brings up some
+problems with non-trivial solutions.  In particular, there is a
+circular dependency between the position and the velocity of the ball.
+The position is the integral of the velocity, while velocity can have
+instantaneous changes due to collisions, which is a function of the
+position of the ball and the current state of the field.  The field is
+dynamic, and it also forms a mutual dependency loop with the ball
+position.  On top of these, part of the field (at least if we regard
+the paddle as part of it) depends on user input, and its effects start
+propagating in the game state as soon as the ball reaches the level of
+the paddle.
+
+Elerea lets us express all these circular dependencies in a natural
+way, by simply referring to the respective signals by their names.
+User input is also seen as a signal from inside the reactive part,
+while the imperative framework is given a sink fuction to update it as
+needed.  Type safety is ensured all the way.
+
+<img src="Breakout.png" alt="Elerea Breakout in action" />
+
+Below follows the full source of the example.
+
+> {-# LANGUAGE DoRec #-}
+>
+> module Main where
+>
+> import Control.Applicative
+> import Control.Concurrent
+> import Control.Monad
+> import Data.IORef
+> import Data.List
+> import Data.Maybe
+> import Data.Traversable hiding (mapM)
+> import FRP.Elerea.Param
+> import Graphics.UI.GLFW as GLFW
+> import Graphics.Rendering.OpenGL
+> import System.Environment
+> import System.IO.Unsafe
+
+> import Common.Utils
+> import Common.Vector
+
+Global constants
+----------------
+
+The dimensions of the ball, which behaves as a rectangle in collision
+detection, but is drawn as an ellipse.
+
+> ballW = 0.04
+> ballH = 0.04
+
+The initial position and velocity of the ball.
+
+> ballPos0 = V 0 (-0.4)
+> ballVel0 = V (-0.4) (0.35)
+
+The dimensions and vertical position of the player.
+
+> playerW = 0.2
+> playerH = 0.03
+> playerY = -fieldH+0.01
+
+The dimensions of the field.
+
+> fieldW = 0.8
+> fieldH = 0.5
+
+The dimensions of each brick.
+
+> brickW = 0.05
+> brickH = 0.03
+
+The data structure describing the state of each brick.  A brick can
+either be alive or dying.  Dying bricks also keep track of their
+fadeout level.
+
+> data BrickState = Live | Dying !GLfloat deriving (Eq,Show)
+
+The starting positions of the bricks.
+
+> brickPos0 = distributeBricks (-0.7) (-0.1) (0.7) (0.4) 18 10
+>     where distributeBricks xmin ymin xmax ymax xn yn = [(xmin+xstep*x,ymin+ystep*y) |
+>                                                         x <- [0..xn-1], y <- [0..yn-1]]
+>               where xstep = (xmax-xmin-xn*brickW)/(xn-1)+brickW
+>                     ystep = (ymax-ymin-yn*brickH)/(yn-1)+brickH
+
+The rate at which a brick fades out.  The reciprocal of this value
+gives the fadeout time in seconds.
+
+> brickFade = 0.5
+
+Game logic
+----------
+
+The entry point performs some lightweight initialisation, and defines
+the two user-driven signals: window size and mouse position.  The
+`external` function creates the signal and the corresponding sink at
+the same time.
+
+When all is done `driveNetwork` is invoked.  It is not a library
+function, but part of the tiny `Utils` module .
+
+> main = do
+>   -- Creating a window without a depth buffer
+>   initialize
+>   openWindow (Size 640 480) [DisplayRGBBits 8 8 8, DisplayAlphaBits 8] Window
+>   windowTitle $= "Elerea Breakout"
+>
+>   -- External signals available for the game logic
+>   (windowSizeGen,windowSizeSink) <- external vnull
+>   (mousePositionGen,mousePositionSink) <- external vnull
+>
+>   -- Wrapping up the init phase
+>   closed <- newIORef False
+>   windowSizeCallback $= resizeGLScene windowSizeSink
+>   windowCloseCallback $= (writeIORef closed True >> return True)
+>   initGL 640 480
+>
+>   -- All we need to get going is an IO-valued signal and an IO
+>   -- function to update the external signals
+>   game <- start $ do
+>     mousePosition <- mousePositionGen
+>     windowSize <- windowSizeGen
+>     breakout mousePosition windowSize
+>   driveNetwork game (readInput mousePositionSink closed)
+>
+>   -- The inevitable sad ending
+>   closeWindow
+
+The `breakout` function creates a reactive signal that carries the
+rendering actions to be performed at each instant.  The principal
+signals forming the game logic are the following:
+
+* `playerX`: the position of the player, a direct function of the
+   mouse position;
+* `ballPos`: the position of the ball given as an integral of its
+   velocity, `ballVel`;
+* `bricks`: the collection of live and dying bricks along with
+   collision information.
+
+The position and velocity of the ball form a circular dependency
+through the bricks, as velocity is changed whenever a collision is
+detected, which is a function of the position.
+
+The signal carrying the collection of the bricks is a higher-order
+signal, where each element of the list is a signal representing an
+individual brick.  Bricks behave independently of each other: they are
+defined as separate transfer functions with the ball position as input
+signal.  As soon as a brick is touched it enters the dying phase and
+fades out.  Also, since other signals are mostly interested in the
+current state of the bricks, we have to define a flattened version,
+which carries the snapshots of all the brick signals.  This is the
+`brickSamples` signal.
+
+> breakout mousePos windowSize = do
+
+User-driven player position:
+
+>   rec let playerX = adjustPlayerPos <$> mousePos <*> windowSize
+>           adjustPlayerPos (V x _) (V w _) = min (fieldW-playerW) $ max (-fieldW) $ 2*x/w-1-playerW/2
+>           (||@) = liftA2 (||)
+>           toMaybe c v = if c then Just v else Nothing
+
+Ball state: position and velocity.  We use a combination of
+`storeJust` and `toMaybe` to produce a latcher element that stores the
+value of a certain signal whenever a boolean control signal yields
+true.  We need to create delayed versions in order to have
+well-defined feedback loops.
+
+>       ballPos <- integralVec ballPos0 ballVel
+>       ballVel <- storeJust ballVel0 $
+>                  toMaybe <$> (ballCollHorz ||@ ballCollVert ||@ ballCollPlayer) <*>
+>                              (adjustVel <$> ballCollHorz <*> ballCollVert <*> ballCollPlayer <*>
+>                               ballVel' <*> ballNewVelX)
+>
+>       ballPos' <- delay ballPos0 ballPos
+>       ballVel' <- delay ballVel0 ballVel
+
+The `adjustVel` function calculates a candidate velocity for the next
+frame given collision information and the current velocity.  Even
+though it would return the current speed if there are no collisions,
+we don't evaluate it at all thanks to the laziness of applicative
+nodes.  In the end, velocity is only recalculated when a collision is
+detected.
+
+>       let adjustVel ch cv cp (V bvx bvy) bvx' = V x y
+>               where x = (if ch then -1 else 1)*(if cp then bvx'*4 else bvx)
+>                     y = if cv || cp then -bvy else bvy
+>           ballNewVelX = (getX <$> ballPos')-playerX-pure (playerW/2)
+
+Collision events are modelled with bool signals that turn true while
+the ball overlaps the offending surface and approaches it at the same
+time.  Collision response will make sure that the second condition
+does not hold in the next instant, so there is no need to push these
+through an `edge` transfer function.
+
+>           ballCollHorz = (any getBrickHColl <$> brickSamples')
+>                          ||@ (check <$> ballPos' <*> ballVel')
+>               where check (V bx _) (V bvx _) = (bx < -fieldW && bvx < 0) ||
+>                                                (bx > fieldW-ballW && bvx > 0)
+>           ballCollVert = (any getBrickVColl <$> brickSamples')
+>                          ||@ (check <$> ballPos' <*> ballVel')
+>               where check (V _ by) (V _ bvy) = by > fieldH-ballH && bvy > 0
+>           ballCollPlayer = check <$> ballPos' <*> ballVel' <*> playerX
+>               where check (V bx by) (V _ bvy) px = bvy < 0 &&
+>                        doRectsIntersect bx by ballW ballH px playerY playerW playerH
+
+Bricks are defined by the updater function `evolveBrick` as a
+transformer of the ball position.  The transfer function takes care of
+fading and checking collision.  Collision information is part of the
+state of the transfer function, even though it is strictly a function
+of the brick data and the ball position at the moment.  However, since
+we need to check collisions in order to update the state of the brick,
+it's simpler and more efficient to let the outer world see the results
+of these checks instead of having to recalculate them.
+
+>       let brick (x,y) = transfer (x,y,Live,False,False) evolveBrick ballPos
+>           getBrickData (x,y,s,_,_) = (x,y,s)
+>           getBrickHColl (_,_,_,c,_) = c
+>           getBrickVColl (_,_,_,_,c) = c
+>
+>           evolveBrick dt _   (x,y,Dying a,_,_) = (x,y,Dying (a-realToFrac dt*brickFade),False,False)
+>           evolveBrick dt (V bx by) (x,y,_,_,_) = (x,y,if isKilled then Dying 1 else Live,collHorz,collVert)
+>               where isKilled = isHit || by < -fieldH-ballH
+>                     isHit = doRectsIntersect bx by ballW ballH x y brickW brickH
+>                     collHorz = isHit && isHorz
+>                     collVert = isHit && not isHorz
+>                     isHorz = xDist/brickW > yDist/brickH
+>                         where xDist = abs ((x+brickW/2)-(bx+ballW/2))
+>                               yDist = abs ((y+brickH/2)-(by+ballH/2))
+
+The `isBrickNeeded` function is used to decide whether a brick should
+be kept in the collection.  As soon as it turns false, the brick in
+question is removed from the `bricks` signal.
+
+>           isBrickNeeded (_,_,Dying a,_,_) = a > 0
+>           isBrickNeeded (_,_,Live   ,_,_) = True
+
+The `brickSamples` signal contains a snapshot of every brick, and it's
+obtained simply by traversing the collection (this is equivalent to
+rebuilding the structure with lifted constructors), then applying a
+sampler, which collapses the two signal layers into one.  We take
+advantage of the fact that lists are instances of Traversable.
+
+>           brickSamples = join (sequenceA <$> bricks)
+>
+>       brickSamples' <- delay [] brickSamples
+
+The `bricks` signal carries the dynamic list of bricks along with
+ball-brick collision information, all of which are updated in each
+frame.  We start out with a number of live bricks in the positions
+given by the `brickPos0` list, and derive the list of the next frame
+from the current one by filtering out the bricks for which
+`isBrickNeeded` evaluates to false.  These updates are made explicit
+by using `delay` to define the dynamic collection.
+
+>       bricks <- do
+>         bricksInit <- mapM brick brickPos0
+>         let bricksNext = map snd . filter (isBrickNeeded . fst) <$> (zip <$> brickSamples <*> bricks)
+>         delay bricksInit bricksNext
+
+And knowing all these signals we can finally assemble the signal of
+rendering actions, i.e. the animation:
+
+>   return $ renderLevel <$> playerX <*> ballPos <*> (map getBrickData <$> brickSamples)
+
+The `doRectsIntersect` function decides whether two rectangles defined
+by their top left corners and dimensions overlap.
+
+> doRectsIntersect x1 y1 sx1 sy1 x2 y2 sx2 sy2 = collIV x1 sx1 x2 sx2 && collIV y1 sy1 y2 sy2
+>     where collIV p1 s1 p2 s2 = (p1 <= p2 && p2 <= p1+s1) || (p2 <= p1 && p1 <= p2+s2)
+
+The `renderLevel` function takes a snapshot of the game and turns it
+into an IO action that displays this snapshot on the screen.  The
+`breakout` signal is the time-varying version of this IO action.
+
+> renderLevel playerX (V ballX ballY) bricks = do
+>   let drawRect x y xs ys = do
+>         loadIdentity
+>         renderPrimitive Quads $ do
+>           vertex $ Vertex3 (x)    (y)    (0 :: GLfloat)
+>           vertex $ Vertex3 (x+xs) (y)    (0 :: GLfloat)
+>           vertex $ Vertex3 (x+xs) (y+ys) (0 :: GLfloat)
+>           vertex $ Vertex3 (x)    (y+ys) (0 :: GLfloat)
+>       drawEllipse x y xs ys n = do
+>         let xc = x+xs/2
+>             yc = y+ys/2
+>         loadIdentity
+>         renderPrimitive TriangleStrip $ forM_ [0..n] $ \i -> do
+>           let a = 2*pi*fromIntegral i/fromIntegral n
+>           vertex $ Vertex3 (xc+xs/2*sin a) (yc+ys/2*cos a) (0 :: GLfloat)
+>           vertex $ Vertex3 xc yc (0 :: GLfloat)
+>
+>   clear [ColorBuffer]
+>
+>   color $ Color4 0.2 0.2 0.2 (1 :: GLfloat)
+>   drawRect (-fieldW) (-fieldH) (fieldW*2) (fieldH*2)
+>
+>   forM_ bricks $ \(x,y,s) -> do
+>     case s of
+>       Live    -> color $ Color4 0.8 0.5 0.5 (0.6 :: GLfloat)
+>       Dying a -> color $ Color4 0.9 0.9 0.2 a
+>     drawRect x y brickW brickH
+>
+>   color $ Color4 1 1 1 (0.6 :: GLfloat)
+>   drawEllipse ballX ballY ballW ballH 20
+>
+>   color $ Color4 0.3 0.4 0.8 (0.5 :: GLfloat)
+>   drawRect playerX playerY playerW playerH
+>
+>   flush
+>   swapBuffers
+
+Backend
+-------
+
+The `readInput` function has two responsibilities: it provides input
+for the `mousePosition` peripheral signal through its associated sink,
+and also feeds the time difference between two states into the system,
+deciding when to exit altogether (by returning `Nothing` instead of
+the current `dt` value wrapped in `Just`).
+
+The `threadDelay` call at the beginning is just a trick to give the
+scheduler a breath.  It will cause a wait equal to a scheduler tick,
+which is 20ms by default.  The program can run perfectly without it,
+but it eats up all the free CPU to produce an unnecessarily high frame
+rate.
+
+> readInput mousePos closed = do
+>   threadDelay 0
+>   t <- get GLFW.time
+>   GLFW.time $= 0
+>   Position x y <- get GLFW.mousePos
+>   mousePos (V (fromIntegral x) (fromIntegral y))
+>   k <- getKey ESC
+>   c <- readIORef closed
+>   return (if c || k == Press then Nothing else Just t)
+
+The `initGL` function sets up almost nothing, which means that most
+functionality is turned off.  Only alpha blending is enabled to
+provide some minimalistic eye candy.
+
+> initGL width height = do
+>   clearColor $= Color4 0 0 0 1
+>   blend $= Enabled
+>   blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
+>   cullFace $= Just Back
+
+The resize callback feeds the `windowSize` signal through its sink
+besides adjusting the projection matrix.
+
+> resizeGLScene winSize size@(Size w h) = do
+>   winSize (V (fromIntegral w) (fromIntegral h))
+>
+>   viewport $= (Position 0 0,size)
+>
+>   matrixMode $= Projection
+>   loadIdentity
+>   scale 1 (fromIntegral w/fromIntegral h) (1 :: GLfloat)
+>
+>   matrixMode $= Modelview 0

src/Chase.lhs view

@@ -1,121 +1,124 @@-Elerea Chase example-====================--This is a minimal example to show how to define signals that can be-mutually recursive and can optionally depend on user input too.  The-grey square accelerates towards the red square at a rate proportional-to their relative position, and it can be given a momentary impulse-with the left mouse button.--For a slightly more complex example check out `Breakout.lhs`.--> {-# LANGUAGE DoRec #-}->-> module Main where->-> import Control.Applicative-> import Control.Monad-> import Data.IORef-> import FRP.Elerea.Param-> import Graphics.UI.GLFW as GLFW-> import Graphics.Rendering.OpenGL->-> import Common.Utils-> import Common.Vector--The `main` function contains the whole reactive logic.  Note that-`driveNetwork` is just a simple loop, and you can see its source below-in the `Utils` module.--> main = do->     initialize->     openWindow (Size 640 480) [DisplayRGBBits 8 8 8, DisplayAlphaBits 8, DisplayDepthBits 24] Window->     windowTitle $= "Elerea Chase"->->     (windowSize,windowSizeSink) <- external vnull->     (mousePosition,mousePositionSink) <- external vnull->     (mousePress,mousePressSink) <- external False->->     closed <- newIORef False->     windowSizeCallback $= resizeGLScene windowSizeSink->     windowCloseCallback $= (writeIORef closed True >> return True)->     initGL 640 480->->     network <- start $ do->         mouseClick <- edge mousePress->         rec let newVel clk v0 = case clk of->                     True -> Just <$> integralVec v0 acc->                     False -> return Nothing->                 acc = (mousePosition^-^pos)^*.0.3->             vel0 <- integralVec vnull acc->             vels <- storeJust vel0 =<< generator (newVel <$> mouseClick <*> vel^+^pos^-^mousePosition)->             vel <- delay vnull (join vels)->             pos <- delay vnull =<< integralVec vnull vel->->         return $ render <$> windowSize <*> mousePosition <*> pos->->     driveNetwork network (readInput mousePositionSink mousePressSink closed)->->     closeWindow--The `render` function takes a snapshot of the system (window size and-the positions of the squares) and turns it into OpenGL calls.  The-signal executed by the `driveNetwork` function is the time-varying-version of the IO action returned here.--> render (V w h) (V cx cy) (V ox oy) = do->   let drawSquare x y s = do->         loadIdentity->         translate $ Vector3 (x/w*2-1) (h/w-y/w*2) 0->         renderPrimitive Quads $ do->           vertex $ Vertex3 (-s) (-s) (0 :: GLfloat)->           vertex $ Vertex3 ( s) (-s) (0 :: GLfloat)->           vertex $ Vertex3 ( s) ( s) (0 :: GLfloat)->           vertex $ Vertex3 (-s) ( s) (0 :: GLfloat)->->   clear [ColorBuffer]->->   color $ Color4 1 0 0 (0.5 :: GLfloat)->   drawSquare cx cy 0.05->   color $ Color4 1 1 1 (0.6 :: GLfloat)->   drawSquare ox oy 0.03->->   flush->   swapBuffers--The `readInput` function provides the driver layer.  It feeds the-peripheral-bound signals and also decides when to stop execution by-returning `Nothing` instead of the time elapsed since its last call.--> readInput mousePos mouseBut closed = do->   t <- get GLFW.time->   GLFW.time $= 0->   Position x y <- get GLFW.mousePos->   mousePos (V (fromIntegral x) (fromIntegral y))->   b <- GLFW.getMouseButton GLFW.ButtonLeft->   mouseBut (b == GLFW.Press)->   k <- getKey ESC->   c <- readIORef closed->   return (if c || k == Press then Nothing else Just t)--OpenGL is initialised with practically everything turned off.  Only-alpha blending is needed to be able to use translucent colours.--> initGL width height = do->   clearColor $= Color4 0 0 0 1->   blend $= Enabled->   blendFunc $= (SrcAlpha,OneMinusSrcAlpha)--The window size callback takes care of the `windowSize` signal and the-projection matrix.--> resizeGLScene winSize size@(Size w h) = do->   winSize (V (fromIntegral w) (fromIntegral h))->->   viewport $= (Position 0 0,size)->->   matrixMode $= Projection->   loadIdentity->   scale 1 (fromIntegral w/fromIntegral h) (1 :: GLfloat)->->   matrixMode $= Modelview 0+Elerea Chase example
+====================
+
+This is a minimal example to show how to define signals that can be
+mutually recursive and can optionally depend on user input too.  The
+grey square accelerates towards the red square at a rate proportional
+to their relative position, and it can be given a momentary impulse
+with the left mouse button.
+
+For a slightly more complex example check out `Breakout.lhs`.
+
+> {-# LANGUAGE DoRec #-}
+>
+> module Main where
+>
+> import Control.Applicative
+> import Control.Monad
+> import Data.IORef
+> import FRP.Elerea.Param
+> import Graphics.UI.GLFW as GLFW
+> import Graphics.Rendering.OpenGL
+>
+> import Common.Utils
+> import Common.Vector
+
+The `main` function contains the whole reactive logic.  Note that
+`driveNetwork` is just a simple loop, and you can see its source below
+in the `Utils` module.
+
+> main = do
+>     initialize
+>     openWindow (Size 640 480) [DisplayRGBBits 8 8 8, DisplayAlphaBits 8, DisplayDepthBits 24] Window
+>     windowTitle $= "Elerea Chase"
+>
+>     (windowSizeGen,windowSizeSink) <- external vnull
+>     (mousePositionGen,mousePositionSink) <- external vnull
+>     (mousePressGen,mousePressSink) <- external False
+>
+>     closed <- newIORef False
+>     windowSizeCallback $= resizeGLScene windowSizeSink
+>     windowCloseCallback $= (writeIORef closed True >> return True)
+>     initGL 640 480
+>
+>     network <- start $ do
+>         mousePress <- mousePressGen
+>         mousePosition <- mousePositionGen
+>         windowSize <- windowSizeGen
+>         mouseClick <- edge mousePress
+>         rec let newVel clk v0 = case clk of
+>                     True -> Just <$> integralVec v0 acc
+>                     False -> return Nothing
+>                 acc = (mousePosition^-^pos)^*.0.3
+>             vel0 <- integralVec vnull acc
+>             vels <- storeJust vel0 =<< generator (newVel <$> mouseClick <*> vel^+^pos^-^mousePosition)
+>             vel <- delay vnull (join vels)
+>             pos <- delay vnull =<< integralVec vnull vel
+>
+>         return $ render <$> windowSize <*> mousePosition <*> pos
+>
+>     driveNetwork network (readInput mousePositionSink mousePressSink closed)
+>
+>     closeWindow
+
+The `render` function takes a snapshot of the system (window size and
+the positions of the squares) and turns it into OpenGL calls.  The
+signal executed by the `driveNetwork` function is the time-varying
+version of the IO action returned here.
+
+> render (V w h) (V cx cy) (V ox oy) = do
+>   let drawSquare x y s = do
+>         loadIdentity
+>         translate $ Vector3 (x/w*2-1) (h/w-y/w*2) 0
+>         renderPrimitive Quads $ do
+>           vertex $ Vertex3 (-s) (-s) (0 :: GLfloat)
+>           vertex $ Vertex3 ( s) (-s) (0 :: GLfloat)
+>           vertex $ Vertex3 ( s) ( s) (0 :: GLfloat)
+>           vertex $ Vertex3 (-s) ( s) (0 :: GLfloat)
+>
+>   clear [ColorBuffer]
+>
+>   color $ Color4 1 0 0 (0.5 :: GLfloat)
+>   drawSquare cx cy 0.05
+>   color $ Color4 1 1 1 (0.6 :: GLfloat)
+>   drawSquare ox oy 0.03
+>
+>   flush
+>   swapBuffers
+
+The `readInput` function provides the driver layer.  It feeds the
+peripheral-bound signals and also decides when to stop execution by
+returning `Nothing` instead of the time elapsed since its last call.
+
+> readInput mousePos mouseBut closed = do
+>   t <- get GLFW.time
+>   GLFW.time $= 0
+>   Position x y <- get GLFW.mousePos
+>   mousePos (V (fromIntegral x) (fromIntegral y))
+>   b <- GLFW.getMouseButton GLFW.ButtonLeft
+>   mouseBut (b == GLFW.Press)
+>   k <- getKey ESC
+>   c <- readIORef closed
+>   return (if c || k == Press then Nothing else Just t)
+
+OpenGL is initialised with practically everything turned off.  Only
+alpha blending is needed to be able to use translucent colours.
+
+> initGL width height = do
+>   clearColor $= Color4 0 0 0 1
+>   blend $= Enabled
+>   blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
+
+The window size callback takes care of the `windowSize` signal and the
+projection matrix.
+
+> resizeGLScene winSize size@(Size w h) = do
+>   winSize (V (fromIntegral w) (fromIntegral h))
+>
+>   viewport $= (Position 0 0,size)
+>
+>   matrixMode $= Projection
+>   loadIdentity
+>   scale 1 (fromIntegral w/fromIntegral h) (1 :: GLfloat)
+>
+>   matrixMode $= Modelview 0

src/Common/Utils.lhs view

@@ -1,44 +1,44 @@-Utils module-============--This module contains some functions that might make it into the core library eventually.--> module Common.Utils where->-> import Control.Applicative-> import Control.Monad-> import FRP.Elerea.Param->-> import Common.Vector--The `driveNetwork` function simply executes the supersteps while the-`driver` function keeps returning valid delta time values.--> driveNetwork network driver = do->   dt <- driver->   case dt of->     Just dt -> do join (network dt)->                   driveNetwork network driver->     Nothing -> return ()--A scalar integral function for `Fractional` instances.--> integral v0 s = transfer v0 (\dt v v0 -> v0+v*realToFrac dt) s--An integral function for two-dimensional vectors defined in the-`Vector` module.--> integralVec v0 s = transfer v0 (\dt v v0 -> v0^+^(v^*.realToFrac dt)) s--A rising edge detector.--> edge s = do->   s' <- delay False s->   return $ s' >>= \x -> if x then return False else s--A latch that always remembers the last value of a `Maybe` signal-wrapped in `Just`.--> storeJust x0 s = transfer x0 store s->     where store _ Nothing  x = x->           store _ (Just x) _ = x+Utils module
+============
+
+This module contains some functions that might make it into the core library eventually.
+
+> module Common.Utils where
+>
+> import Control.Applicative
+> import Control.Monad
+> import FRP.Elerea.Param
+>
+> import Common.Vector
+
+The `driveNetwork` function simply executes the supersteps while the
+`driver` function keeps returning valid delta time values.
+
+> driveNetwork network driver = do
+>   dt <- driver
+>   case dt of
+>     Just dt -> do join (network dt)
+>                   driveNetwork network driver
+>     Nothing -> return ()
+
+A scalar integral function for `Fractional` instances.
+
+> integral v0 s = transfer v0 (\dt v v0 -> v0+v*realToFrac dt) s
+
+An integral function for two-dimensional vectors defined in the
+`Vector` module.
+
+> integralVec v0 s = transfer v0 (\dt v v0 -> v0^+^(v^*.realToFrac dt)) s
+
+A rising edge detector.
+
+> edge s = do
+>   s' <- delay False s
+>   return $ s' >>= \x -> if x then return False else s
+
+A latch that always remembers the last value of a `Maybe` signal
+wrapped in `Just`.
+
+> storeJust x0 s = transfer x0 store s
+>     where store _ Nothing  x = x
+>           store _ (Just x) _ = x

src/Common/Vector.lhs view

@@ -1,50 +1,50 @@-Vector module-=============--This module contains a class for two-dimensional vectors, a strict-datatype to instantiate it, and another instance for signals of the-same type.--> {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, TypeSynonymInstances #-}->-> module Common.Vector where->-> import Control.Applicative-> import FRP.Elerea.Param-> import Graphics.Rendering.OpenGL->-> data Vec = V { getX :: !GLfloat, getY :: !GLfloat }->-> infixl 7 ^*.-> infixl 7 .*^-> infixl 7 `dot`-> infixl 7 `cross`-> infixl 6 ^+^-> infixl 6 ^-^->-> class Vector2D v c | v -> c where->     (^+^) :: v -> v -> v->     (^-^) :: v -> v -> v->     (^*.) :: v -> c -> v->     (.*^) :: c -> v -> v->     vnull :: v->     dot :: v -> v -> c->     cross :: v -> v -> c->-> instance Vector2D Vec GLfloat where->     V x1 y1 ^+^ V x2 y2 = V (x1+x2) (y1+y2)->     V x1 y1 ^-^ V x2 y2 = V (x1-x2) (y1-y2)->     V x y ^*. t = V (x*t) (y*t)->     t .*^ V x y = V (x*t) (y*t)->     vnull = V 0 0->     V x1 y1 `dot` V x2 y2 = x1*y1+x2*y2->     V x1 y1 `cross` V x2 y2 = x1*y2-x2*y1->-> instance Vector2D (Signal Vec) (Signal GLfloat) where->     (^+^) = liftA2 (^+^)->     (^-^) = liftA2 (^-^)->     (^*.) = liftA2 (^*.)->     (.*^) = liftA2 (.*^)->     vnull = pure vnull->     dot = liftA2 dot->     cross = liftA2 cross+Vector module
+=============
+
+This module contains a class for two-dimensional vectors, a strict
+datatype to instantiate it, and another instance for signals of the
+same type.
+
+> {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, TypeSynonymInstances #-}
+>
+> module Common.Vector where
+>
+> import Control.Applicative
+> import FRP.Elerea.Param
+> import Graphics.Rendering.OpenGL
+>
+> data Vec = V { getX :: !GLfloat, getY :: !GLfloat }
+>
+> infixl 7 ^*.
+> infixl 7 .*^
+> infixl 7 `dot`
+> infixl 7 `cross`
+> infixl 6 ^+^
+> infixl 6 ^-^
+>
+> class Vector2D v c | v -> c where
+>     (^+^) :: v -> v -> v
+>     (^-^) :: v -> v -> v
+>     (^*.) :: v -> c -> v
+>     (.*^) :: c -> v -> v
+>     vnull :: v
+>     dot :: v -> v -> c
+>     cross :: v -> v -> c
+>
+> instance Vector2D Vec GLfloat where
+>     V x1 y1 ^+^ V x2 y2 = V (x1+x2) (y1+y2)
+>     V x1 y1 ^-^ V x2 y2 = V (x1-x2) (y1-y2)
+>     V x y ^*. t = V (x*t) (y*t)
+>     t .*^ V x y = V (x*t) (y*t)
+>     vnull = V 0 0
+>     V x1 y1 `dot` V x2 y2 = x1*y1+x2*y2
+>     V x1 y1 `cross` V x2 y2 = x1*y2-x2*y1
+>
+> instance Vector2D (Signal Vec) (Signal GLfloat) where
+>     (^+^) = liftA2 (^+^)
+>     (^-^) = liftA2 (^-^)
+>     (^*.) = liftA2 (^*.)
+>     (.*^) = liftA2 (.*^)
+>     vnull = pure vnull
+>     dot = liftA2 dot
+>     cross = liftA2 cross