├── .github └── workflows │ └── build-examples-deploy-pages.yml ├── .gitignore ├── LICENSE ├── README.md ├── _config.yml ├── _layouts └── default.html ├── assets └── css │ └── style.scss ├── bundle-examples.sh ├── docs ├── README.md ├── manual.md └── quickstart.md ├── examples ├── README.md ├── analog-clock │ ├── README.md │ ├── analog-clock.png │ ├── dist │ │ └── index.html │ ├── spago.yaml │ └── src │ │ └── AnalogClock.purs ├── bounce │ ├── README.md │ ├── bounce.gif │ ├── dist │ │ └── index.html │ ├── spago.yaml │ └── src │ │ └── Bounce.purs ├── hello │ ├── README.md │ ├── dist │ │ └── index.html │ ├── hello.png │ ├── spago.yaml │ └── src │ │ └── Hello.purs ├── interpolation │ ├── README.md │ ├── dist │ │ └── index.html │ ├── interpolation.gif │ ├── spago.yaml │ └── src │ │ └── Interpolation.purs ├── keyboard │ ├── README.md │ ├── dist │ │ └── index.html │ ├── output.gif │ ├── spago.yaml │ └── src │ │ └── Keyboard.purs ├── mouse-and-scaling │ ├── README.md │ ├── dist │ │ └── index.html │ ├── mouse-and-scaling.png │ ├── spago.yaml │ └── src │ │ └── MouseAndScaling.purs ├── paint-app │ ├── README.md │ ├── dist │ │ └── index.html │ ├── paint-app.png │ ├── spago.yaml │ └── src │ │ ├── ColorButton.purs │ │ ├── Grid.purs │ │ ├── PaintApp.purs │ │ └── Root.purs └── timing │ ├── README.md │ ├── dist │ └── index.html │ ├── spago.yaml │ ├── src │ ├── Timing.js │ └── Timing.purs │ └── timing.png ├── spago.lock ├── spago.yaml ├── src ├── Gesso.purs └── Gesso │ ├── Application.purs │ ├── Application │ └── Behavior.purs │ ├── Canvas.purs │ ├── Canvas │ └── Element.purs │ ├── Geometry.purs │ ├── Geometry │ ├── Dimensions.purs │ ├── Internal.purs │ └── Scaler.purs │ ├── Interactions.purs │ ├── Interactions │ ├── Events.purs │ └── Internal.purs │ ├── State.purs │ ├── Time.js │ └── Time.purs └── test └── Main.purs /.github/workflows/build-examples-deploy-pages.yml: -------------------------------------------------------------------------------- 1 | name: Build Gesso examples and deploy with Jekyll to GitHub Pages 2 | 3 | on: 4 | push: 5 | pull_request: 6 | workflow_dispatch: 7 | 8 | # Sets permissions of the GITHUB_TOKEN to allow deployment to GitHub Pages 9 | permissions: 10 | contents: read 11 | pages: write 12 | id-token: write 13 | 14 | # Allow only one concurrent deployment, skipping runs queued between the run in-progress and latest queued. 15 | # However, do NOT cancel in-progress runs as we want to allow these production deployments to complete. 16 | concurrency: 17 | group: "pages" 18 | cancel-in-progress: false 19 | 20 | jobs: 21 | # Build job 22 | build: 23 | runs-on: ubuntu-latest 24 | steps: 25 | - name: Checkout 26 | uses: actions/checkout@v4 27 | - name: Set up PureScript toolchain 28 | uses: purescript-contrib/setup-purescript@v3.1.0 29 | with: 30 | spago: "unstable" 31 | - name: "Check for cached output" 32 | uses: actions/cache@v4 33 | with: 34 | key: ${{ runner.os }}-spago-${{ hashFiles('**/spago*') }} 35 | path: | 36 | spago.lock 37 | .spago 38 | output 39 | examples/*/dist 40 | - run: npm install -g esbuild 41 | - run: spago build 42 | - run: ./bundle-examples.sh 43 | - name: Build with Jekyll 44 | uses: actions/jekyll-build-pages@v1 45 | with: 46 | source: ./ 47 | destination: ./_site 48 | - name: Upload artifact 49 | uses: actions/upload-pages-artifact@v3 50 | 51 | # Deployment job 52 | deploy: 53 | environment: 54 | name: github-pages 55 | url: ${{ steps.deployment.outputs.page_url }} 56 | runs-on: ubuntu-latest 57 | # Only deploy the new documentation if this event changed master, or if 58 | # this deploy was started manually 59 | if: ${{ (github.event_name == 'push' && github.ref_name == 'master') || github.event_name == 'workflow_dispatch' }} 60 | needs: build 61 | steps: 62 | - name: Deploy to GitHub Pages 63 | id: deployment 64 | uses: actions/deploy-pages@v4 65 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /bower_components/ 2 | /node_modules/ 3 | /.pulp-cache/ 4 | /output/ 5 | /generated-docs/ 6 | /.psc-package/ 7 | /.psc* 8 | /.purs* 9 | /.psa* 10 | /.spago 11 | /.cache 12 | /dist/ 13 | /examples/*/dist/*.js* 14 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2025 Tom Smilack 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # PureScript Gesso 2 | 3 | Gesso is a PureScript library that makes it simple to use `` graphics in standalone applications or Halogen components. 4 | 5 | Pronounced like **jes**ter and espr**esso** ([/'dʒɛsoʊ/](https://en.wikipedia.org/wiki/Help:IPA/English)), Gesso is named after a primer used to prepare canvas for painting. 6 | 7 | This is all it takes to start drawing on a ``: 8 | 9 | ```purescript 10 | module Main where 11 | 12 | import Prelude 13 | import Effect (Effect) 14 | import Gesso (launch) 15 | import Gesso.Application (WindowMode(..), defaultBehavior) 16 | import Gesso.Geometry (null) 17 | import Graphics.Canvas (fillText) 18 | 19 | main :: Effect Unit 20 | main = launch 21 | { name: "app" 22 | , initialState: unit 23 | , window: Fullscreen 24 | , viewBox: null 25 | , behavior: defaultBehavior 26 | { render = \context _ _ _ -> fillText context "hello world" 20.0 20.0 } 27 | } 28 | ``` 29 | 30 | To get started right away, check out the [Quick-Start Guide](docs/quickstart.md). 31 | 32 | ## How does it work? 33 | 34 | You tell Gesso: 35 | 36 | - Which element to put the canvas in 37 | 38 | - The initial state of your application 39 | 40 | - The size of the canvas: fullscreen, fixed size, or fill container 41 | 42 | - Optionally, a separate viewport for the drawing (like [`svg:viewBox`](https://developer.mozilla.org/en-US/docs/Web/SVG/Reference/Attribute/viewBox)) 43 | 44 | - Any of these functions: 45 | 46 | 47 | 48 | 49 | 52 | 55 | 56 | 57 | 60 | 63 | 64 | 65 | 68 | 71 | 72 | 73 | 76 | 79 | 80 | 81 | 84 | 87 | 88 | 89 |
50 | Render 51 | 53 | Draw on the canvas on each animation frame 54 |
58 | Update 59 | 61 | Make changes to the application state immediately before rendering 62 |
66 | Fixed update 67 | 69 | Make changes to the state at a regular, configurable time interval 70 |
74 | Interactions 75 | 77 | Event handlers, like mouse, keyboard, or touch events 78 |
82 | Input and output 83 | 85 | Communication with a parent Halogen component 86 |
90 | 91 | Then, Gesso: 92 | 93 | Creates a `` element, adds it to the page, sets its size and position, attaches event handlers, and starts requesting animation frames to call your rendering function. It tracks your application state and runs your update functions. It can react to queries from other Halogen components and send output when your state changes. It provides timestamps and delta times to all your functions. When using a fixed-rate update, it provides interpolation information to your render function. It provides dimensions for the `` and your drawing, and functions for scaling coordinates and sizes between the two, while automatically accounting for changes to the page size. 94 | 95 | ## Is Gesso a... 96 | 97 | ### Canvas API? 98 | No, while Gesso gives you easy access to a `Context2D` object, it's agnostic about the way you interact with it. You could use the basic canvas bindings in [purescript-canvas](https://pursuit.purescript.org/packages/purescript-canvas), another library with higher-level bindings, or your own custom ones. In fact, the original idea for Gesso was to simplify experimenting with custom canvas bindings. 99 | 100 | ### Game engine? 101 | No, Gesso does not provide anything like a physics engine, asset pipeline, or audio functions that a complete game engine might include. However, because Gesso renders with `requestAnimationFrame` and supports both per-frame and fixed-interval update functions, you could certainly make a game with Gesso if you wanted to mix and match other libraries or write your own handling for physics, sound, etc. 102 | 103 | ## Installation 104 | 105 | Install with [Spago](https://github.com/purescript/spago#installation): 106 | 107 | ``` 108 | spago install gesso 109 | ``` 110 | 111 | > [!NOTE] 112 | > Gesso is available starting in package set 63.6.0. If you're using an earlier package set, add these lines to the `extraPackages` section in `spago.yaml`: 113 | > ```yaml 114 | > extraPackages: 115 | > gesso: 116 | > git: https://github.com/smilack/purescript-gesso.git 117 | > ref: v1.0.0 118 | > ``` 119 | 120 | ## Documentation 121 | 122 | - [Quick-Start Guide](docs/quickstart.md) 123 | - [The Gesso Manual](docs/manual.md) covers the vast majority of what you need to know to use Gesso effectively. 124 | - There are a variety of [examples](examples/README.md) available to look through. 125 | - Details about specific functions and types can be found on [Pursuit](https://pursuit.purescript.org/packages/purescript-gesso/). 126 | - If you encounter a bug, the documentation is unclear or incorrect, or you have ideas for improving the API, open an issue. 127 | - For general help or questions, create a thread on the [PureScript Discourse instance](https://discourse.purescript.org/) or the [PureScript Discord Server](https://purescript.org/chat). 128 | 129 | ## License 130 | 131 | Gesso is licensed under the [MIT License](./LICENSE) 132 | -------------------------------------------------------------------------------- /_config.yml: -------------------------------------------------------------------------------- 1 | theme: jekyll-theme-slate 2 | baseurl: "/purescript-gesso" 3 | -------------------------------------------------------------------------------- /_layouts/default.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | {% seo %} 11 | {% include head-custom.html %} 12 | 13 | 14 | 15 | 16 | 17 |
18 |
19 | {% if site.github.is_project_page %} 20 | View on GitHub 21 | {% endif %} 22 | 23 |

{{ site.title | default: site.github.repository_name }}

24 |

{{ site.description | default: site.github.project_tagline }}

25 | 26 | {% if site.show_downloads %} 27 |
28 | Download this project as a .zip file 29 | Download this project as a tar.gz file 30 |
31 | {% endif %} 32 |
33 |
34 | 35 | 36 |
37 | 38 | 39 | 46 | 47 |
48 | {{ content }} 49 |
50 |
51 | 52 | 53 | 61 | 62 | 63 | -------------------------------------------------------------------------------- /assets/css/style.scss: -------------------------------------------------------------------------------- 1 | --- 2 | --- 3 | 4 | @import "{{ site.theme }}"; 5 | 6 | body { 7 | font-size: 20px; 8 | line-height: 1.4; 9 | } 10 | 11 | ol, ul { 12 | margin-left: 1rem; 13 | } 14 | 15 | li + li { 16 | margin-top: 0.25rem; 17 | } 18 | 19 | .inner { 20 | max-width: 700px; 21 | } 22 | 23 | #gesso_nav { 24 | max-width: 700px; 25 | margin: 10px auto; 26 | font-size: 24px; 27 | } 28 | 29 | #gesso_nav ul { 30 | display: flex; 31 | flex-direction: row; 32 | margin: 0; 33 | padding: 0; 34 | justify-content: flex-end; 35 | } 36 | 37 | #gesso_nav li { 38 | display: block; 39 | margin: 0; 40 | padding: 0 20px; 41 | } 42 | 43 | #gesso_nav li + li { 44 | border-left: 1px #212121 dotted; 45 | } 46 | 47 | .readme_link { 48 | font-variant: small-caps 49 | } 50 | 51 | #main_content.inner { 52 | padding-top: 0; 53 | } 54 | -------------------------------------------------------------------------------- /bundle-examples.sh: -------------------------------------------------------------------------------- 1 | set -e 2 | spago bundle --source-maps -p gesso-example-bounce 3 | spago bundle --source-maps -p gesso-example-analog-clock 4 | spago bundle --source-maps -p gesso-example-keyboard 5 | spago bundle --source-maps -p gesso-example-hello 6 | spago bundle --source-maps -p gesso-example-paint-app 7 | spago bundle --source-maps -p gesso-example-mouse-and-scaling 8 | spago bundle --source-maps -p gesso-example-interpolation 9 | spago bundle --source-maps -p gesso-example-timing 10 | -------------------------------------------------------------------------------- /docs/README.md: -------------------------------------------------------------------------------- 1 | # Gesso Documentation 2 | 3 | ## Quick-Start 4 | 5 | The [Quick-Start Guide](quickstart.md) walks you through the process of setting up and compiling your first Gesso application. 6 | 7 | ## Gesso Manual 8 | 9 | [The Gesso Manual](manual.md) covers the vast majority of what you need to know to use Gesso effectively: 10 | 11 | - How to launch a Gesso application 12 | - App configuration 13 | - The kinds of update functions 14 | - Event handling 15 | - Coordinate scaling 16 | - Parameters of rendering, update, event, and I/O functions 17 | - I/O with Halogen components 18 | 19 | Details about specific functions and types can be found on [Pursuit](https://pursuit.purescript.org/packages/purescript-gesso/). 20 | 21 | ## Examples 22 | 23 | These small programs showcase various features. See [Gesso Examples](../examples/README.md) for more information on building and running the examples. 24 | 25 | | Name | Summary | 26 | |-|-| 27 | | [Hello](hello) | The most barebones Gesso program: exactly what you need to get a canvas to draw on, and nothing more. | 28 | | [Bounce](bounce) | A circle that moves around the canvas and bounces off the edges. | 29 | | [Keyboard](keyboard) | Move a square around the canvas using the arrow keys. | 30 | | [Mouse And Scaling](mouse-and-scaling) | A graph that shows the coordinates of a mouse click. Scales coordinates between canvas and drawing. | 31 | | [Analog Clock](analog-clock) | A more complex drawing. Uses coordinate scaling functions and non-canvas `Effect`s. | 32 | | [Interpolation](interpolation) | Fixed-rate update functions and interpolating state for rendering. | 33 | | [Paint App](paint-app) | A Halogen application with an embedded Gesso component. | 34 | | [Timing](timing) | A graph comparing the `delta` values in fixed and per-frame update functions. | 35 | -------------------------------------------------------------------------------- /docs/manual.md: -------------------------------------------------------------------------------- 1 | # The Gesso Manual 2 | 3 | ### Contents 4 | 5 | 1. [Launching a Gesso Application](#launching-a-gesso-application) 6 | 1. [`launch` and `launchIn`](#launch-and-launchin) 7 | 2. [`runGessoAff`](#rungessoaff) 8 | 2. [`AppSpec` Record](#appspec-record) 9 | 1. [Basic `AppSpec` Fields](#basic-appspec-fields) 10 | 2. [Canvas Dimensions](#canvas-dimensions) 11 | 3. [`AppBehavior` Record](#appbehavior-record) 12 | 1. [Rendering Functions](#rendering-functions) 13 | 2. [Update Functions and Events](#update-functions-and-events) 14 | 3. [Per-Frame vs Fixed-Rate Updates](#per-frame-vs-fixed-rate-updates) 15 | 4. [Interactions](#interactions) 16 | 5. [Component Input and Output](#component-input-and-output) 17 | 6. [Update Timing](#update-timing) 18 | 4. [`Geometry` Module](#geometry-module) 19 | 1. [Size and Positioning Types](#size-and-positioning-types) 20 | 2. [`Scaler` and `Scalers` Records](#scaler-and-scalers-records) 21 | 3. [Calling Scaling Functions](#calling-scaling-functions) 22 | 1. [Scaling a Single Value](#scaling-a-single-value) 23 | 2. [Scaling a Record](#scaling-a-record) 24 | 3. [Flipped Scaling Functions](#flipped-scaling-functions) 25 | 4. [Scaling Function Operators](#scaling-function-operators) 26 | 4. [Other Geometry Functions](#other-geometry-functions) 27 | 5. [Gesso as a Halogen Component](#gesso-as-a-halogen-component) 28 | 1. [Halogen Component Input (Queries)](#halogen-component-input-queries) 29 | 2. [Halogen Component Output](#halogen-component-output) 30 | 31 | # Launching a Gesso Application 32 | 33 | The `Gesso` module contains functions for launching a standalone Gesso application. Launching a Gesso application always requires an [`AppSpec` record](#appspec-record). 34 | 35 | > [!TIP] 36 | > If the Gesso component is going to be part of a larger Halogen application, this module isn't necessary. See [Gesso as a Halogen Component](#gesso-as-a-halogen-component). 37 | 38 | ## `launch` and `launchIn` 39 | 40 | These are the simplest options, designed for applications which require no `Aff` effects other than Gesso. 41 | 42 | `launch` is perfect for applications with nothing else on the page. Gesso attaches directly to the page body: 43 | 44 | ```purescript 45 | launch :: forall state i o. AppSpec state i o -> Effect Unit 46 | 47 | main :: Effect Unit 48 | main = launch appSpec 49 | ``` 50 | 51 | `launchIn` is best for pages with some static content. It takes a `String` as an argument, which is treated as a query selector to find an element on the page to attach to: 52 | 53 | ```purescript 54 | launchIn :: forall state i o. String -> AppSpec state i o -> Effect Unit 55 | 56 | main :: Effect Unit 57 | main = launchIn "#some-element-id" appSpec 58 | ``` 59 | 60 | ## `runGessoAff` 61 | 62 | `runGessoAff` is an alias for `runHalogenAff`. It's the most flexible way to launch Gesso because it allows running other `Aff` effects while setting up Gesso. For example, this is roughly what `launch` does: 63 | 64 | ```purescript 65 | import Gesso.Canvas (component) 66 | import Halogen.Aff (awaitBody, runHalogenAff) 67 | import Halogen.VDom.Driver (runUI) 68 | 69 | main :: Effect Unit 70 | main = runHalogenAff do 71 | body <- awaitBody 72 | _ <- runUI component appSpec body 73 | pure unit 74 | ``` 75 | 76 | # `AppSpec` Record 77 | 78 | In `Gesso.Application`, the `AppSpec` and `AppBehavior` types contain everything that makes an application work. 79 | 80 | ```purescript 81 | type AppSpec state input output = 82 | { name :: String 83 | , initialState :: state 84 | , viewBox :: Rect 85 | , window :: WindowMode 86 | , behavior :: AppBehavior state input output 87 | } 88 | ``` 89 | 90 | ## Basic `AppSpec` Fields 91 | 92 | The `state` type is the state of your application and can be anything you want, for example, a large complicated record, a single integer, or just `unit` if you don't need to track state at all 93 | 94 | The `input` and `output` types are only used for communication with a parent component in a Halogen application. See [Gesso as a Halogen Component](#gesso-as-a-halogen-component). 95 | 96 | The `name` field will be used as the `id` attribute for the canvas element. 97 | 98 | > [!WARNING] 99 | > If you plan to target the element with any CSS or JavaScript outside of what Gesso normally does, then it's best to make `name` a valid CSS identifier. Otherwise, it doesn't matter much. 100 | 101 | ## Canvas Dimensions 102 | 103 | `viewBox` is a `Rect` ([Size and Positioning Types](#size-and-positioning-types)) that determines the coordinate system of the drawing. It is analagous to the `viewBox` attribute on an SVG — neither is tied to the actual size of the element on the page. This simplifies the drawing process when the screen size is unpredictable and subject to change. 104 | 105 | `window` determines the space that the canvas element takes up: 106 | - `Fixed` creates an element with an exact size. 107 | - `Stretch` causes the element to fill its parent. 108 | - `FullScreen` takes up the entire page from the top left corner to the bottom right. 109 | 110 | The `viewBox` scales automatically to fit within the canvas element while remaining centered. Unless the view box and drawing have the exact same aspect ratio, this leaves a margin in the canvas outside of the view box on one axis. (That is, it behaves like SVG's `preserveAspectRatio="xMidYMid meet"`) 111 | 112 | # `AppBehavior` Record 113 | 114 | The `AppBehavior` type covers all functions that make an application interact with or respond to the canvas itself, events, other components, and the passage of time. 115 | 116 | ```purescript 117 | type AppBehavior state input output = 118 | { render :: RenderFunction state 119 | , update :: UpdateFunction state 120 | , fixed :: FixedUpdate state 121 | , interactions :: Interactions state 122 | , output :: OutputProducer state output 123 | , input :: InputReceiver state input 124 | } 125 | ``` 126 | 127 | `Gesso.Application` exports a default `AppBehavior` record, which can be updated piecemeal, for example: 128 | 129 | ```purescript 130 | myAppBehavior :: AppBehavior MyState MyInput MyOutput 131 | myAppBehavior = defaultBehavior { render = render, update = update } 132 | ``` 133 | 134 | All of these functions run in `Effect` and therefore have access to any `Effect`. 135 | 136 | There are several important types in the arguments to these functions. They'll be covered in more detail later, but for a quick rundown: 137 | 138 | - `Delta`: the timestamps of the current and previous animation frames and the difference between them 139 | - `Scalers`: information about the sizes of the canvas and the drawing (view box) and functions to convert between the two 140 | - `States`: two sequential states (the current and previous) and the progress (on the interval `[0, 1]`) from the first to second 141 | - `Compare`: two states — an old and new — not necessarily sequential 142 | 143 | ## Rendering Functions 144 | 145 | ```purescript 146 | type RenderFunction state = Context2D -> Delta -> Scalers -> States state -> Effect Unit 147 | ``` 148 | 149 | `render` is the only behavior function that has access to the canvas's `Context2D` for drawing. 150 | 151 | The `States` record contains the current and previous states and an interpolation parameter. Typically, only the current is needed, and the interpolation parameter is `1`. 152 | 153 | However, if there is a fixed-interval update function running at a different rate than the rendering function, the interpolation parameter will be a number in the range `[0, 1]` representing the progress from the previous state to the current. This can be used to smooth animations in some circumstances. 154 | 155 | ## Update Functions and Events 156 | 157 | Because of the overlap between kinds of state-changing functions, they use a few type synonyms to maintain consistency. This is not how they are literally written in the code, but it may be the most clear presentation: 158 | 159 | ```purescript 160 | type UpdateFunction state = Delta -> Scalers -> local -> Effect (Maybe local) 161 | 162 | -- Gesso.Interactions 163 | type Handler event state = event -> UpdateFunction state 164 | ``` 165 | 166 | All kinds of state-changing functions have access to the same `Delta` and `Scalers` records as `render`, but only one state. 167 | 168 | All of them also return a `Maybe state`, with a `Nothing` value indicating that no change was made. 169 | 170 | ### Per-Frame vs Fixed-Rate Updates 171 | 172 | `update` is the most basic kind of update function. It runs once per frame immediately before `render`. 173 | 174 | `fixed` updates have a time interval in milliseconds (constructed using the `Gesso.Time.hz` function) and an update function. Gesso tracks the last time that the fixed update function ran (`last`). Each frame, if the amount of time since `last` is greater than `interval`, the fixed update is run repeatedly, with timestamps starting at `last + interval` and increasing by `interval`, stopping before `last + i * interval` would pass the current time. (See [GameProgrammingPatterns.com: Sequencing Patterns / Play catch up](https://gameprogrammingpatterns.com/game-loop.html#play-catch-up)) 175 | 176 | > [!WARNING] 177 | > There isn't an escape hatch to extend or skip fixed updates if the update function takes longer than `interval` to run. (Issue #24) Very small intervals or very slow fixed update functions could cause the application to get stuck trying to catch up. 178 | 179 | ## Interactions 180 | 181 | Interactions are event handlers attached to the canvas. The `interactions` field is a record containing an array for each event type: 182 | 183 | ```purescript 184 | type Interactions state = 185 | { base :: Array (EventInteraction state) 186 | , clipboard :: Array (ClipboardInteraction state) 187 | , focus :: Array (FocusInteraction state) 188 | , keyboard :: Array (KeyboardInteraction state) 189 | , touch :: Array (TouchInteraction state) 190 | , drag :: Array (DragInteraction state) 191 | , mouse :: Array (MouseInteraction state) 192 | , wheel :: Array (WheelInteraction state) 193 | , pointer :: Array (PointerInteraction state) 194 | } 195 | ``` 196 | 197 | In addition to the usual state-changing function signature, interactions have access to the triggering event. The event types come from several different modules. `Gesso.Interactions` re-exports all of these, but their original modules contain many functions for working with them: 198 | 199 | ```purescript 200 | import Web.Clipboard.ClipboardEvent (ClipboardEvent) 201 | import Web.Event.Internal.Types (Event) 202 | import Web.HTML.Event.DragEvent (DragEvent) 203 | import Web.PointerEvent (PointerEvent) 204 | import Web.TouchEvent.TouchEvent (TouchEvent) 205 | import Web.UIEvent.FocusEvent (FocusEvent) 206 | import Web.UIEvent.KeyboardEvent (KeyboardEvent) 207 | import Web.UIEvent.MouseEvent (MouseEvent) 208 | import Web.UIEvent.WheelEvent (WheelEvent) 209 | ``` 210 | 211 | Interaction constructors are re-exported in the `Gesso.Interactions` module but you can look at `Gesso.Interactions.Events` for a complete list. A small number of canvas events are not implemented yet, but they are included with comments for completeness. 212 | 213 | Interaction constructors take a `Handler event state` function and return a type of interaction specific to that event (e.g. `onMouseDown :: forall s. Handler MouseEvent s -> MouseInteraction s`). A default record containing no interactions is provided for convenience. 214 | 215 | Here is an example of creating an event handler and adding it to an `Interactions` record: 216 | 217 | ```purescript 218 | import Web.UIEvent.MouseEvent (MouseEvent) 219 | import Gesso.Geometry (Point, fromMouseEvent) 220 | import Gesso.Interactions (Interactions, MouseInteraction, default, onMouseMove) 221 | 222 | type State = Point 223 | 224 | appInteractions :: Interactions State 225 | appInteractions = default { mouse = [ trackMousePosition ] } 226 | 227 | trackMousePosition :: MouseInteraction State 228 | trackMousePosition = onMouseMove getMousePosition 229 | 230 | getMousePosition :: MouseEvent -> Delta -> Scalers -> state -> Effect (Maybe state) 231 | getMousePosition event _ _ _ = pure $ Just $ fromMouseEvent event 232 | ``` 233 | 234 | The default `Interactions` record is already included in the default `AppBehavior` record, so it can be updated at the same time the rest of the `AppSpec` is defined. 235 | 236 | ## Component Input and Output 237 | 238 | The `input` and `output` functions control component I/O between a Gesso component and a parent component in a Halogen application. See [Gesso as a Halogen Component](#gesso-as-a-halogen-component). 239 | 240 | ## Update Timing 241 | 242 | Interactions and component inputs are timestamped as they arrive, and their `Delta` values are based on the difference between this time and the time of the last frame rendering. 243 | 244 | On each animation frame, after Gesso determines the timing of any necessary fixed update function calls, interactions, component inputs, and fixed updates are sorted by timestamp before processing. 245 | 246 | # `Geometry` Module 247 | 248 | ## Size and Positioning Types 249 | 250 | `Gesso.Geometry` contains three pairs of Row and Record types that may be useful. The Row types are open and have a type parameter: 251 | 252 | ```purescript 253 | type Position a r = ( x :: a, y :: a | r ) 254 | 255 | type Size a r = ( width :: a, height :: a | r ) 256 | 257 | type Rectangular a r = Position a + Size a + r 258 | ``` 259 | 260 | Each Row has a corresponding closed record with the type specified as `Number`: 261 | 262 | ```purescript 263 | type Point = { | Position Number () } 264 | 265 | type Area = { | Size Number () } 266 | 267 | type Rect = { | Rectangular Number () } 268 | ``` 269 | 270 | These are used in a handful of places internally, and some external modules, like `Graphics.Canvas`, use records with the same fields for functions like `fillRect` and `clearRect`. 271 | 272 | There is also a default, empty value for each record: 273 | 274 | ```purescript 275 | origin :: Point 276 | origin = { x: 0.0, y: 0.0 } 277 | 278 | sizeless :: Area 279 | sizeless = { width: 0.0, height: 0.0 } 280 | 281 | null :: Rect 282 | null = { x: 0.0, y: 0.0, width: 0.0, height: 0.0 } 283 | ``` 284 | 285 | ## `Scaler` and `Scalers` Records 286 | 287 | Because the size of a user's screen or browser window is unpredictable, it's useful to set a view box in the `AppSpec` so that drawing coordinates can be consistent. However, this means that it's necessary to convert from drawing coordinates to canvas coordinates in order to paint the canvas, and to convert from canvas to drawing to process mouse or touch events. In addition, because the view box scales by preserving its aspect ratio while remaining centered, there may be a margin to account for — horizontally or vertically. 288 | 289 | > [!IMPORTANT] 290 | > The `viewBox` record determines two things: 291 | > 1. the scale and position of the drawing coordinates relative to the canvas coordinates 292 | > 2. the area of the drawing that must always be visible 293 | > 294 | > The drawing coordinate system extends infinitely, which means that canvas coordinates outside the view box can still be converted to valid drawing coordinates. Drawings in the margins may be visible, but drawings are only *guaranteed* to be visible if they fall within the view box. 295 | 296 | The `Scalers` record contains data and functions to simplify all of these conversions. 297 | 298 | ```purescript 299 | type Scalers = 300 | { scale :: Number 301 | , canvas :: Scaler 302 | , drawing :: Scaler 303 | } 304 | ``` 305 | 306 | `scale` is a constant scaling factor: the amount that the view box has been scaled up or down to fit within the canvas. 307 | 308 | `canvas` and `drawing` are: 309 | 310 | ```purescript 311 | -- with some synonyms expanded: 312 | type Scaler = 313 | { rect :: Rect 314 | , x :: Number 315 | , y :: Number 316 | , width :: Number 317 | , height :: Number 318 | , scaling :: 319 | { all :: forall rl r. RowToList r rl => Scalable rl r Number => {| r } -> Builder {} {| r } 320 | , x :: Number -> Number 321 | , y :: Number -> Number 322 | , length :: Number -> Number 323 | } 324 | } 325 | ``` 326 | 327 | The `x`/`y`/`width`/`height` fields are the same as the `rect` field, but repeated to make it easier to get a single attribute or `Rect` as needed. 328 | 329 | In `drawing`, these fields are identical to the view box. In `canvas`, `x` and `y` are zero and `width` and `height` are the dimensions of the canvas. 330 | 331 | > [!TIP] 332 | > The `Scalers` record is automatically rebuilt whenever the browser window is resized. 333 | 334 | ## Calling Scaling Functions 335 | 336 | The `scaling` field of a `Scaler` contains functions for scaling to the coordinate system with the same name as the record. It's not recommended to call the scaling functions directly. Instead, use these functions from `Geometry`: 337 | 338 | ```purescript 339 | xTo :: Number -> Scaler -> Number 340 | 341 | yTo :: Number -> Scaler -> Number 342 | 343 | lengthTo :: Number -> Scaler -> Number 344 | 345 | to :: forall rl r. RowToList r rl => Scalable rl r Number => {| r } -> Scaler -> {| r } 346 | ``` 347 | 348 | ### Scaling a Single Value 349 | 350 | `xTo`, `yTo`, and `lengthTo` operate on single values. For example, if you have a circle with radius `1.0` in your view box at coordinates `(2.0, 3.0)`, you could convert those values to canvas coordinates like this: 351 | 352 | ```purescript 353 | x' = 2.0 `xTo` canvas 354 | y' = 3.0 `yTo` canvas 355 | r' = 1.0 `lengthTo` canvas 356 | ``` 357 | 358 | (What makes `lengthTo` different from the others is that lengths don't need to account for page margins.) 359 | 360 | ### Scaling a Record 361 | 362 | The `to` function is provided to greatly simplify scaling multiple values: 363 | 364 | ```purescript 365 | circle' = { x: 2.0, y: 3.0, r: 1.0 } `to` canvas 366 | ``` 367 | 368 | Its type signature is so abstract because it can operate on any record and automatically convert many different fields. Currently, it will convert any of these fields if they have type `Number`: 369 | 370 | | Conversion | Field name | 371 | |-|-| 372 | | `xTo` | `x`, `x1`, `x2` | 373 | | `yTo` | `y`, `y1`, `y2` | 374 | | `lengthTo` | `width`, `w`, `height`, `h`, `radius`, `r`, `length`, `len`, `l` | 375 | 376 | ### Flipped Scaling Functions 377 | 378 | `to`, `xTo`, `yTo`, and `lengthTo` have `from` counterparts with flipped arguments, e.g.: 379 | 380 | ```purescript 381 | xTo :: Number -> Scaler -> Number 382 | 383 | xFrom :: Scaler -> Number -> Number 384 | xFrom = flip xTo 385 | ``` 386 | 387 | This can be more convenient sometimes, depending on code formatting, or when composing functions. 388 | 389 | ### Scaling Function Operators 390 | 391 | The scaling functions have infix operators as well: 392 | 393 | | | `to` | `from` | 394 | |-|-|-| 395 | | all | `*~>` | `<~*` | 396 | | `x` | `-~>` | `<~-` | 397 | | `y` | `\|~>` | `<~\|` | 398 | | `length` | `/~>` | `<~/` | 399 | 400 | For example: 401 | 402 | ```purescript 403 | x' = 2.0 -~> canvas 404 | circle' = canvas <~* { x: 2.0, y: 3.0, r: 1.0 } 405 | ``` 406 | 407 | ## Other Geometry Functions 408 | 409 | Geometry exports a `fromMouseEvent` function that extracts a `Point` (in canvas coordinates) from a `MouseEvent`. 410 | 411 | # Gesso as a Halogen Component 412 | 413 | See the [Halogen Guide: Parent and Child Components](https://purescript-halogen.github.io/purescript-halogen/guide/05-Parent-Child-Components.html) for adding a child to a Halogen component. 414 | 415 | > [!IMPORTANT] 416 | > Halogen and Gesso use slightly different terminology here. 417 | > 418 | > In Halogen, child components can have a `receive :: input -> Maybe action` function that's called on every render, and "Input" refers to this function. "Queries" are messages sent from a parent to a child outside of this cycle, and "Output" is messages sent from a child to a parent. 419 | > 420 | > The Gesso component doesn't use a `receive` function, so "Queries" are referred to as "Input" for symmetry with "Output." 421 | 422 | `Gesso.Canvas` provides a `Slot` type which includes the `CanvasInput` and `CanvasOutput` types used for I/O, as well as a proxy for the row label: 423 | 424 | ```purescript 425 | type Slot input output slot = H.Slot (CanvasInput input) (CanvasOutput output) slot 426 | 427 | _gessoCanvas = Proxy :: Proxy "gessoCanvas" 428 | ``` 429 | 430 | You'll need to define an input and an output type (which can be the same) that will be reflected in the `AppSpec`. Recall the `AppSpec` and `AppBehavior` types: 431 | 432 | ```purescript 433 | type AppSpec state input output = 434 | { name :: String 435 | , initialState :: state 436 | , viewBox :: Rect 437 | , window :: WindowMode 438 | , behavior :: AppBehavior state input output 439 | } 440 | 441 | type AppBehavior state input output = 442 | { render :: RenderFunction state 443 | , update :: UpdateFunction state 444 | , fixed :: FixedUpdate state 445 | , interactions :: Interactions state 446 | , output :: OutputProducer state output 447 | , input :: InputReceiver state input 448 | } 449 | ``` 450 | 451 | ## Halogen Component Input (Queries) 452 | 453 | `InputReceiver` is an update function that also receives a copy of the input type. Apart from that, it behaves the same as an update or event handler. 454 | 455 | ```purescript 456 | type InputReceiver state input = input -> Delta -> Scalers -> state -> Effect (Maybe state) 457 | ``` 458 | 459 | It's invoked when a parent component calls `Halogen.tell` targeted at the canvas component. 460 | 461 | ## Halogen Component Output 462 | 463 | When an application's state changes, an `OutputProducer` function is called: 464 | 465 | ```purescript 466 | type OutputProducer state output = Delta -> Scalers -> Compare state -> Effect (Maybe output) 467 | ``` 468 | 469 | It's similar to an update function, with two main differences: 470 | 471 | - Instead of a single state, it gets a `Compare state` record: 472 | 473 | ```purescript 474 | type Compare a = { old :: a, new :: a } 475 | ``` 476 | 477 | - Instead of returning a `Maybe state`, it returns a `Maybe output` 478 | 479 | It has an opportunity to compare the two states and determine if the parent component needs to know about the difference. `Nothing` return values are ignored, while `Just` values lead to calling `Halogen.raise`. 480 | 481 | This requires the `Slot` in the parent component to designate an `Action` to handle the output. 482 | -------------------------------------------------------------------------------- /docs/quickstart.md: -------------------------------------------------------------------------------- 1 | # Gesso Quick-Start Guide 2 | These are the basic steps to get a brand new Gesso project up and running. 3 | 4 | ## 1. Initialize a new PureScript project 5 | ``` 6 | spago init 7 | ``` 8 | 9 | ## 2. Install Gesso and `purescript-canvas` 10 | ``` 11 | spago install canvas 12 | spago install gesso 13 | ``` 14 | 15 | > [!NOTE] 16 | > Gesso is available starting in package set 63.6.0. If you're using an earlier package set, add these lines to the `extraPackages` section in `spago.yaml`: 17 | > ```yaml 18 | > extraPackages: 19 | > gesso: 20 | > git: https://github.com/smilack/purescript-gesso.git 21 | > ref: v1.0.0 22 | > ``` 23 | 24 | ## 3. Write application in `src/Main.purs` 25 | ```purescript 26 | module Main where 27 | 28 | import Prelude 29 | 30 | import Effect (Effect) 31 | import Gesso (launch) 32 | import Gesso.Application (AppSpec, WindowMode(..), defaultBehavior) 33 | import Gesso.Geometry (null) 34 | import Graphics.Canvas (fillText) 35 | 36 | appSpec :: forall i o. AppSpec Unit i o 37 | appSpec = 38 | { name: "app" 39 | , initialState: unit 40 | , window: Fullscreen 41 | , viewBox: null 42 | , behavior: defaultBehavior 43 | { render = \context _ _ _ -> fillText context "hello world" 20.0 20.0 44 | } 45 | } 46 | 47 | main :: Effect Unit 48 | main = launch appSpec 49 | ``` 50 | 51 | ## 4. Bundle project 52 | ``` 53 | spago bundle 54 | ``` 55 | 56 | > [!NOTE] 57 | > `spago bundle` uses `esbuild`. If you don't have it, you can install it with `npm`: 58 | > ``` 59 | > npm install -g esbuild 60 | > ``` 61 | 62 | ## 5. Create HTML file to run application 63 | ```html 64 | 65 | 66 | 67 | 68 | Gesso Quick-Start 69 | 70 | 71 | 72 | 73 | 74 | ``` 75 | 76 | ## 6. Open the file in a browser 77 | You should the the words "hello world" in the upper left corner. Next, check out [the examples](../examples/README.md) to see what you can do with Gesso! 78 | -------------------------------------------------------------------------------- /examples/README.md: -------------------------------------------------------------------------------- 1 | # Gesso Examples 2 | 3 | This folder contains several Gesso programs showcasing a variety of options. Each example's readme has more details and a link to a pre-compiled version you can run online. 4 | 5 | | Name | Summary | 6 | |-|-| 7 | | [Hello](hello) | The most barebones Gesso program: exactly what you need to get a canvas to draw on, and nothing more. | 8 | | [Bounce](bounce) | A circle that moves around the canvas and bounces off the edges. | 9 | | [Keyboard](keyboard) | Move a square around the canvas using the arrow keys. | 10 | | [Mouse And Scaling](mouse-and-scaling) | A graph that shows the coordinates of a mouse click. Scales coordinates between canvas and drawing. | 11 | | [Analog Clock](analog-clock) | A more complex drawing. Uses coordinate scaling functions and non-canvas `Effect`s. | 12 | | [Interpolation](interpolation) | Fixed-rate update functions and interpolating state for rendering. | 13 | | [Paint App](paint-app) | A Halogen application with an embedded Gesso component. | 14 | | [Timing](timing) | A graph comparing the `delta` values in fixed and per-frame update functions. | 15 | 16 | ## Compiling the examples 17 | 18 | Here are the steps to compile and run them locally: 19 | 20 | ### Prerequisites 21 | 22 | - [PureScript compiler](https://github.com/purescript/purescript) 23 | - [Spago](https://github.com/purescript/spago#installation) 24 | - [esbuild](https://esbuild.github.io/getting-started/) 25 | 26 | The easiest way to get set up is to install these all globally with `npm`: 27 | 28 | ``` 29 | npm install -g purescript 30 | npm install -g spago@next 31 | npm install -g esbuild 32 | ``` 33 | 34 | ### Building 35 | 36 | First, clone the Gesso repository to your computer. 37 | 38 | To run the examples locally, they have to be bundled. You can bundle a single example with this command: 39 | 40 | ``` 41 | spago bundle --source-maps -p gesso-example-hello 42 | ``` 43 | 44 | > [!NOTE] 45 | > The `--source-maps` option lets you see PureScript code in the browser debugger. 46 | 47 | Or, you can bundle all the examples at once using the `bundle-examples.sh` script, which runs that command for every example. 48 | 49 | The example package names are: 50 | 51 | ``` 52 | gesso-example-hello 53 | gesso-example-bounce 54 | gesso-example-keyboard 55 | gesso-example-mouse-and-scaling 56 | gesso-example-analog-clock 57 | gesso-example-interpolation 58 | gesso-example-paint-app 59 | gesso-example-timing 60 | ``` 61 | 62 | ### Running 63 | 64 | An `index.html` file is provided in each example's `dist` folder. For example, after bundling the `hello` example, you can open up `examples/hello/dist/index.html` in your browser to run it. 65 | -------------------------------------------------------------------------------- /examples/analog-clock/README.md: -------------------------------------------------------------------------------- 1 | # Analog Clock 2 | 3 | This example renders an analog clock that updates in real time. 4 | 5 | It's a more complex drawing than other examples and uses a variety of canvas functions, as well as: 6 | 7 | ### `Effect`s 8 | 9 | Because the `render` function runs in the `Effect` monad, it's able to call the `nowTime` function from `Effect.Now`. 10 | 11 | ### Scaling 12 | 13 | The example uses a custom view box in `AppSpec`: 14 | 15 | ```purescript 16 | , viewBox: { x: 0.0, y: 0.0, width: 1100.0, height: 1100.0 } 17 | ``` 18 | 19 | In `render`, the clock is defined by a circle in the middle of the view box, and the position and radius are scaled to the canvas with the `to` scaling function: 20 | 21 | ```purescript 22 | clock = 23 | { x: drawing.width / 2.0 24 | , y: drawing.height / 2.0 25 | , r: 500.0 26 | } `to` canvas 27 | ``` 28 | 29 | Some other values are scaled as well, like the thicknesses of the clock's hands: 30 | 31 | ```purescript 32 | -- hour and minute hands 33 | Canvas.setLineWidth context $ 16.0 `lengthTo` canvas 34 | 35 | -- second hand 36 | Canvas.setLineWidth context $ 7.0 `lengthTo` canvas 37 | ``` 38 | 39 | ## Sample output 40 | 41 | [See this example in action](https://smilack.github.io/purescript-gesso/examples/analog-clock/dist/) 42 | 43 | ![Screenshot of analog clock displaying 7:56:01](analog-clock.png) 44 | -------------------------------------------------------------------------------- /examples/analog-clock/analog-clock.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/smilack/purescript-gesso/d78e1ccdb17a838288b5c5a9207dd5ad22bac4ee/examples/analog-clock/analog-clock.png -------------------------------------------------------------------------------- /examples/analog-clock/dist/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | Gesso Analog Clock Example 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- /examples/analog-clock/spago.yaml: -------------------------------------------------------------------------------- 1 | package: 2 | dependencies: 3 | - arrays 4 | - canvas 5 | - datetime 6 | - effect 7 | - enums 8 | - foldable-traversable 9 | - gesso 10 | - integers 11 | - now 12 | - numbers 13 | - prelude 14 | name: gesso-example-analog-clock 15 | bundle: 16 | module: Gesso.Example.AnalogClock 17 | outfile: "dist/example.js" 18 | -------------------------------------------------------------------------------- /examples/analog-clock/src/AnalogClock.purs: -------------------------------------------------------------------------------- 1 | module Gesso.Example.AnalogClock (main) where 2 | 3 | import Prelude 4 | 5 | import Data.Array (range) 6 | import Data.Enum (fromEnum) 7 | import Data.Foldable (sequence_) 8 | import Data.Int (toNumber, floor) 9 | import Data.Number (cos, sin, pi, tau) 10 | import Data.Time (hour, minute, second) as Time 11 | import Effect (Effect) 12 | import Effect.Now (nowTime) as Now 13 | import Gesso (launch) as Gesso 14 | import Gesso.Application (WindowMode(..), defaultBehavior) as GApp 15 | import Gesso.Geometry (lengthTo, to) 16 | import Gesso.Geometry (Scalers) as GGeo 17 | import Gesso.State (States) as GSt 18 | import Gesso.Time (Delta) as GTime 19 | import Graphics.Canvas as Canvas 20 | 21 | main :: Effect Unit 22 | main = Gesso.launch 23 | { name: "analog-clock" 24 | , initialState: unit 25 | , window: GApp.Fullscreen 26 | , viewBox: { x: 0.0, y: 0.0, width: 1100.0, height: 1100.0 } 27 | , behavior: GApp.defaultBehavior { render = render } 28 | } 29 | 30 | render 31 | :: Canvas.Context2D 32 | -> GTime.Delta 33 | -> GGeo.Scalers 34 | -> GSt.States Unit 35 | -> Effect Unit 36 | render context _ { canvas, drawing } _ = do 37 | -- Clear background 38 | Canvas.setFillStyle context "white" 39 | Canvas.fillRect context canvas.rect 40 | drawFrame 41 | drawNumbers 42 | drawHashes 43 | { hour, minute, second } <- getTime 44 | drawHourHand hour minute 45 | drawMinuteHand minute second 46 | drawSecondHand second 47 | -- Center dot 48 | Canvas.setFillStyle context "#888888" 49 | Canvas.fillPath context do 50 | Canvas.arc context 51 | { x: clock.x 52 | , y: clock.y 53 | , start: 0.0 54 | , end: tau 55 | , radius: 15.0 `lengthTo` canvas 56 | , useCounterClockwise: false 57 | } 58 | where 59 | clock = 60 | { x: drawing.width / 2.0 61 | , y: drawing.height / 2.0 62 | , r: 500.0 63 | } `to` canvas 64 | 65 | eta = pi / 2.0 66 | 67 | getTime :: Effect { hour :: Number, minute :: Number, second :: Number } 68 | getTime = do 69 | t <- Now.nowTime 70 | let 71 | hour = toNumber $ (_ `mod` 12) $ (_ + 7) $ fromEnum $ Time.hour t 72 | 73 | minute = toNumber $ fromEnum $ Time.minute t 74 | 75 | second = toNumber $ fromEnum $ Time.second t 76 | pure { hour, minute, second } 77 | 78 | drawFrame :: Effect Unit 79 | drawFrame = do 80 | Canvas.setFillStyle context "#eeeeee" 81 | Canvas.fillPath context do 82 | Canvas.arc context 83 | { x: clock.x 84 | , y: clock.y 85 | , start: 0.0 86 | , end: tau 87 | , radius: clock.r 88 | , useCounterClockwise: false 89 | } 90 | Canvas.setStrokeStyle context "#888888" 91 | Canvas.setLineWidth context $ 25.0 `lengthTo` canvas 92 | Canvas.strokePath context do 93 | Canvas.arc context 94 | { x: clock.x 95 | , y: clock.y 96 | , start: 0.0 97 | , end: tau 98 | , radius: clock.r 99 | , useCounterClockwise: false 100 | } 101 | 102 | drawNumbers :: Effect Unit 103 | drawNumbers = do 104 | let 105 | size = floor $ 78.0 `lengthTo` canvas 106 | Canvas.setFillStyle context "black" 107 | Canvas.setFont context $ show size <> "pt Georgia" 108 | Canvas.setTextAlign context Canvas.AlignCenter 109 | sequence_ $ map drawNumber $ range 1 12 110 | 111 | drawNumber :: Int -> Effect Unit 112 | drawNumber i = do 113 | let 114 | angle = (_ - eta) <<< (_ * (tau / 12.0)) <<< toNumber $ i `mod` 12 115 | 116 | x = clock.x + (0.775 * clock.r * cos angle) 117 | 118 | -- Graphics.Canvas doesn't have setTextBaseline, so push the numbers down 119 | -- a little bit 120 | y = clock.y + (0.775 * clock.r * sin angle + (30.0 `lengthTo` canvas)) 121 | Canvas.fillText context (show i) x y 122 | 123 | drawHashes :: Effect Unit 124 | drawHashes = do 125 | Canvas.setStrokeStyle context "black" 126 | Canvas.setLineCap context Canvas.Square 127 | sequence_ $ map drawHash $ range 0 59 128 | 129 | drawHash :: Int -> Effect Unit 130 | drawHash i = do 131 | if i `mod` 5 == 0 then 132 | Canvas.setLineWidth context $ 9.0 `lengthTo` canvas 133 | else 134 | Canvas.setLineWidth context $ 3.0 `lengthTo` canvas 135 | let 136 | angle = (_ * (tau / 60.0)) <<< toNumber $ i 137 | drawLineSegment angle 0.9 0.95 138 | 139 | drawHourHand :: Number -> Number -> Effect Unit 140 | drawHourHand hour minute = do 141 | let 142 | angle = (_ - eta) <<< (_ * (tau / 12.0)) $ (_ + (minute / 60.0)) $ hour 143 | Canvas.setLineCap context Canvas.Round 144 | Canvas.setStrokeStyle context "black" 145 | Canvas.setLineWidth context $ 16.0 `lengthTo` canvas 146 | drawLineSegment angle (-0.1) 0.5 147 | 148 | drawMinuteHand :: Number -> Number -> Effect Unit 149 | drawMinuteHand minute second = do 150 | let 151 | angle = (_ - eta) <<< (_ * (tau / 60.0)) $ (_ + (second / 60.0)) $ minute 152 | Canvas.setLineCap context Canvas.Round 153 | Canvas.setStrokeStyle context "black" 154 | Canvas.setLineWidth context $ 16.0 `lengthTo` canvas 155 | drawLineSegment angle (-0.1) 0.7 156 | 157 | drawSecondHand :: Number -> Effect Unit 158 | drawSecondHand second = do 159 | let 160 | angle = (_ - eta) <<< (_ * (tau / 60.0)) $ second 161 | Canvas.setLineCap context Canvas.Square 162 | Canvas.setStrokeStyle context "#DD0000" 163 | Canvas.setLineWidth context $ 7.0 `lengthTo` canvas 164 | drawLineSegment angle (-0.2) 0.7 165 | Canvas.setLineWidth context $ 16.0 `lengthTo` canvas 166 | Canvas.setLineCap context Canvas.Round 167 | drawLineSegment angle (-0.2) (-0.1) 168 | 169 | drawLineSegment :: Number -> Number -> Number -> Effect Unit 170 | drawLineSegment angle r1 r2 = do 171 | let 172 | x = clock.x + (r1 * clock.r * cos angle) 173 | 174 | x' = clock.x + (r2 * clock.r * cos angle) 175 | 176 | y = clock.y + (r1 * clock.r * sin angle) 177 | 178 | y' = clock.y + (r2 * clock.r * sin angle) 179 | Canvas.strokePath context do 180 | Canvas.moveTo context x y 181 | Canvas.lineTo context x' y' 182 | -------------------------------------------------------------------------------- /examples/bounce/README.md: -------------------------------------------------------------------------------- 1 | # Bounce 2 | 3 | This example adds animation and state to an application. A red circle moves across the page, changing direction when it hits an edge. 4 | 5 | ### `update` 6 | 7 | The update function moves the circle and may change its velocity depending on its position. It uses the `x`, `y`, `width`, and `height` properties of the `canvas` scaler to check the bounds of the canvas: 8 | 9 | ```purescript 10 | update :: Delta -> Scalers -> State -> Effect (Maybe State) 11 | update _ { canvas } { x, vx, y, vy } = pure $ Just $ 12 | { x: x + vx' 13 | , vx: vx' 14 | , y: y + vy' 15 | , vy: vy' 16 | } 17 | where 18 | vx' = updateV x canvas.x (canvas.x + canvas.width) vx 19 | vy' = updateV y canvas.y (canvas.y + canvas.height) vy 20 | ``` 21 | 22 | This update is a pure function, but update functions run in `Effect`, so the new state is wrapped in `pure`. 23 | 24 | To signal whether the state has changed, the new state is wrapped in a `Maybe` value with the `Just` constructor. If the function returned `Nothing` instead, this would tell Gesso to keep the state the same. 25 | 26 | > [!IMPORTANT] 27 | > The `Maybe` wrapper is important because the state type can be anything, and there are many types that can't be compared for equality. 28 | 29 | ### Rendering 30 | 31 | The `render` function uses the `rect` property of the `canvas` scaler to clear the visible portion of the canvas: 32 | 33 | ```purescript 34 | render :: Context2D -> Delta -> Scalers -> States State -> Effect Unit 35 | render context _ { canvas } { current: { x, y } } = do 36 | Canvas.clearRect context canvas.rect 37 | ``` 38 | 39 | ## Sample output 40 | 41 | [See this example in action](https://smilack.github.io/purescript-gesso/examples/bounce/dist/) 42 | 43 | ![A red circle inside a large rectangle. The circle moves in a straight line until it reaches an edge of the rectangle, then bounces off, changing direction.](bounce.gif) 44 | -------------------------------------------------------------------------------- /examples/bounce/bounce.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/smilack/purescript-gesso/d78e1ccdb17a838288b5c5a9207dd5ad22bac4ee/examples/bounce/bounce.gif -------------------------------------------------------------------------------- /examples/bounce/dist/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | Gesso Bounce Example 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- /examples/bounce/spago.yaml: -------------------------------------------------------------------------------- 1 | package: 2 | dependencies: 3 | - canvas 4 | - effect 5 | - gesso 6 | - maybe 7 | - numbers 8 | - prelude 9 | name: gesso-example-bounce 10 | bundle: 11 | module: Gesso.Example.Bounce 12 | outfile: "dist/example.js" 13 | -------------------------------------------------------------------------------- /examples/bounce/src/Bounce.purs: -------------------------------------------------------------------------------- 1 | module Gesso.Example.Bounce (main) where 2 | 3 | import Prelude 4 | 5 | import Data.Maybe (Maybe(..)) 6 | import Data.Number (pi) 7 | import Effect (Effect) 8 | import Gesso (launch) as Gesso 9 | import Gesso.Application (WindowMode(..), defaultBehavior) as GApp 10 | import Gesso.Geometry (null, Scalers) as GGeo 11 | import Gesso.State (States) as GSt 12 | import Gesso.Time (Delta) as GTime 13 | import Graphics.Canvas as Canvas 14 | 15 | main :: Effect Unit 16 | main = Gesso.launch 17 | { name: "bounce" 18 | , initialState 19 | , viewBox: GGeo.null 20 | , window: GApp.Fullscreen 21 | , behavior: GApp.defaultBehavior 22 | { render = render 23 | , update = update 24 | } 25 | } 26 | 27 | type State = 28 | { x :: Number 29 | , vx :: Number 30 | , y :: Number 31 | , vy :: Number 32 | } 33 | 34 | v :: Number 35 | v = 2.0 36 | 37 | radius :: Number 38 | radius = 50.0 39 | 40 | initialState :: State 41 | initialState = 42 | { x: radius 43 | , vx: v 44 | , y: radius 45 | , vy: v 46 | } 47 | 48 | update :: GTime.Delta -> GGeo.Scalers -> State -> Effect (Maybe State) 49 | update _ { canvas } { x, vx, y, vy } = pure $ Just $ 50 | { x: x + vx' 51 | , vx: vx' 52 | , y: y + vy' 53 | , vy: vy' 54 | } 55 | where 56 | vx' = updateV x canvas.x (canvas.x + canvas.width) vx 57 | vy' = updateV y canvas.y (canvas.y + canvas.height) vy 58 | 59 | updateV :: Number -> Number -> Number -> Number -> Number 60 | updateV position min max velocity 61 | | position + radius + velocity > max = -v 62 | | position - radius + velocity < min = v 63 | | otherwise = velocity 64 | 65 | render 66 | :: Canvas.Context2D 67 | -> GTime.Delta 68 | -> GGeo.Scalers 69 | -> GSt.States State 70 | -> Effect Unit 71 | render context _ { canvas } { current: { x, y } } = do 72 | Canvas.clearRect context canvas.rect 73 | Canvas.setFillStyle context "red" 74 | Canvas.fillPath context $ 75 | Canvas.arc context 76 | { x, y, radius, start: 0.0, end: 2.0 * pi, useCounterClockwise: false } 77 | -------------------------------------------------------------------------------- /examples/hello/README.md: -------------------------------------------------------------------------------- 1 | # Hello 2 | 3 | This is the most minimal example of a Gesso application - a starting point for anything you might build. 4 | 5 | ### Configuration 6 | 7 | The argument to `launch` is an `AppSpec` record. The Gesso manual has [a section covering `AppSpec` in detail](../../docs/manual.md#2-appspec). 8 | 9 | Here, we use: 10 | 11 | - `name` - the ID of our application - is `"hello"` 12 | - `initialState` is `unit` because this application doesn't track any state 13 | - the `viewBox` is [`null`](../../docs/manual.md#row-and-record-types), meaning we don't need a custom coordinate system for the drawing - we'll just use the dimensions of the canvas 14 | - `window` is `Fullscreen`, so the canvas will take up the entire page 15 | - in `behavior`, we overwrite the default `render` function with our function that draws the text `"hello world"` 16 | 17 | ## Sample output 18 | 19 | [See this example in action](https://smilack.github.io/purescript-gesso/examples/hello/dist/) 20 | 21 | ![A large white rectangle with small black text near the bottom middle that says "hello world"](hello.png) 22 | -------------------------------------------------------------------------------- /examples/hello/dist/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | Gesso Hello Example 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- /examples/hello/hello.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/smilack/purescript-gesso/d78e1ccdb17a838288b5c5a9207dd5ad22bac4ee/examples/hello/hello.png -------------------------------------------------------------------------------- /examples/hello/spago.yaml: -------------------------------------------------------------------------------- 1 | package: 2 | dependencies: 3 | - canvas 4 | - effect 5 | - gesso 6 | - prelude 7 | name: gesso-example-hello 8 | bundle: 9 | module: Gesso.Example.Hello 10 | outfile: "dist/example.js" 11 | -------------------------------------------------------------------------------- /examples/hello/src/Hello.purs: -------------------------------------------------------------------------------- 1 | module Gesso.Example.Hello (main) where 2 | 3 | import Effect (Effect) 4 | import Gesso (launch) 5 | import Gesso.Application (WindowMode(..), defaultBehavior) 6 | import Gesso.Geometry (Scalers, null) 7 | import Gesso.State (States) 8 | import Gesso.Time (Delta) 9 | import Graphics.Canvas (Context2D, fillText) 10 | import Prelude (Unit, unit) 11 | 12 | main :: Effect Unit 13 | main = launch 14 | { name: "hello" 15 | , initialState: unit 16 | , viewBox: null 17 | , window: Fullscreen 18 | , behavior: defaultBehavior { render = render } 19 | } 20 | 21 | render :: Context2D -> Delta -> Scalers -> States Unit -> Effect Unit 22 | render context _ _ _ = fillText context "hello world" 500.0 500.0 23 | -------------------------------------------------------------------------------- /examples/interpolation/README.md: -------------------------------------------------------------------------------- 1 | # Interpolation 2 | 3 | This example demonstrates movement interpolation and fixed-rate update functions. 4 | 5 | ### Updates 6 | 7 | A fixed-rate update function runs every 50 milliseconds (20 times per second), moving a circle horizontally, bouncing back and forth. 8 | 9 | ### Interpolation 10 | 11 | Because the update function doesn't run at the same frequency as the render function, the animation is not synchronized with the movement. This means that the "current" state when rendering is often slightly different from what it would be in a perfectly timed system. 12 | 13 | `render` can use the `current`, `previous`, and `t` fields from the `States` record to estimate the correct position of the circle: 14 | 15 | ```purescript 16 | type States a = { current :: a, previous :: a, t :: Number } 17 | ``` 18 | 19 | `t` is a number from `0` to `1` that represents a fraction of the fixed-rate update interval: the amount of time passed since the last update. 20 | 21 | There are other methods of interpolation, but a simple linear interpolation function is exported by `Gesso.State`: 22 | 23 | ```purescript 24 | lerp :: States Number -> Number 25 | lerp { current, previous, t } = (1.0 - t) * previous + t * current 26 | ``` 27 | 28 | ### Animation 29 | 30 | A circle moves back and forth, leaving a trail. Each second, it alternates between: 31 | 32 | 1. a black circle moving with interpolated position 33 | 2. a white circle moving without interpolating its position 34 | 35 | The white trail is choppier than the black, showing the difference that interpolation makes. 36 | 37 | ## Sample output 38 | 39 | [See this example in action](https://smilack.github.io/purescript-gesso/examples/interpolation/dist/) 40 | 41 | ![A black circle moves to the right, leaving a smooth trail. After one second, it changes to a white circle and leaves a choppy trail. The black and white circles alternate each second, moving back and forth, demonstrating the difference between motion that has been smoothed and motion that hasn't.](interpolation.gif) 42 | -------------------------------------------------------------------------------- /examples/interpolation/dist/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | Gesso Interpolation Example 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- /examples/interpolation/interpolation.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/smilack/purescript-gesso/d78e1ccdb17a838288b5c5a9207dd5ad22bac4ee/examples/interpolation/interpolation.gif -------------------------------------------------------------------------------- /examples/interpolation/spago.yaml: -------------------------------------------------------------------------------- 1 | package: 2 | dependencies: 3 | - canvas 4 | - effect 5 | - gesso 6 | - integers 7 | - maybe 8 | - numbers 9 | - prelude 10 | name: gesso-example-interpolation 11 | bundle: 12 | module: Gesso.Example.Interpolation 13 | outfile: "dist/example.js" 14 | -------------------------------------------------------------------------------- /examples/interpolation/src/Interpolation.purs: -------------------------------------------------------------------------------- 1 | module Gesso.Example.Interpolation (main) where 2 | 3 | import Prelude 4 | 5 | import Data.Int (trunc, parity, Parity(..)) 6 | import Data.Maybe (Maybe(..)) 7 | import Data.Number (abs, pi) 8 | import Effect (Effect) 9 | import Gesso (launch) as Gesso 10 | import Gesso.Application (defaultBehavior, WindowMode(..)) as GApp 11 | import Gesso.Geometry (Scalers, null) as GGeo 12 | import Gesso.State (States, lerp) as GSt 13 | import Gesso.Time (Delta, hz) as GTime 14 | import Graphics.Canvas as Canvas 15 | 16 | main :: Effect Unit 17 | main = Gesso.launch 18 | { name: "interpolation" 19 | , initialState 20 | , window: GApp.Fullscreen 21 | , viewBox: GGeo.null 22 | , behavior: GApp.defaultBehavior 23 | { render = render 24 | , fixed = { interval: GTime.hz 20.0, function: fixedUpdate } 25 | } 26 | } 27 | 28 | type Ball = 29 | { x :: Number 30 | , vx :: Number 31 | , y :: Number 32 | , r :: Number 33 | } 34 | 35 | type State = { ball :: Ball, seconds :: Number } 36 | 37 | initialState :: State 38 | initialState = 39 | { ball: { x: 75.0, y: 100.0, vx: 0.3, r: 50.0 } 40 | , seconds: 0.0 41 | } 42 | 43 | fixedUpdate :: GTime.Delta -> GGeo.Scalers -> State -> Effect (Maybe State) 44 | fixedUpdate { delta } { canvas } { ball, seconds } = do 45 | pure $ Just $ 46 | { ball: move { min, max } delta ball 47 | , seconds: seconds + delta / 1000.0 48 | } 49 | where 50 | min = canvas.x 51 | max = min + canvas.width 52 | 53 | move :: { min :: Number, max :: Number } -> Number -> Ball -> Ball 54 | move { min, max } dt ball@{ x, vx, r } = ball { x = x', vx = vx' } 55 | where 56 | x' = x + vx * dt 57 | vx' 58 | | x' + r + vx > max = 0.0 - abs vx 59 | | x' - r + vx < min = abs vx 60 | | otherwise = vx 61 | 62 | render 63 | :: Canvas.Context2D 64 | -> GTime.Delta 65 | -> GGeo.Scalers 66 | -> GSt.States State 67 | -> Effect Unit 68 | render context _ _ { previous, current: { ball, seconds }, t } = do 69 | Canvas.setLineWidth context 10.0 70 | Canvas.setStrokeStyle context color 71 | Canvas.strokePath context do 72 | Canvas.arc context 73 | { x 74 | , y 75 | , radius: ball.r 76 | , start: 0.0 77 | , end: 2.0 * pi 78 | , useCounterClockwise: false 79 | } 80 | where 81 | { x, y, color } = case parity $ trunc $ seconds of 82 | Even -> 83 | { x: GSt.lerp { t, previous: previous.ball.x, current: ball.x } 84 | , y: GSt.lerp { t, previous: previous.ball.y, current: ball.y } 85 | , color: "black" 86 | } 87 | Odd -> 88 | { x: ball.x 89 | , y: ball.y 90 | , color: "white" 91 | } 92 | -------------------------------------------------------------------------------- /examples/keyboard/README.md: -------------------------------------------------------------------------------- 1 | # Keyboard 2 | 3 | This example uses keyboard events to move a blue square around the page. Control the square with the arrow keys. 4 | 5 | ### Interactions 6 | 7 | This example modifies the default interactions record in `Gesso.Application.defaultBehavior` by adding two keyboard event handlers: 8 | 9 | ```purescript 10 | , behavior: GApp.defaultBehavior 11 | { render = render 12 | , update = update 13 | , interactions { keyboard = [ keyDown, keyUp ] } 14 | } 15 | ``` 16 | 17 | The event handlers have type `Gesso.Interactions.KeyboardInteraction State`. They're constructed using `on` functions from `Gesso.Interactions`. They both listen for key events, and update the state when an arrow key is pressed or released: 18 | 19 | ```purescript 20 | keyDown :: GInt.KeyboardInteraction State 21 | keyDown = GInt.onKeyDown $ setKey true 22 | 23 | keyUp :: GInt.KeyboardInteraction State 24 | keyUp = GInt.onKeyUp $ setKey false 25 | 26 | setKey :: Boolean -> KeyboardEvent -> Delta -> Scalers -> State -> Effect (Maybe State) 27 | setKey val event _ _ state = pure $ case KEv.key event of 28 | "ArrowUp" -> Just state { keys { up = val } } 29 | "ArrowDown" -> Just state { keys { down = val } } 30 | "ArrowLeft" -> Just state { keys { left = val } } 31 | "ArrowRight" -> Just state { keys { right = val } } 32 | _ -> Nothing 33 | ``` 34 | 35 | ## Sample output 36 | 37 | [See this example in action](https://smilack.github.io/purescript-gesso/examples/keyboard/dist/) 38 | -------------------------------------------------------------------------------- /examples/keyboard/dist/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | Gesso Keyboard Example 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- /examples/keyboard/output.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/smilack/purescript-gesso/d78e1ccdb17a838288b5c5a9207dd5ad22bac4ee/examples/keyboard/output.gif -------------------------------------------------------------------------------- /examples/keyboard/spago.yaml: -------------------------------------------------------------------------------- 1 | package: 2 | dependencies: 3 | - canvas 4 | - effect 5 | - gesso 6 | - maybe 7 | - prelude 8 | - web-uievents 9 | name: gesso-example-keyboard 10 | bundle: 11 | module: Gesso.Example.Keyboard 12 | outfile: "dist/example.js" 13 | -------------------------------------------------------------------------------- /examples/keyboard/src/Keyboard.purs: -------------------------------------------------------------------------------- 1 | module Gesso.Example.Keyboard (main) where 2 | 3 | import Prelude 4 | 5 | import Data.Maybe (Maybe(..)) 6 | import Effect (Effect) 7 | import Gesso (launch) as Gesso 8 | import Gesso.Application (WindowMode(..), defaultBehavior) as GApp 9 | import Gesso.Geometry (null, Scalers) as GGeo 10 | import Gesso.Interactions (KeyboardInteraction, KeyboardEvent, onKeyUp, onKeyDown) as GInt 11 | import Gesso.State (States) as GSt 12 | import Gesso.Time (Delta) as GTime 13 | import Graphics.Canvas as Canvas 14 | import Web.UIEvent.KeyboardEvent (key) as KEv 15 | 16 | main :: Effect Unit 17 | main = Gesso.launch 18 | { name: "keyboard" 19 | , initialState 20 | , viewBox: GGeo.null 21 | , window: GApp.Fullscreen 22 | , behavior: GApp.defaultBehavior 23 | { render = render 24 | , update = update 25 | , interactions { keyboard = [ keyDown, keyUp ] } 26 | } 27 | } 28 | 29 | type Keys = 30 | { up :: Boolean 31 | , down :: Boolean 32 | , left :: Boolean 33 | , right :: Boolean 34 | } 35 | 36 | type State = { x :: Number, y :: Number, keys :: Keys } 37 | 38 | v :: Number 39 | v = 3.0 40 | 41 | halfSide :: Number 42 | halfSide = 50.0 43 | 44 | initialState :: State 45 | initialState = 46 | { x: 1.5 * halfSide 47 | , y: 1.5 * halfSide 48 | , keys: { up: false, down: false, left: false, right: false } 49 | } 50 | 51 | keyDown :: GInt.KeyboardInteraction State 52 | keyDown = GInt.onKeyDown $ setKey true 53 | 54 | keyUp :: GInt.KeyboardInteraction State 55 | keyUp = GInt.onKeyUp $ setKey false 56 | 57 | setKey 58 | :: Boolean 59 | -> GInt.KeyboardEvent 60 | -> GTime.Delta 61 | -> GGeo.Scalers 62 | -> State 63 | -> Effect (Maybe State) 64 | setKey val event _ _ state = pure $ case KEv.key event of 65 | "ArrowUp" -> Just state { keys { up = val } } 66 | "ArrowDown" -> Just state { keys { down = val } } 67 | "ArrowLeft" -> Just state { keys { left = val } } 68 | "ArrowRight" -> Just state { keys { right = val } } 69 | _ -> Nothing 70 | 71 | update :: GTime.Delta -> GGeo.Scalers -> State -> Effect (Maybe State) 72 | update _ { canvas } state@{ x, y, keys: { up, down, left, right } } = 73 | pure $ Just state 74 | { x = updatePosition x canvas.x (canvas.x + canvas.width) vx 75 | , y = updatePosition y canvas.y (canvas.y + canvas.height) vy 76 | } 77 | where 78 | vx = getV left right 79 | vy = getV up down 80 | 81 | getV :: Boolean -> Boolean -> Number 82 | getV neg pos 83 | | neg && pos = 0.0 84 | | neg = -v 85 | | pos = v 86 | | otherwise = 0.0 87 | 88 | updatePosition :: Number -> Number -> Number -> Number -> Number 89 | updatePosition pos min max velocity 90 | | pos + halfSide + velocity > max = pos 91 | | pos - halfSide + velocity < min = pos 92 | | otherwise = pos + velocity 93 | 94 | render 95 | :: Canvas.Context2D 96 | -> GTime.Delta 97 | -> GGeo.Scalers 98 | -> GSt.States State 99 | -> Effect Unit 100 | render context _ { canvas } { current: { x, y } } = do 101 | Canvas.clearRect context canvas.rect 102 | Canvas.setFillStyle context "blue" 103 | Canvas.fillRect context 104 | { x: x - halfSide 105 | , y: y - halfSide 106 | , width: halfSide * 2.0 107 | , height: halfSide * 2.0 108 | } 109 | -------------------------------------------------------------------------------- /examples/mouse-and-scaling/README.md: -------------------------------------------------------------------------------- 1 | # Mouse and Scaling 2 | 3 | This example shows a grid from `-1` to `1` on both the x and y axes, with lines at increments of `0.1`. Clicking anywhere on the canvas - in or out of the grid - places a crosshair and shows the coordinates of the spot clicked. 4 | 5 | ### View box 6 | 7 | This example uses an unusual view box: ranging from `-1.5` to `1.5` on both axes: 8 | 9 | ```purescript 10 | , viewBox: { x: -1.5, y: -1.5, width: 3.0, height: 3.0 } 11 | ``` 12 | 13 | The grid occupies part of that: `-1` to `1` on both axes. 14 | 15 | ### Scaling 16 | 17 | Clicking anywhere on the canvas displays the coordinates, from the drawing's perspective, of the clicked location. This includes areas outside of the view box: because the drawing scales to fit the canvas while maintaining its aspect ratio, there will be a margin either horizontally or vertically. The coordinates displayed are the location that the click would be if the view box extended infinitely in all directions. 18 | 19 | Try clicking near the edges of the canvas to get a feel for the scaling. 20 | 21 | The application stores the canvas coordinates of the clicked location, and converts them to drawing coordinates when rendering. Try clicking somewhere and resizing your browser window to watch the coordinates update as the scaling factors change. 22 | 23 | ### Interactions 24 | 25 | This example uses `onMouseMove` and `onMouseDown` from `Gesso.Interactions` and `Gesso.Geometry.fromMouseEvent` to detect and track mouse events. 26 | 27 | ## Sample output 28 | 29 | [See this example in action](https://smilack.github.io/purescript-gesso/examples/mouse-and-scaling/dist/) 30 | 31 | ![A square Cartesian graph where each quadrant is a 10 by 10 grid. There is a circled crosshair in the middle of the upper right quadrant. Above the graph, there is text that says "Clicked: (0.498, -0.502)"](mouse-and-scaling.png) 32 | -------------------------------------------------------------------------------- /examples/mouse-and-scaling/dist/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | Gesso Mouse and Scaling Example 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- /examples/mouse-and-scaling/mouse-and-scaling.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/smilack/purescript-gesso/d78e1ccdb17a838288b5c5a9207dd5ad22bac4ee/examples/mouse-and-scaling/mouse-and-scaling.png -------------------------------------------------------------------------------- /examples/mouse-and-scaling/spago.yaml: -------------------------------------------------------------------------------- 1 | package: 2 | dependencies: 3 | - arrays 4 | - canvas 5 | - effect 6 | - foldable-traversable 7 | - gesso 8 | - integers 9 | - maybe 10 | - numbers 11 | - prelude 12 | name: gesso-example-mouse-and-scaling 13 | bundle: 14 | module: Gesso.Example.MouseAndScaling 15 | outfile: "dist/example.js" 16 | -------------------------------------------------------------------------------- /examples/mouse-and-scaling/src/MouseAndScaling.purs: -------------------------------------------------------------------------------- 1 | module Gesso.Example.MouseAndScaling (main) where 2 | 3 | import Prelude 4 | 5 | import Data.Array (range) 6 | import Data.Foldable (traverse_) 7 | import Data.Int (toNumber, floor, round) 8 | import Data.Maybe (Maybe(..)) 9 | import Data.Number (tau) 10 | import Effect (Effect) 11 | import Gesso (launch) as Gesso 12 | import Gesso.Application (WindowMode(..), defaultBehavior) as GApp 13 | import Gesso.Geometry (yTo, xTo, lengthTo, to) 14 | import Gesso.Geometry (fromMouseEvent, Scalers, Point) as GGeo 15 | import Gesso.Interactions (onMouseMove, onMouseDown, MouseInteraction) as GInt 16 | import Gesso.Time (Delta) as GTime 17 | import Gesso.State (States) as GSt 18 | import Graphics.Canvas as Canvas 19 | 20 | main :: Effect Unit 21 | main = Gesso.launch 22 | { name: "test-app" 23 | , initialState 24 | , window: GApp.Fullscreen 25 | , viewBox: { x: -1.5, y: -1.5, width: 3.0, height: 3.0 } 26 | , behavior: 27 | GApp.defaultBehavior 28 | { render = render 29 | , interactions { mouse = [ mousePosition, mouseDown ] } 30 | } 31 | } 32 | 33 | type State = 34 | { mousePos :: Maybe GGeo.Point 35 | , clicked :: Maybe GGeo.Point 36 | } 37 | 38 | initialState :: State 39 | initialState = 40 | { mousePos: Nothing 41 | , clicked: Nothing 42 | } 43 | 44 | mousePosition :: GInt.MouseInteraction State 45 | mousePosition = GInt.onMouseMove set 46 | where 47 | set event _ _ state = 48 | pure $ Just $ state { mousePos = Just $ GGeo.fromMouseEvent event } 49 | 50 | mouseDown :: GInt.MouseInteraction State 51 | mouseDown = GInt.onMouseDown set 52 | where 53 | set event _ _ state = 54 | pure $ Just $ state { clicked = Just $ GGeo.fromMouseEvent event } 55 | 56 | render 57 | :: Canvas.Context2D 58 | -> GTime.Delta 59 | -> GGeo.Scalers 60 | -> GSt.States State 61 | -> Effect Unit 62 | render context _ { canvas, drawing } { current: { clicked, mousePos } } = do 63 | clearBackground 64 | drawAxes 65 | drawGridLines 66 | drawMouseClicked clicked 67 | traverse_ drawMouseCursor mousePos 68 | where 69 | clearBackground :: Effect Unit 70 | clearBackground = do 71 | Canvas.setFillStyle context "white" 72 | Canvas.fillRect context canvas.rect 73 | 74 | drawAxes :: Effect Unit 75 | drawAxes = do 76 | Canvas.setStrokeStyle context "black" 77 | Canvas.setLineWidth context $ 0.015 `lengthTo` canvas 78 | drawCross ({ x: 0.0, y: 0.0 } `to` canvas) 1.0 79 | 80 | drawGridLines :: Effect Unit 81 | drawGridLines = do 82 | Canvas.setStrokeStyle context "black" 83 | Canvas.setLineWidth context $ 0.005 `lengthTo` canvas 84 | traverse_ drawGridLine $ range 1 10 85 | 86 | drawGridLine :: Int -> Effect Unit 87 | drawGridLine i = do 88 | Canvas.strokePath context do 89 | Canvas.moveTo context (-n `xTo` canvas) (-1.0 `yTo` canvas) 90 | Canvas.lineTo context (-n `xTo` canvas) (1.0 `yTo` canvas) 91 | Canvas.moveTo context (n `xTo` canvas) (-1.0 `yTo` canvas) 92 | Canvas.lineTo context (n `xTo` canvas) (1.0 `yTo` canvas) 93 | Canvas.moveTo context (-1.0 `xTo` canvas) (-n `yTo` canvas) 94 | Canvas.lineTo context (1.0 `xTo` canvas) (-n `yTo` canvas) 95 | Canvas.moveTo context (-1.0 `xTo` canvas) (n `yTo` canvas) 96 | Canvas.lineTo context (1.0 `xTo` canvas) (n `yTo` canvas) 97 | where 98 | n = (_ / 10.0) <<< toNumber $ i 99 | 100 | drawMouseClicked :: Maybe GGeo.Point -> Effect Unit 101 | drawMouseClicked mxy = do 102 | Canvas.setFont context $ size <> "px 'Courier New'" 103 | Canvas.setFillStyle context "black" 104 | Canvas.setTextAlign context Canvas.AlignCenter 105 | Canvas.fillText context 106 | ("Clicked: (" <> text) 107 | (0.0 `xTo` canvas) 108 | (-1.1 `yTo` canvas) 109 | case mxy of 110 | Nothing -> pure unit 111 | Just p -> do 112 | Canvas.setStrokeStyle context "black" 113 | Canvas.setLineWidth context $ 0.01 `lengthTo` canvas 114 | Canvas.strokePath context do 115 | Canvas.arc context 116 | { x: p.x 117 | , y: p.y 118 | , radius: 0.05 `lengthTo` canvas 119 | , start: 0.0 120 | , end: tau 121 | , useCounterClockwise: false 122 | } 123 | drawCross p 0.05 124 | where 125 | size = show $ floor $ 0.2 `lengthTo` canvas 126 | 127 | x' = round3 <<< (_ `xTo` drawing) 128 | 129 | y' = round3 <<< (_ `yTo` drawing) 130 | 131 | round3 = (_ / 1000.0) <<< toNumber <<< round <<< (_ * 1000.0) 132 | 133 | text = case mxy of 134 | Nothing -> "Nothing)" 135 | Just p -> show (x' p.x) <> ", " <> show (y' p.y) <> ")" 136 | 137 | drawMouseCursor :: GGeo.Point -> Effect Unit 138 | drawMouseCursor point = do 139 | Canvas.setStrokeStyle context "black" 140 | Canvas.setLineWidth context $ 0.01 `lengthTo` canvas 141 | drawCross point 0.05 142 | 143 | drawCross :: { x :: Number, y :: Number } -> Number -> Effect Unit 144 | drawCross { x, y } length = do 145 | Canvas.strokePath context do 146 | let l = length `lengthTo` canvas 147 | Canvas.moveTo context (x - l) y 148 | Canvas.lineTo context (x + l) y 149 | Canvas.moveTo context x (y - l) 150 | Canvas.lineTo context x (y + l) 151 | -------------------------------------------------------------------------------- /examples/paint-app/README.md: -------------------------------------------------------------------------------- 1 | # Paint App 2 | 3 | This example shows how to use a Gesso component inside a Halogen application to make a small drawing app. It uses Halogen queries to communicate with the parent component. 4 | 5 | ### Structure 6 | 7 | `Root` is the main component. It contains the Gesso component (`Grid`) and four button components (`ColorButton`). It keeps track of the color of the pixels in the drawing and the order that they changed colors, in order to provide undo and redo features. 8 | 9 | `ColorButton` renders a button element for selecting a color to draw with. It emits an `Output` when clicked. 10 | 11 | `Grid` wraps the Gesso canvas. It uses this `AppSpec`: 12 | 13 | ```purescript 14 | , behavior: GApp.defaultBehavior 15 | { render = renderApp 16 | , output = extractOutput 17 | , input = convertState 18 | , interactions 19 | { mouse = [ highlightCell, clearHighlight, mouseDown, mouseUp ] 20 | } 21 | } 22 | ``` 23 | 24 | When the canvas state changes, `extractOutput` is called with a `Gesso.State.Compare` record. If this returns a `Just` value, Gesso automatically calls `Halogen.raise` to send output to `Root`. 25 | 26 | When `Root` sends a query to `Grid` with `Halogen.tell`, `Grid` reacts to the query with `convertState`. 27 | 28 | ### Layout 29 | 30 | This example uses a view box from `0` to `32` in both axes to simplify coloring individual squares. 31 | 32 | It also uses a fixed, 600 by 600 pixel size. 33 | 34 | ### Scaling operators 35 | 36 | This example uses the operator aliases for scaling functions: 37 | 38 | ```purescript 39 | x = floor $ point.x -~> drawing 40 | 41 | y = floor $ point.y |~> drawing 42 | 43 | Canvas.setLineWidth context $ 0.05 /~> canvas 44 | 45 | Canvas.fillRect context $ 46 | { x: toNumber x, y: toNumber y, width: 1.0, height: 1.0 } *~> canvas 47 | ``` 48 | 49 | ## Output 50 | 51 | [See this example in action](https://smilack.github.io/purescript-gesso/examples/paint-app/dist/) 52 | 53 | ![A small drawing application. On the left, there are four buttons to pick a shade of gray to draw with. On the right, there are undo and redo buttons and a list of colors and coordinates showing the order that pixels were given a color. At the bottom, a checkbox with the label "Show Grid" is checked. In the middle, a canvas divided into a 32 by 32 grid has the word "example" written on it in various shades of gray.](paint-app.png) 54 | -------------------------------------------------------------------------------- /examples/paint-app/dist/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | Gesso Paint App Example 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- /examples/paint-app/paint-app.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/smilack/purescript-gesso/d78e1ccdb17a838288b5c5a9207dd5ad22bac4ee/examples/paint-app/paint-app.png -------------------------------------------------------------------------------- /examples/paint-app/spago.yaml: -------------------------------------------------------------------------------- 1 | package: 2 | dependencies: 3 | - aff 4 | - arrays 5 | - canvas 6 | - dom-indexed 7 | - effect 8 | - foldable-traversable 9 | - gesso 10 | - halogen 11 | - integers 12 | - lists 13 | - maybe 14 | - prelude 15 | - record 16 | name: gesso-example-paint-app 17 | bundle: 18 | module: Gesso.Example.PaintApp 19 | outfile: "dist/example.js" 20 | -------------------------------------------------------------------------------- /examples/paint-app/src/ColorButton.purs: -------------------------------------------------------------------------------- 1 | module Gesso.Example.PaintApp.ColorButton 2 | ( Slot 3 | , Output(..) 4 | , _colorButton 5 | , component 6 | ) where 7 | 8 | import Prelude 9 | import Data.Maybe (Maybe(..)) 10 | import Halogen as H 11 | import Halogen.HTML as HH 12 | import Halogen.HTML.Events (onClick) 13 | import Halogen.HTML.Properties as HP 14 | import Type.Proxy (Proxy(..)) 15 | 16 | type Slot slot = forall q. H.Slot q Output slot 17 | 18 | _colorButton = Proxy :: Proxy "colorButton" 19 | 20 | type State = { color :: String, selected :: String } 21 | 22 | type Input = State 23 | 24 | data Output = Clicked String 25 | 26 | data Action 27 | = ClickedAction String 28 | | Update Input 29 | 30 | component :: forall q m. H.Component q Input Output m 31 | component = 32 | H.mkComponent 33 | { initialState: identity 34 | , render 35 | , eval: H.mkEval $ H.defaultEval 36 | { handleAction = handleAction 37 | , receive = Just <<< Update 38 | } 39 | } 40 | 41 | render :: forall s m. State -> H.ComponentHTML Action s m 42 | render { color, selected } = 43 | HH.button 44 | [ onClick \_ -> ClickedAction color 45 | , style 46 | $ ("background-color: " <> color <> ";") 47 | <> "width: 72px;" 48 | <> "height: 72px;" 49 | <> "margin: 6px 12px;" 50 | <> "cursor: pointer;" 51 | <> selectedStyle 52 | ] 53 | [] 54 | where 55 | selectedStyle = 56 | if selected == color then 57 | "outline: 4px #2196f3 solid;" 58 | else 59 | "" 60 | 61 | style :: forall r i. String -> HP.IProp r i 62 | style = HP.attr (HH.AttrName "style") 63 | 64 | handleAction :: forall s m. Action -> H.HalogenM State Action s Output m Unit 65 | handleAction = case _ of 66 | ClickedAction state -> H.raise $ Clicked state 67 | Update state -> H.put state 68 | -------------------------------------------------------------------------------- /examples/paint-app/src/Grid.purs: -------------------------------------------------------------------------------- 1 | module Gesso.Example.PaintApp.Grid 2 | ( CanvasIO 3 | , CanvasIO' 4 | , Pixel(..) 5 | , Slot 6 | , component 7 | , publicInitialState 8 | ) where 9 | 10 | import Prelude 11 | 12 | import Data.Array (range) 13 | import Data.Foldable (sequence_, traverse_, length) 14 | import Data.Int (floor, toNumber) 15 | import Data.List (List(..), (:), reverse, head) 16 | import Data.Maybe (Maybe(..)) 17 | import Effect (Effect) 18 | import Effect.Aff.Class (class MonadAff) 19 | import Gesso.Application as GApp 20 | import Gesso.Canvas as GC 21 | import Gesso.Geometry ((-~>), (|~>), (*~>), (/~>)) 22 | import Gesso.Geometry as GGeo 23 | import Gesso.Interactions as GInt 24 | import Gesso.State as GSt 25 | import Gesso.Time as GTime 26 | import Graphics.Canvas as Canvas 27 | import Halogen.HTML as HH 28 | import Record (merge) as Record 29 | 30 | type CanvasIO = { | CanvasIO' () } 31 | 32 | -- These are all the things that Root needs to know. If Root is aware 33 | -- of mouseCell, it changes the global state too often, causing lag. 34 | type CanvasIO' r = 35 | ( showGrid :: Boolean 36 | , color :: String 37 | , pixels :: List Pixel 38 | , redo :: List Pixel 39 | | r 40 | ) 41 | 42 | type CanvasState = 43 | { 44 | | CanvasIO' 45 | ( mouseCell :: Maybe { x :: Int, y :: Int } 46 | , clicked :: Maybe { x :: Number, y :: Number } 47 | , mouseDown :: Boolean 48 | ) 49 | } 50 | 51 | newtype Pixel = Pixel { x :: Int, y :: Int, color :: String } 52 | 53 | derive instance eqPixel :: Eq Pixel 54 | 55 | type Slot s = (gessoCanvas :: GC.Slot CanvasIO CanvasIO Unit | s) 56 | 57 | component 58 | :: forall action slots m 59 | . MonadAff m 60 | => (GC.CanvasOutput CanvasIO -> action) 61 | -> HH.ComponentHTML action (Slot slots) m 62 | component action = HH.slot GC._gessoCanvas unit GC.component appSpec action 63 | 64 | publicInitialState :: CanvasIO 65 | publicInitialState = 66 | { showGrid: true 67 | , color: "black" 68 | , pixels: Nil 69 | , redo: Nil 70 | } 71 | 72 | localState :: CanvasState 73 | localState = 74 | Record.merge publicInitialState 75 | { mouseCell: Nothing 76 | , clicked: Nothing 77 | , mouseDown: false 78 | } 79 | 80 | appSpec :: GApp.AppSpec CanvasState CanvasIO CanvasIO 81 | appSpec = 82 | { name: "canvas" 83 | , initialState: localState 84 | , window: GApp.Fixed { width: 600.0, height: 600.0 } 85 | , viewBox: { x: 0.0, y: 0.0, width: 32.0, height: 32.0 } 86 | , behavior: GApp.defaultBehavior 87 | { render = renderApp 88 | , output = extractOutput 89 | , input = convertState 90 | , interactions 91 | { mouse = [ highlightCell, clearHighlight, mouseDown, mouseUp ] 92 | } 93 | } 94 | } 95 | 96 | convertState 97 | :: forall delta scaler r s 98 | . { | CanvasIO' r } 99 | -> delta 100 | -> scaler 101 | -> { | CanvasIO' s } 102 | -> Effect (Maybe { | CanvasIO' s }) 103 | convertState { showGrid, color, pixels, redo } _ _ = pure 104 | <<< Just 105 | <<< _ { showGrid = showGrid, color = color, pixels = pixels, redo = redo } 106 | 107 | extractOutput 108 | :: GTime.Delta 109 | -> GGeo.Scalers 110 | -> GSt.Compare CanvasState 111 | -> Effect (Maybe CanvasIO) 112 | extractOutput _ _ { old, new: { showGrid, color, pixels, redo } } = 113 | pure $ 114 | if 115 | (old.showGrid /= showGrid) 116 | || (old.color /= color) 117 | || (length old.pixels /= (length pixels :: Int)) 118 | || (length old.redo /= (length redo :: Int)) then 119 | Just { showGrid, color, pixels, redo } 120 | else 121 | Nothing 122 | 123 | highlightCell :: GInt.MouseInteraction CanvasState 124 | highlightCell = GInt.onMouseMove getMousePos 125 | where 126 | getMousePos event _ scaler state = pure $ 127 | let 128 | { x, y } = toXY event scaler 129 | 130 | p = Pixel { x, y, color: state.color } 131 | in 132 | if state.mouseDown then case head state.pixels of 133 | Nothing -> Just 134 | state { mouseCell = Just { x, y }, pixels = p : state.pixels } 135 | Just pixel -> 136 | if p == pixel then 137 | if state.mouseCell == Just { x, y } then 138 | Nothing 139 | else 140 | Just state { mouseCell = Just { x, y } } 141 | else 142 | Just state { mouseCell = Just { x, y }, pixels = p : state.pixels } 143 | else if state.mouseCell == Just { x, y } then 144 | Nothing 145 | else 146 | Just state { mouseCell = Just { x, y } } 147 | 148 | toXY :: GInt.MouseEvent -> GGeo.Scalers -> { x :: Int, y :: Int } 149 | toXY event { drawing } = 150 | let 151 | point = GGeo.fromMouseEvent event 152 | 153 | x = floor $ point.x -~> drawing 154 | 155 | y = floor $ point.y |~> drawing 156 | in 157 | { x, y } 158 | 159 | clearHighlight :: GInt.MouseInteraction CanvasState 160 | clearHighlight = 161 | GInt.onMouseOut (\_ _ _ s -> pure $ Just s { mouseCell = Nothing }) 162 | 163 | mouseDown :: GInt.MouseInteraction CanvasState 164 | mouseDown = GInt.onMouseDown startDrawing 165 | where 166 | startDrawing event _ scaler state = pure $ 167 | let 168 | { x, y } = toXY event scaler 169 | 170 | p = Pixel { x, y, color: state.color } 171 | in 172 | Just state { pixels = p : state.pixels, redo = Nil, mouseDown = true } 173 | 174 | mouseUp :: GInt.MouseInteraction CanvasState 175 | mouseUp = GInt.onMouseUp (\_ _ _ s -> pure $ Just s { mouseDown = false }) 176 | 177 | renderApp 178 | :: Canvas.Context2D 179 | -> GTime.Delta 180 | -> GGeo.Scalers 181 | -> GSt.States CanvasState 182 | -> Effect Unit 183 | renderApp context _ { canvas } { current } = do 184 | let { mouseCell, showGrid } = current 185 | clearBackground 186 | drawOutline 187 | when showGrid drawGrid 188 | drawImage 189 | traverse_ drawCursor mouseCell 190 | where 191 | clearBackground :: Effect Unit 192 | clearBackground = do 193 | Canvas.setFillStyle context "white" 194 | Canvas.fillRect context canvas.rect 195 | 196 | drawOutline :: Effect Unit 197 | drawOutline = do 198 | Canvas.setLineWidth context $ 0.05 /~> canvas 199 | Canvas.setStrokeStyle context "#888" 200 | Canvas.strokeRect context canvas.rect 201 | 202 | drawGrid :: Effect Unit 203 | drawGrid = do 204 | Canvas.setStrokeStyle context "#ccc" 205 | sequence_ $ map drawGridLine $ range 1 31 206 | 207 | drawGridLine :: Int -> Effect Unit 208 | drawGridLine i = do 209 | Canvas.strokePath context do 210 | Canvas.moveTo context (n -~> canvas) (0.0 |~> canvas) 211 | Canvas.lineTo context (n -~> canvas) (32.0 |~> canvas) 212 | Canvas.moveTo context (0.0 -~> canvas) (n |~> canvas) 213 | Canvas.lineTo context (32.0 -~> canvas) (n |~> canvas) 214 | where 215 | n = toNumber i 216 | 217 | drawCursor :: { x :: Int, y :: Int } -> Effect Unit 218 | drawCursor { x, y } = drawPixel $ Pixel { x, y, color: current.color } 219 | 220 | drawImage :: Effect Unit 221 | drawImage = sequence_ $ map drawPixel $ reverse current.pixels 222 | 223 | drawPixel :: Pixel -> Effect Unit 224 | drawPixel (Pixel { x, y, color: c }) = do 225 | Canvas.setFillStyle context c 226 | Canvas.fillRect context $ 227 | { x: toNumber x, y: toNumber y, width: 1.0, height: 1.0 } *~> canvas 228 | -------------------------------------------------------------------------------- /examples/paint-app/src/PaintApp.purs: -------------------------------------------------------------------------------- 1 | module Gesso.Example.PaintApp (main) where 2 | 3 | import Prelude 4 | import Effect (Effect) 5 | import Halogen.Aff (runHalogenAff, awaitBody) 6 | import Halogen.VDom.Driver (runUI) 7 | import Gesso.Example.PaintApp.Root as Root 8 | 9 | main :: Effect Unit 10 | main = 11 | runHalogenAff do 12 | body <- awaitBody 13 | runUI Root.component unit body 14 | -------------------------------------------------------------------------------- /examples/paint-app/src/Root.purs: -------------------------------------------------------------------------------- 1 | module Gesso.Example.PaintApp.Root (component) where 2 | 3 | import Prelude 4 | 5 | import DOM.HTML.Indexed.InputType (InputType(..)) 6 | import Data.Array (fromFoldable) 7 | import Data.List (List(..), (:), tail, reverse, head) 8 | import Data.Maybe (Maybe(..), fromMaybe) 9 | import Effect.Aff.Class (class MonadAff) 10 | import Gesso.Example.PaintApp.ColorButton as CB 11 | import Gesso.Example.PaintApp.Grid (CanvasIO) 12 | import Gesso.Example.PaintApp.Grid as Grid 13 | import Gesso.Canvas as GC 14 | import Halogen as H 15 | import Halogen.HTML as HH 16 | import Halogen.HTML.Events as HE 17 | import Halogen.HTML.Properties as HP 18 | 19 | type Slots = 20 | ( colorButton :: CB.Slot Int 21 | | Grid.Slot () 22 | ) 23 | 24 | data Action 25 | = ButtonClicked CB.Output 26 | | Undo 27 | | Redo 28 | | ToggleGrid 29 | | GotOutput (GC.CanvasOutput CanvasIO) 30 | 31 | component 32 | :: forall q i o m 33 | . MonadAff m 34 | => H.Component q i o m 35 | component = H.mkComponent 36 | { initialState: const Grid.publicInitialState 37 | , render 38 | , eval: H.mkEval $ H.defaultEval { handleAction = handleAction } 39 | } 40 | 41 | render :: forall m. MonadAff m => CanvasIO -> H.ComponentHTML Action Slots m 42 | render state = 43 | HH.div 44 | [ style styles.root ] 45 | [ colorPicker 46 | , drawing 47 | , undoRedoHistory 48 | ] 49 | where 50 | colorPicker = 51 | HH.div [ style styles.colorPicker ] 52 | [ HH.slot CB._colorButton 0 CB.component (picker "black") ButtonClicked 53 | , HH.slot CB._colorButton 1 CB.component (picker "#888") ButtonClicked 54 | , HH.slot CB._colorButton 2 CB.component (picker "#ccc") ButtonClicked 55 | , HH.slot CB._colorButton 3 CB.component (picker "white") ButtonClicked 56 | ] 57 | 58 | picker = { selected: state.color, color: _ } 59 | 60 | drawing = 61 | HH.div [ style styles.canvas ] 62 | [ Grid.component GotOutput 63 | , HH.label [ style styles.label ] 64 | [ HH.input 65 | [ HP.type_ InputCheckbox 66 | , HE.onClick (const ToggleGrid) 67 | , HP.checked state.showGrid 68 | ] 69 | , HH.span_ [ HH.text "Show Grid" ] 70 | ] 71 | ] 72 | 73 | undoRedoHistory = 74 | HH.div 75 | [ style styles.history ] 76 | [ HH.button [ HE.onClick (const Undo), style styles.control ] 77 | [ HH.text "⟲ Undo" ] 78 | , HH.button [ HE.onClick (const Redo), style styles.control ] 79 | [ HH.text "⟳ Redo" ] 80 | , HH.ul 81 | [ style "list-style-type: none;" ] 82 | $ history styles.redo (reverse state.redo) 83 | <> 84 | [ HH.li [ style styles.place ] 85 | [ HH.span [ style styles.line ] [] ] 86 | ] 87 | <> history "" state.pixels 88 | ] 89 | 90 | history sty pixels = fromFoldable $ map listItem pixels 91 | where 92 | listItem (Grid.Pixel { x, y, color }) = 93 | HH.li [] 94 | [ pixelBlock color 95 | , HH.span [ style sty ] 96 | [ HH.text $ " (" <> show x <> ", " <> show y <> ")" ] 97 | ] 98 | 99 | pixelBlock color = 100 | HH.span 101 | [ style 102 | $ "display: inline-block;" 103 | <> "width: 10px;" 104 | <> "height: 10px;" 105 | <> "border: 1px black solid;" 106 | <> ("background-color: " <> color) 107 | ] 108 | [] 109 | 110 | style :: forall r i. String -> HP.IProp r i 111 | style = HP.attr (HH.AttrName "style") 112 | 113 | styles = 114 | { root: "display: flex; font-family: sans-serif; justify-content: center;" 115 | , colorPicker: "display: flex; flex-direction: column;" 116 | , canvas: "display: flex; flex-direction: column; margin: 6px 0; align-items: center;" 117 | , label: "display: block; margin: 6px 0; font-size: 24px; cursor: pointer;" 118 | , history: "margin: 6px 12px; max-height: 600px; overflow: hidden scroll;" 119 | , control: "font-size: 24px;" 120 | , redo: "opacity: 0.33;" 121 | , place: "padding-left: 3px; list-style-type: '⮞';" 122 | , line: "display: inline-block; width: 100%; height: 2px; background-color: black; vertical-align: middle; margin-bottom: 2px;" 123 | } 124 | 125 | send 126 | :: forall o m 127 | . MonadAff m 128 | => CanvasIO 129 | -> H.HalogenM CanvasIO Action Slots o m Unit 130 | send state = do 131 | H.tell GC._gessoCanvas unit $ GC.CanvasInput $ toIO state 132 | pure unit 133 | 134 | handleAction 135 | :: forall o m 136 | . MonadAff m 137 | => Action 138 | -> H.HalogenM CanvasIO Action Slots o m Unit 139 | handleAction = case _ of 140 | ToggleGrid -> 141 | (H.modify \s -> s { showGrid = not s.showGrid } :: CanvasIO) >>= send 142 | GotOutput (GC.CanvasOutput output') -> H.put output' 143 | ButtonClicked (CB.Clicked color') -> 144 | H.modify (_ { color = color' }) >>= send 145 | Undo -> do 146 | state <- H.get 147 | let 148 | step = head state.pixels 149 | 150 | pixels' = fromMaybe Nil $ tail state.pixels 151 | case step of 152 | Nothing -> pure unit 153 | Just pixel -> do 154 | let 155 | redo' = pixel : state.redo 156 | H.modify (_ { pixels = pixels', redo = redo' }) >>= send 157 | Redo -> do 158 | state <- H.get 159 | let 160 | step = head state.redo 161 | 162 | redo' = fromMaybe Nil $ tail state.redo 163 | case step of 164 | Nothing -> pure unit 165 | Just pixel -> do 166 | let 167 | pixels' = pixel : state.pixels 168 | 169 | state' = state { pixels = pixels', redo = redo' } 170 | H.put state' 171 | send state' 172 | 173 | toIO :: forall r. { | Grid.CanvasIO' r } -> CanvasIO 174 | toIO { showGrid, color, pixels, redo } = { showGrid, color, pixels, redo } 175 | -------------------------------------------------------------------------------- /examples/timing/README.md: -------------------------------------------------------------------------------- 1 | # Timing 2 | 3 | This example demonstrates the difference between the timing of per-frame and fixed-rate updates using a graph of the frequency (Hz/frames per second) that the `delta` time value corresponds to. 4 | 5 | It begins on the left and moves to the right, and when it reaches the right edge of the view box it restarts from the left, overwriting the old chart. 6 | 7 | ### Update function 8 | 9 | The two update types share a function in this example: 10 | 11 | ```purescript 12 | behavior: defaultBehavior 13 | { render = render 14 | , update = saveDelta @"reg" 15 | , fixed = 16 | { interval: hz 60.0 17 | , function: saveDelta @"fixed" 18 | } 19 | } 20 | ``` 21 | 22 | ```purescript 23 | saveDelta :: forall @l t r. IsSymbol l => Cons l Number t r => 24 | Delta -> Scaler -> { | r } -> Effect (Maybe { | r }) 25 | saveDelta { delta } _ = pure <<< Just <<< set (Proxy @l) delta 26 | ``` 27 | 28 | This uses a `Proxy` representing a key of the state record to set that key's value to the `delta` from the `Delta` record. 29 | 30 | ### `TextMetrics` 31 | 32 | This example uses custom definitions for [`TextMetrics`](https://developer.mozilla.org/en-US/docs/Web/API/TextMetrics) and [`measureText`](https://developer.mozilla.org/en-US/docs/Web/API/CanvasRenderingContext2D/measureText) to clear the canvas behind the text (most of the canvas is not refreshed each frame, but text gets messy if it's drawn on top of other text). 33 | 34 | Most of the `TextMetrics` attributes are relative to the text alignment and baseline of the canvas, so `toRelativeBoundingRect` converts them into a rectangle: 35 | 36 | ```purescript 37 | toRelativeBoundingRect :: TextMetrics -> Rect 38 | toRelativeBoundingRect 39 | { actualBoundingBoxLeft 40 | , actualBoundingBoxRight 41 | , actualBoundingBoxAscent 42 | , actualBoundingBoxDescent 43 | } = 44 | { x: -actualBoundingBoxLeft 45 | , y: -actualBoundingBoxAscent 46 | , width: actualBoundingBoxRight + actualBoundingBoxLeft 47 | , height: actualBoundingBoxDescent + actualBoundingBoxAscent 48 | } 49 | ``` 50 | 51 | This rectangle is in canvas coordinates and relative to the coordinates of the text, so it needs to be shifted by the position of the text after scaling to the canvas: 52 | 53 | ```purescript 54 | let { x, y } = position *~> canvas 55 | relative@{ width, height } <- toRelativeBoundingRect <$> measureText ctx text 56 | clearRect ctx { width, height, x: x + relative.x, y: y + relative.y } 57 | fillText ctx text x y 58 | ``` 59 | 60 | ## Sample output 61 | 62 | [See this example in action](https://smilack.github.io/purescript-gesso/examples/timing/dist/) 63 | 64 | ![Two long horizontal graphs of lines moving to the right. One graph is above the other. The upper one is labeled "Fixed update (60 Hz)" and the lower is labeled "Per-frame update." A heading for both graphs says "delta t received by update functions." Both graphs have markings for 75 Hz, 60 Hz, and 50 Hz. The "fixed update" graph has a perfectly flat line at 60 Hz. The "per-frame update" graph has a mostly flat line at 60 Hz, but there are six small downward spikes, spaced mostly evenly, to around 55 Hz, and a large downward spike below 50 Hz immediately followed by a large upward spike above 75 Hz.](timing.png) 65 | -------------------------------------------------------------------------------- /examples/timing/dist/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | Gesso Timing Example 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- /examples/timing/spago.yaml: -------------------------------------------------------------------------------- 1 | package: 2 | dependencies: 3 | - canvas 4 | - effect 5 | - foldable-traversable 6 | - gesso 7 | - maybe 8 | - numbers 9 | - prelude 10 | - record 11 | name: gesso-example-timing 12 | bundle: 13 | module: Gesso.Example.Timing 14 | outfile: "dist/example.js" 15 | -------------------------------------------------------------------------------- /examples/timing/src/Timing.js: -------------------------------------------------------------------------------- 1 | export function _now() { 2 | return performance.now(); 3 | } 4 | 5 | export function measureTextImpl(ctx, text) { 6 | return ctx.measureText(text); 7 | } 8 | -------------------------------------------------------------------------------- /examples/timing/src/Timing.purs: -------------------------------------------------------------------------------- 1 | module Gesso.Example.Timing where 2 | 3 | import Prelude 4 | 5 | import Data.Foldable (for_) 6 | import Data.Maybe (Maybe(..)) 7 | import Data.Number ((%)) 8 | import Data.Symbol (class IsSymbol) 9 | import Effect (Effect) 10 | import Effect.Uncurried (EffectFn2, runEffectFn2) 11 | import Gesso (launch) 12 | import Gesso.Application (WindowMode(..), defaultBehavior) 13 | import Gesso.Geometry (Rect, Scaler, Scalers, (*~>), (-~>), (/~>), (<~*), origin) 14 | import Gesso.State (States) 15 | import Gesso.Time (Delta, hz) 16 | import Graphics.Canvas (Context2D, clearRect, fillText, lineTo, moveTo, setFillStyle, setFont, setStrokeStyle, strokePath, setTextBaseline, TextBaseline(..)) 17 | import Prim.Row (class Cons) 18 | import Record (set, merge) 19 | import Type.Proxy (Proxy(..)) 20 | 21 | main :: Effect Unit 22 | main = do 23 | start <- _now 24 | launch 25 | { name: "timing" 26 | , window: Fullscreen 27 | , initialState: 28 | { start 29 | , reg: (100.0 / 6.0) 30 | , fixed: (100.0 / 6.0) 31 | } 32 | , viewBox: merge origin 33 | { width: 300.0 34 | , height: 90.0 35 | } 36 | , behavior: defaultBehavior 37 | { render = render 38 | , update = saveDelta @"reg" 39 | , fixed = 40 | { interval: hz 60.0 41 | , function: saveDelta @"fixed" 42 | } 43 | } 44 | } 45 | 46 | foreign import _now :: Effect Number 47 | 48 | type Data = { start :: Number, reg :: Number, fixed :: Number } 49 | 50 | saveDelta 51 | :: forall @l t r s 52 | . IsSymbol l 53 | => Cons l Number t r 54 | => Delta 55 | -> s 56 | -> { | r } 57 | -> Effect (Maybe { | r }) 58 | saveDelta { delta } _ = pure <<< Just <<< set (Proxy @l) delta 59 | 60 | -- Scale timing data to fit onto graphs: 61 | -- 62 | -- x: 1. Adjust time scale so graph doesn't move too quickly. 63 | -- 2. Wrap around from right to left. 64 | -- 65 | -- y: 1. Get difference from target of 60 Hz. 66 | -- 2. Scale up for emphasis. 67 | -- 3. Set position relative to x-axis. 68 | graph :: { x :: Number -> Number, y :: Number -> Number -> Number } 69 | graph = 70 | { x: \x -> (x / 30.0) % 300.0 71 | , y: \baseline y -> (y - 100.0 / 6.0) * 3.0 + baseline 72 | } 73 | 74 | render :: Context2D -> Delta -> Scalers -> States Data -> Effect Unit 75 | render ctx { now, last } { canvas } { previous, current } = do 76 | let 77 | x1 = graph.x $ last - current.start 78 | x2 = graph.x $ now - current.start 79 | fixed = canvas <~* 80 | { x1 81 | , x2 82 | , y1: graph.y 30.0 previous.fixed 83 | , y2: graph.y 30.0 current.fixed 84 | } 85 | reg = canvas <~* 86 | { x1 87 | , x2 88 | , y1: graph.y 70.0 previous.reg 89 | , y2: graph.y 70.0 current.reg 90 | } 91 | sweep = 92 | { x: x2 -~> canvas 93 | , y: 0.0 94 | , width: 20.0 /~> canvas 95 | , height: canvas.height 96 | } 97 | 98 | clearRect ctx sweep 99 | 100 | -- don't draw line from end to start as it wraps around 101 | when (x2 > x1) do 102 | setStrokeStyle ctx "black" 103 | drawLine ctx fixed 104 | drawLine ctx reg 105 | 106 | drawLabels ctx canvas 107 | 108 | drawLine 109 | :: Context2D 110 | -> { x1 :: Number, x2 :: Number, y1 :: Number, y2 :: Number } 111 | -> Effect Unit 112 | drawLine ctx { x1, y1, x2, y2 } = 113 | strokePath ctx do 114 | moveTo ctx x1 y1 115 | lineTo ctx x2 y2 116 | 117 | drawLabels :: Context2D -> Scaler -> Effect Unit 118 | drawLabels ctx canvas = do 119 | setTextBaseline ctx BaselineMiddle 120 | for_ [ 30.0, 70.0 ] \b -> do 121 | let 122 | -- slight adjustment to make the dash line up 123 | y' t = (graph.y b t) - 0.1 124 | drawLabel "16pt Arial" { x: -1.0, y: y' (100.0 / 7.5) } "- 75 Hz—" 125 | drawLabel "16pt Arial" { x: -1.0, y: y' (100.0 / 6.0) } "- 60 Hz—" 126 | drawLabel "16pt Arial" { x: -1.0, y: y' (100.0 / 5.0) } "- 50 Hz—" 127 | 128 | setTextBaseline ctx BaselineTop 129 | drawLabel "26pt Arial" { x: 2.0, y: 1.0 } "Δt Received by update functions" 130 | drawLabel "20pt Arial" { x: 4.0, y: 12.0 } "Fixed update (60 Hz)" 131 | drawLabel "20pt Arial" { x: 4.0, y: 52.0 } "Per-frame update" 132 | where 133 | drawLabel font pos text = do 134 | let { x, y } = pos *~> canvas 135 | 136 | setFont ctx font 137 | rel@{ width, height } <- toRelativeBoundingRect <$> measureText ctx text 138 | 139 | clearRect ctx { width, height, x: x + rel.x, y: y + rel.y } 140 | setFillStyle ctx "black" 141 | fillText ctx text x y 142 | 143 | -- Extra Canvas stuff 144 | 145 | type TextMetrics = 146 | { width :: Number 147 | , actualBoundingBoxLeft :: Number 148 | , actualBoundingBoxRight :: Number 149 | , fontBoundingBoxAscent :: Number 150 | , fontBoundingBoxDescent :: Number 151 | , actualBoundingBoxAscent :: Number 152 | , actualBoundingBoxDescent :: Number 153 | , emHeightAscent :: Number 154 | , emHeightDescent :: Number 155 | , hangingBaseline :: Number 156 | , alphabeticBaseline :: Number 157 | , ideographicBaseline :: Number 158 | } 159 | 160 | foreign import measureTextImpl :: EffectFn2 Context2D String TextMetrics 161 | 162 | measureText :: Context2D -> String -> Effect TextMetrics 163 | measureText = runEffectFn2 measureTextImpl 164 | 165 | toRelativeBoundingRect :: TextMetrics -> Rect 166 | toRelativeBoundingRect 167 | { actualBoundingBoxLeft 168 | , actualBoundingBoxRight 169 | , actualBoundingBoxAscent 170 | , actualBoundingBoxDescent 171 | } = 172 | { x: -actualBoundingBoxLeft 173 | , y: -actualBoundingBoxAscent 174 | , width: actualBoundingBoxRight + actualBoundingBoxLeft 175 | , height: actualBoundingBoxDescent + actualBoundingBoxAscent 176 | } 177 | -------------------------------------------------------------------------------- /examples/timing/timing.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/smilack/purescript-gesso/d78e1ccdb17a838288b5c5a9207dd5ad22bac4ee/examples/timing/timing.png -------------------------------------------------------------------------------- /spago.yaml: -------------------------------------------------------------------------------- 1 | package: 2 | name: gesso 3 | description: "Easily build applications in PureScript — Compatible with Halogen" 4 | dependencies: 5 | - aff: ">=7.0.0 <9.0.0" 6 | - canvas: ">=6.0.0 <7.0.0" 7 | - css: ">=6.0.0 <7.0.0" 8 | - dom-indexed: ">=11.0.0 <13.0.0" 9 | - effect: ">=4.0.0 <5.0.0" 10 | - foldable-traversable: ">=6.0.0 <7.0.0" 11 | - halogen: ">=7.0.0 <8.0.0" 12 | - halogen-subscriptions: ">=2.0.0 <3.0.0" 13 | - integers: ">=6.0.0 <7.0.0" 14 | - lists: ">=7.0.0 <8.0.0" 15 | - maybe: ">=6.0.0 <7.0.0" 16 | - numbers: ">=9.0.1 <10.0.0" 17 | - ordered-collections: ">=3.2.0 <4.0.0" 18 | - prelude: ">=6.0.1 <7.0.0" 19 | - record: ">=4.0.0 <5.0.0" 20 | - transformers: ">=6.1.0 <7.0.0" 21 | - tuples: ">=7.0.0 <8.0.0" 22 | - typelevel-prelude: ">=7.0.0 <8.0.0" 23 | - web-clipboard: ">=4.0.0 <7.0.0" 24 | - web-dom: ">=6.0.0 <7.0.0" 25 | - web-events: ">=4.0.0 <5.0.0" 26 | - web-html: ">=4.1.0 <5.0.0" 27 | - web-pointerevents: ">=1.0.0 <3.0.0" 28 | - web-touchevents: ">=4.0.0 <5.0.0" 29 | - web-uievents: ">=4.0.0 <6.0.0" 30 | publish: 31 | version: 1.0.0 32 | license: MIT 33 | exclude: 34 | - "examples/*" 35 | location: 36 | githubOwner: smilack 37 | githubRepo: purescript-gesso 38 | workspace: 39 | packageSet: 40 | registry: 62.2.6 41 | -------------------------------------------------------------------------------- /src/Gesso.purs: -------------------------------------------------------------------------------- 1 | -- | This is the main entry point for Gesso applications and contains functions 2 | -- | for running `Aff` values. For a full-page application where Gesso is the 3 | -- | root component, typical usage of this module would be: 4 | -- | ```purescript 5 | -- | main :: Effect Unit 6 | -- | main = Gesso.launch appSpec 7 | -- | ``` 8 | -- | Or to confine Gesso to an element on the page, use `launchIn` with a query 9 | -- | selector: 10 | -- | ```purescript 11 | -- | main :: Effect Unit 12 | -- | main = Gesso.launchIn "#some-element-id" appSpec 13 | -- | ``` 14 | -- | If it's necessary to perform other `Aff` actions, the `run` function is 15 | -- | available: 16 | -- | ```purescript 17 | -- | runGessoAff do 18 | -- | body <- awaitBody 19 | -- | Gesso.run appSpec body 20 | -- | ``` 21 | -- | When Gesso is a subcomponent of another Halogen component, run Halogen and 22 | -- | include Gesso as a child component in the standard way. 23 | module Gesso 24 | ( launch 25 | , launchIn 26 | , module Exports 27 | , run 28 | , runGessoAff 29 | ) where 30 | 31 | import Prelude 32 | 33 | import Data.Maybe (maybe) 34 | import Effect (Effect) 35 | import Effect.Aff (Aff, error, throwError) 36 | import Gesso.Application as GApp 37 | import Gesso.Canvas as GCan 38 | import Halogen.Aff (awaitBody, awaitLoad, selectElement) as Exports 39 | import Halogen.Aff (awaitLoad, runHalogenAff, selectElement) as HAff 40 | import Halogen.VDom.Driver (runUI) 41 | import Web.DOM.ParentNode (QuerySelector(..)) 42 | import Web.DOM.ParentNode (QuerySelector(..)) as Exports 43 | import Web.HTML.HTMLElement (HTMLElement) 44 | 45 | -- | Launch a Gesso application in the page body. 46 | launch 47 | :: forall state input ouput 48 | . GApp.AppSpec state input ouput 49 | -> Effect Unit 50 | launch = launchIn "body" 51 | 52 | -- | Launch a Gesso application in a given element. The String argument should 53 | -- | be a valid query selector for some element on the page. 54 | launchIn 55 | :: forall state input ouput 56 | . String 57 | -> GApp.AppSpec state input ouput 58 | -> Effect Unit 59 | launchIn selector input = runGessoAff do 60 | HAff.awaitLoad 61 | target <- HAff.selectElement (QuerySelector selector) 62 | element <- maybe err pure target 63 | run input element 64 | where 65 | err = throwError $ error $ "Could not find " <> selector 66 | 67 | -- | Run an `Aff` value such as the one produced by `run`. Alias for 68 | -- | `Halogen.Aff.runHalogenAff`. 69 | runGessoAff :: forall x. Aff x -> Effect Unit 70 | runGessoAff = HAff.runHalogenAff 71 | 72 | -- | An `Aff` which starts a Gesso application in the provided element. Used 73 | -- | when performing other `Aff` effects at the same time as running the 74 | -- | application. 75 | run 76 | :: forall state input ouput 77 | . GApp.AppSpec state input ouput 78 | -> HTMLElement 79 | -> Aff Unit 80 | run spec element = do 81 | _ <- runUI GCan.component spec element 82 | pure unit 83 | -------------------------------------------------------------------------------- /src/Gesso/Application.purs: -------------------------------------------------------------------------------- 1 | -- | Functions and configuration necessary to start a Gesso application. 2 | module Gesso.Application 3 | ( AppBehavior 4 | , AppSpec 5 | , WindowMode(..) 6 | , defaultBehavior 7 | , module Exports 8 | ) where 9 | 10 | import Prelude 11 | 12 | import Data.Maybe (Maybe(..)) 13 | import Gesso.Application.Behavior (FixedUpdate, InputReceiver, OutputProducer, RenderFunction, UpdateFunction) 14 | import Gesso.Application.Behavior (FixedUpdate, InputReceiver, OutputProducer, RenderFunction, TimestampedUpdate, UpdateFunction) as Exports 15 | import Gesso.Geometry (Area, Rect) 16 | import Gesso.Interactions (Interactions) 17 | import Gesso.Interactions (default) as Interactions 18 | import Gesso.Time (never) 19 | 20 | -- | `AppSpec` holds information about the setup and behavior of a Gesso 21 | -- | component. 22 | -- | 23 | -- | - `name` is the name of the application, which doubles as the HTML `id` for 24 | -- | the canvas element. 25 | -- | - `initialState` is the initial state for the application. 26 | -- | - `viewBox` is the desired dimensions for the drawing area. 27 | -- | - `window` defines how the screen element should size and position itself. 28 | -- | - `behavior` contains functions that control i/o, updates, and rendering. 29 | type AppSpec state input output = 30 | { name :: String 31 | , initialState :: state 32 | , viewBox :: Rect 33 | , window :: WindowMode 34 | , behavior :: AppBehavior state input output 35 | } 36 | 37 | -- | `AppBehavior` holds the functions that make an application run. 38 | -- | 39 | -- | - `render` draws on the component every animation frame. 40 | -- | - `update` runs on each animation frame, just before `render`. 41 | -- | - `fixed` runs at a set interval of time. 42 | -- | - `interactions` are events which will be attached to the canvas element. 43 | -- | - `output` defines how (or if) the component should send information out to 44 | -- | a parent component. 45 | -- | - `input` defines how the component's state should change in response to 46 | -- | receiving input from a parent component. 47 | type AppBehavior state input output = 48 | { render :: RenderFunction state 49 | , update :: UpdateFunction state 50 | , fixed :: FixedUpdate state 51 | , interactions :: Interactions state 52 | , output :: OutputProducer state output 53 | , input :: InputReceiver state input 54 | } 55 | 56 | -- | A default `AppBehavior` which can be modified piecemeal like Halogen's 57 | -- | `EvalSpec`. It does nothing on its own. 58 | defaultBehavior 59 | :: forall state input output 60 | . AppBehavior state input output 61 | defaultBehavior = 62 | { render: \_ _ _ _ -> pure unit 63 | , update: \_ _ _ -> pure Nothing 64 | , fixed: 65 | { interval: never 66 | , function: \_ _ _ -> pure Nothing 67 | } 68 | , interactions: Interactions.default 69 | , output: \_ _ _ -> pure Nothing 70 | , input: \_ _ _ _ -> pure Nothing 71 | } 72 | 73 | -- | There are three modes that determine the size and position of a Gesso 74 | -- | component: 75 | -- | 76 | -- | - `Fixed` creates a screen of the specified size. 77 | -- | - `Stretch` expands to fill its containing element. 78 | -- | - `FullScreen` takes up the entire page from the top left corner to the 79 | -- | bottom right. 80 | data WindowMode 81 | = Fixed Area 82 | | Stretch 83 | | Fullscreen 84 | -------------------------------------------------------------------------------- /src/Gesso/Application/Behavior.purs: -------------------------------------------------------------------------------- 1 | module Gesso.Application.Behavior 2 | ( FixedUpdate 3 | , InputReceiver 4 | , OutputProducer 5 | , RenderFunction 6 | , TimestampedUpdate 7 | , UpdateFunction 8 | ) where 9 | 10 | import Prelude 11 | 12 | import Data.Maybe (Maybe) 13 | import Effect (Effect) 14 | import Gesso.Geometry (Scalers) 15 | import Gesso.State (Compare, States) 16 | import Gesso.Time (Delta, Interval) 17 | import Graphics.Canvas (Context2D) 18 | 19 | -- | A function that draws on the component. It knows the following: 20 | -- | 21 | -- | - `Context2D` is the drawing context of the canvas element 22 | -- | - `Delta` is a record containing current and previous timestamps and the 23 | -- | time elapsed since the previous frame. 24 | -- | - `Scalers` is a record containing scaling information for transforming 25 | -- | coordinates between the drawing and the canvas. 26 | -- | - `state` is the state of the application, with `States` containing the two 27 | -- | most recent states and the time progress between them (on the interval 28 | -- | `[0, 1]`). 29 | -- | 30 | -- | The render function may run any operations in `Effect`, not just functions 31 | -- | related to drawing on the canvas. 32 | type RenderFunction state = 33 | Context2D -> Delta -> Scalers -> States state -> Effect Unit 34 | 35 | -- | An function that may update the application state. It runs on every frame, 36 | -- | before the render function. It knows the following: 37 | -- | 38 | -- | - `Delta` is a record containing current and previous timestamps and the 39 | -- | time elapsed since the previous frame. 40 | -- | - `Scalers` is a record containing scaling information for transforming 41 | -- | coordinates between the drawing and the canvas. 42 | -- | - `state` is the state of the application 43 | -- | 44 | -- | The update function may return a new state if changes are necessary (or 45 | -- | `Nothing` if not). 46 | -- | 47 | -- | This type is also used by Interaction handlers and when receiving input 48 | -- | from a host application. 49 | type UpdateFunction state = 50 | Delta -> TimestampedUpdate state 51 | 52 | -- | A partially applied `UpdateFunction` that already has the `Delta` record. 53 | type TimestampedUpdate state = 54 | Scalers -> state -> Effect (Maybe state) 55 | 56 | -- | An update function that occurs at a fixed, regular interval, rather than on 57 | -- | every animation frame. 58 | type FixedUpdate state = 59 | { interval :: Interval 60 | , function :: UpdateFunction state 61 | } 62 | 63 | -- | An input receiver is a variant of an update function that can receive 64 | -- | information from the component's parent and produce an update function 65 | -- | in response. 66 | type InputReceiver state input = input -> UpdateFunction state 67 | 68 | -- | When the state of an application changes, an output producer compares the 69 | -- | old and new states and may send output to the component's parent based on 70 | -- | the difference. 71 | type OutputProducer state output = 72 | Delta -> Scalers -> Compare state -> Effect (Maybe output) 73 | -------------------------------------------------------------------------------- /src/Gesso/Canvas.purs: -------------------------------------------------------------------------------- 1 | -- | Gesso Canvas is a Halogen component that handles creating a canvas element, 2 | -- | calling `requestAnimationFrame`, attaching events, and running render and 3 | -- | update functions. 4 | module Gesso.Canvas 5 | ( CanvasInput(..) 6 | , CanvasOutput(..) 7 | , Slot 8 | , _gessoCanvas 9 | , component 10 | ) where 11 | 12 | import Prelude 13 | 14 | import Control.Monad.Maybe.Trans (MaybeT(..), lift, runMaybeT) 15 | import Data.Foldable (foldr, for_, traverse_) 16 | import Data.Function (on) 17 | import Data.List (List, (:)) 18 | import Data.List as List 19 | import Data.Maybe (Maybe(..), maybe) 20 | import Data.Traversable (for, traverse) 21 | import Effect (Effect) 22 | import Effect.Aff.Class (class MonadAff) 23 | import Gesso.Application as App 24 | import Gesso.Canvas.Element as GEl 25 | import Gesso.Geometry (Rect) as Geo 26 | import Gesso.Geometry.Internal (Scalers, mkScalers) as Geo 27 | import Gesso.Interactions.Internal as GI 28 | import Gesso.State (Compare, History) 29 | import Gesso.Time as T 30 | import Graphics.Canvas (Context2D) 31 | import Halogen (liftEffect) 32 | import Halogen as H 33 | import Halogen.HTML (memoized, canvas) as HH 34 | import Halogen.HTML.Properties (id, tabIndex) 35 | import Halogen.Query.Event as HE 36 | import Halogen.Subscription as HS 37 | import Type.Proxy (Proxy(..)) 38 | import Web.Event.Event (EventType(..)) 39 | import Web.HTML (window) 40 | import Web.HTML.HTMLDocument (toEventTarget, visibilityState) as Document 41 | import Web.HTML.HTMLDocument.VisibilityState (VisibilityState(..)) as Document 42 | import Web.HTML.Window (document) 43 | import Web.HTML.Window (toEventTarget) as Window 44 | 45 | -- | A Halogen slot type for the Canvas component, which is used to include it 46 | -- | inside another Halogen component. 47 | type Slot input output slot = 48 | H.Slot (CanvasInput input) (CanvasOutput output) slot 49 | 50 | -- | A proxy type for Canvas for use with `Slot`. 51 | _gessoCanvas = Proxy :: Proxy "gessoCanvas" 52 | 53 | -- | The internal state of the Canvas component 54 | -- | 55 | -- | - `name` is the name of the application, which doubles as the HTML `id` for 56 | -- | the canvas element. 57 | -- | - `localState` is the state of the application. 58 | -- | - `viewBox` is the position and dimensions of the drawing area. 59 | -- | - `window` defines how the screen element should size and position itself. 60 | -- | - `behavior` contains functions that make the application do things. 61 | -- | - `render` draws on the component every animation frame. 62 | -- | - `update` runs on each animation frame, just before `render`. 63 | -- | - `fixed` runs at a set interval of time. 64 | -- | - `interactions` are events attached to the canvas element. 65 | -- | - `output` defines how (or if) the component should send information out 66 | -- | to the host application. 67 | -- | - `input` defines how the component's state should change in response to 68 | -- | receiving input from the host application. 69 | -- | - `dom`: DOM-related fields available after initialization: 70 | -- | - `clientRect` is the actual position and dimensions of the canvas 71 | -- | element. 72 | -- | - `canvas` is the canvas element. 73 | -- | - `context` is the `Context2D` for the canvas element. 74 | -- | - `scalers` is a record containing scaling information for transforming 75 | -- | coordinates between the drawing and the canvas. 76 | -- | - `subscriptions`: Event subscriptions created during initialization and 77 | -- | kept until the application is destroyed. 78 | -- | - `resize` is a subscription to window resize events, to re-check the 79 | -- | `clientRect` and recreate the `scaler`. 80 | -- | - `visibility` is a subscription to document `visibilitychange` events, 81 | -- | to pause or resume running timers. 82 | -- | - `emitter` is a subscription to a listener/emitter pair used to send 83 | -- | Actions from `requestAnimationFrame` callbacks to the component. 84 | -- | - `timers` contains two timestamps, which are both set to a default value 85 | -- | when the component is initialized: 86 | -- | - `frame` is the timestamp of the most recently fired animation frame. 87 | -- | - `fixed` is used for accurately spacing fixed-rate updates and it's 88 | -- | updated after every batch of updates. 89 | -- | - `pendingUpdates` is a list of interactions and Query inputs waiting to be 90 | -- | applied. 91 | -- | - `rafId` is the ID of the most recently requested animation frame. It's 92 | -- | set when `requestAnimationFrame` is called and cleared when the animation 93 | -- | frame callback runs. 94 | type State state input output = 95 | { name :: String 96 | , localState :: state 97 | , viewBox :: Geo.Rect 98 | , window :: App.WindowMode 99 | , behavior :: 100 | { render :: App.RenderFunction state 101 | , update :: App.UpdateFunction state 102 | , fixed :: App.FixedUpdate state 103 | , interactions :: GI.Interactions state 104 | , output :: App.OutputProducer state output 105 | , input :: App.InputReceiver state input 106 | } 107 | , dom :: 108 | Maybe 109 | { clientRect :: Geo.Rect 110 | , canvas :: GEl.Canvas 111 | , context :: Context2D 112 | , scalers :: Geo.Scalers 113 | } 114 | , subscriptions :: 115 | Maybe 116 | { resize :: H.SubscriptionId 117 | , visibility :: H.SubscriptionId 118 | , emitter :: H.SubscriptionId 119 | } 120 | , timers :: 121 | Maybe 122 | { frame :: T.Last 123 | , fixed :: T.Last 124 | } 125 | , pendingUpdates :: List (T.Stamped (App.TimestampedUpdate state)) 126 | , rafId :: Maybe T.RequestAnimationFrameId 127 | } 128 | 129 | -- | See `handleAction` 130 | data Action state 131 | = Initialize 132 | | HandleResize 133 | | HandleVisibilityChange 134 | | FirstTick (Action state -> Effect Unit) 135 | | Tick (Action state -> Effect Unit) T.Last 136 | | Finalize 137 | | StateUpdated T.Delta Geo.Scalers (Compare state) 138 | | QueueUpdate (App.UpdateFunction state) 139 | | FrameRequested T.RequestAnimationFrameId 140 | | FrameFired 141 | 142 | -- | Used to wrap Output to a parent Halogen component. The component's output 143 | -- | type is defined by the `OutputProducer` in the 144 | -- | [`Gesso.Application.AppSpec`](Gesso.Application.html#t:AppSpec). 145 | newtype CanvasOutput ouput = CanvasOutput ouput 146 | 147 | -- | Used to wrap Queries from a parent Halogen component. The component's input 148 | -- | type is defined by the `InputReceiver` in the 149 | -- | [`Gesso.Application.AppSpec`](Gesso.Application.html#t:AppSpec). 150 | data CanvasInput input a = CanvasInput input a 151 | 152 | -- | Definition of the Canvas component. Can be used to slot the canvas into a 153 | -- | parent Halogen component. 154 | -- `render` is memoized so that it only re-renders when the dimensions of the 155 | -- canvas element change. 156 | component 157 | :: forall state input output m 158 | . MonadAff m 159 | => H.Component 160 | (CanvasInput input) 161 | (App.AppSpec state input output) 162 | (CanvasOutput output) 163 | m 164 | component = 165 | H.mkComponent 166 | { initialState 167 | , render: HH.memoized (eq `on` (_.dom >>> map _.clientRect)) renderComponent 168 | , eval: 169 | H.mkEval 170 | $ H.defaultEval 171 | { handleAction = handleAction 172 | , handleQuery = handleQuery 173 | , initialize = Just Initialize 174 | , finalize = Just Finalize 175 | } 176 | } 177 | 178 | -- | Get initial state for Canvas. Most values are copied directly from the 179 | -- | input. The rest require Effects and are created in `initialize`, except for 180 | -- | the update queues, which start empty. 181 | initialState 182 | :: forall state input output 183 | . App.AppSpec state input output 184 | -> State state input output 185 | initialState { name, window, initialState: localState, viewBox, behavior } = 186 | { name 187 | , localState 188 | , viewBox 189 | , window 190 | , behavior 191 | , dom: Nothing 192 | , subscriptions: Nothing 193 | , timers: Nothing 194 | , pendingUpdates: List.Nil 195 | , rafId: Nothing 196 | } 197 | 198 | -- | Render Canvas component. The `width` and `height` attributes may be 199 | -- | different from the CSS width and height. The CSS controls the area that the 200 | -- | element takes up on the page, while the HTML attributes control the 201 | -- | coordinate system of the drawing area. 202 | renderComponent 203 | :: forall state input output slots m 204 | . State state input output 205 | -> H.ComponentHTML (Action state) slots m 206 | renderComponent { name, dom, window, behavior: { interactions } } = 207 | HH.canvas $ [ id name, GEl.style window, tabIndex 0 ] 208 | <> GI.toProps QueueUpdate interactions 209 | <> maybe [] GEl.toSizeProps (dom <#> _.clientRect) 210 | 211 | -- | - `Initialize`: Create `subscriptions` and `dom` records, then recurse with 212 | -- | `FirstTick` to request the first animation frame. 213 | -- | - `HandleResize`: Window resized, get new client rect and recalculate 214 | -- | `scaler` functions. 215 | -- | - (TODO) `HandleVisibilityChange`: Window visibility has changed; pause or 216 | -- | resume running timers. 217 | -- | - `FirstTick`: Request an animation frame that only checks the time and 218 | -- | then starts the `Tick` loop, so that `Tick` can start out knowing the 219 | -- | frame timing. 220 | -- | - `Tick`: Request an animation frame. When animating, `Tick` passes the 221 | -- | animation frame timestamp to itself so it can calculate the delta between 222 | -- | frames. 223 | -- | - `Finalize`: Unsubscribe from window resize events and listener/emitter. 224 | -- | - `QueueUpdate`: An event (interaction or input) fired, add the handler to 225 | -- | a queue to be run on the next animation frame. 226 | -- | - `StateUpdated`: The local state is changing. Save it and tell 227 | -- | `Application` to handle output. 228 | -- | - `FrameRequested`: An animation frame has been requested, save its ID. 229 | -- | - `FrameFired`: The requested animation frame has fired, forget its ID. 230 | handleAction 231 | :: forall state input output slots m 232 | . MonadAff m 233 | => Action state 234 | -> H.HalogenM (State state input output) (Action state) slots 235 | (CanvasOutput output) 236 | m 237 | Unit 238 | handleAction = case _ of 239 | Initialize -> initialize >>= (FirstTick >>> handleAction) 240 | 241 | HandleResize -> updateClientRect 242 | 243 | HandleVisibilityChange -> {- TODO -} 244 | H.liftEffect do 245 | window >>= document >>= Document.visibilityState 246 | >>= case _ of 247 | Document.Visible -> pure unit 248 | Document.Hidden -> pure unit 249 | 250 | FirstTick notify -> H.liftEffect $ getFirstFrame notify 251 | 252 | Tick notify lastFrame -> do 253 | { localState, behavior: { fixed, update, render }, pendingUpdates } <- H.get 254 | 255 | results <- runMaybeT do 256 | timers <- MaybeT $ H.gets _.timers 257 | { context, scalers } <- MaybeT $ H.gets _.dom 258 | 259 | lift $ H.liftEffect do 260 | -- schedule fixed updates 261 | let { function, interval } = fixed 262 | { last, items } <- T.stampInterval timers.fixed function interval 263 | let updateQueue = T.sort (items <> pendingUpdates) 264 | 265 | -- run pending + queued updates 266 | let 267 | initialHistory = 268 | { original: localState 269 | , old: localState 270 | , new: localState 271 | , changed: false 272 | } 273 | stateHistory <- 274 | foldr 275 | (tryUpdate scalers) 276 | (pure initialHistory) 277 | (updateQueue <#> _.item) 278 | 279 | queueAnimationFrame 280 | lastFrame 281 | (T.toRatio last interval) 282 | context 283 | scalers 284 | stateHistory 285 | update 286 | render 287 | notify 288 | 289 | pure 290 | { queue': List.Nil 291 | , timers': Just { frame: lastFrame, fixed: last } 292 | } 293 | 294 | case results of 295 | Nothing -> handleAction Finalize 296 | Just { queue', timers' } -> 297 | H.modify_ (_ { pendingUpdates = queue', timers = timers' }) 298 | 299 | Finalize -> unsubscribe 300 | 301 | -- Hold on to interactions/inputs until the next tick, then pass them into rAF 302 | QueueUpdate handlerFn -> do 303 | { pendingUpdates, timers } <- H.get 304 | for_ timers \{ frame } -> do 305 | stampedUpdate <- H.liftEffect $ T.stamp frame handlerFn 306 | H.modify_ (_ { pendingUpdates = stampedUpdate : pendingUpdates }) 307 | 308 | StateUpdated delta scalers stateVersions -> 309 | saveNewState delta scalers stateVersions 310 | 311 | FrameRequested rafId -> H.modify_ (_ { rafId = Just rafId }) 312 | 313 | FrameFired -> H.modify_ (_ { rafId = Nothing }) 314 | 315 | -- | Subscribe to window resize events. Get the `canvas` element and its 316 | -- | `Context2D` and `clientRect`. Create scaling functions based on the 317 | -- | `viewBox` and `clientRect`. 318 | initialize 319 | :: forall state input output slots o m 320 | . MonadAff m 321 | => H.HalogenM (State state input output) (Action state) slots o m 322 | (Action state -> Effect Unit) 323 | initialize = do 324 | { notify, subscriptions } <- mkSubs 325 | timers <- H.liftEffect mkTimers 326 | state <- H.get 327 | dom <- H.liftEffect $ mkDom state 328 | H.put $ state { dom = dom, subscriptions = subscriptions, timers = timers } 329 | pure notify 330 | where 331 | mkTimers = T.started <#> \t -> Just { frame: t, fixed: t } 332 | 333 | mkSubs = do 334 | notifications <- H.liftEffect HS.create 335 | emitter <- H.subscribe notifications.emitter 336 | resize <- subscribeResize 337 | visibility <- subscribeVisibility 338 | pure 339 | { notify: HS.notify notifications.listener 340 | , subscriptions: Just { resize, visibility, emitter } 341 | } 342 | 343 | mkDom { name, viewBox } = do 344 | context <- GEl.getContextByAppName name 345 | canvas <- GEl.getCanvasByAppName name 346 | clientRect <- traverse GEl.getCanvasClientRect canvas 347 | let scalers = Geo.mkScalers viewBox <$> clientRect 348 | pure $ 349 | { clientRect: _, canvas: _, context: _, scalers: _ } 350 | <$> clientRect 351 | <*> canvas 352 | <*> context 353 | <*> scalers 354 | 355 | -- | The reusable chunk of requesting an animation frame: 356 | -- | 357 | -- | 1. Request the frame and tell the component that the frame was requested. 358 | -- | 2. When the frame fires, notify the component that the frame has fired and 359 | -- | then call the provided callback function. 360 | -- | 3. After running the callback, tell the component to start the next Tick. 361 | requestAnimationFrame 362 | :: forall state 363 | . (T.Now -> Effect Unit) 364 | -> (Action state -> Effect Unit) 365 | -> Effect Unit 366 | requestAnimationFrame callback notify = 367 | window 368 | >>= T.requestAnimationFrame callbackWrapper 369 | >>= (FrameRequested >>> notify) 370 | where 371 | callbackWrapper timestamp = 372 | notify FrameFired 373 | *> callback timestamp 374 | *> tick timestamp 375 | 376 | tick = notify <<< Tick notify <<< T.elapse 377 | 378 | -- | Request one animation frame in order to get a timestamp to start counting 379 | -- | from. 380 | getFirstFrame 381 | :: forall state 382 | . (Action state -> Effect Unit) 383 | -> Effect Unit 384 | getFirstFrame = requestAnimationFrame (const $ pure unit) 385 | 386 | -- | Run per-frame update function and render function. Give `render` the newest 387 | -- | state and the state prior to the most recent update, as well as the time 388 | -- | difference between the two. Send the most recent state and the state as of 389 | -- | the beginning of this tick to the app's output function to determine 390 | -- | whether to send I/O. 391 | queueAnimationFrame 392 | :: forall state 393 | . T.Last 394 | -> (T.Now -> Number) 395 | -> Context2D 396 | -> Geo.Scalers 397 | -> History state 398 | -> App.UpdateFunction state 399 | -> App.RenderFunction state 400 | -> (Action state -> Effect Unit) 401 | -> Effect Unit 402 | queueAnimationFrame 403 | lastTime 404 | toIntervalRatio 405 | context 406 | scalers 407 | stateHistory 408 | update 409 | render 410 | notify = 411 | requestAnimationFrame rafCallback notify 412 | where 413 | rafCallback :: T.Now -> Effect Unit 414 | rafCallback timestamp = do 415 | let delta = T.delta timestamp lastTime 416 | 417 | history <- tryUpdate scalers (update delta) (pure stateHistory) 418 | 419 | when history.changed 420 | $ notify 421 | $ StateUpdated delta scalers { old: history.original, new: history.new } 422 | 423 | render context delta scalers 424 | { previous: history.old 425 | , current: history.new 426 | , t: toIntervalRatio timestamp 427 | } 428 | 429 | -- | Run an update function, using a current state if available, or an older one 430 | -- | if not. When folding over a list of update functions, this makes it easier 431 | -- | to track whether the state has changed while also continuing to pass on the 432 | -- | most current state. 433 | tryUpdate 434 | :: forall state 435 | . Geo.Scalers 436 | -> (Geo.Scalers -> state -> Effect (Maybe state)) 437 | -> Effect (History state) 438 | -> Effect (History state) 439 | tryUpdate scalers update state = do 440 | { original, new } <- state 441 | update scalers new >>= case _ of 442 | Nothing -> state 443 | Just new' -> pure { original, old: new, new: new', changed: true } 444 | 445 | -- | Get a new `clientRect` for the `canvas` element and create new scalers for 446 | -- | it, saving both to the component state. 447 | updateClientRect 448 | :: forall state input output action slots o m 449 | . MonadAff m 450 | => H.HalogenM (State state input output) action slots o m Unit 451 | updateClientRect = do 452 | dom' <- H.liftEffect <<< updateDom =<< H.get 453 | H.modify_ (_ { dom = dom' }) 454 | where 455 | updateDom { viewBox, dom } = for dom \d -> do 456 | clientRect <- GEl.getCanvasClientRect d.canvas 457 | pure d 458 | { clientRect = clientRect 459 | , scalers = Geo.mkScalers viewBox clientRect 460 | } 461 | 462 | -- | Unsubscribe from window resize events and paired listener/emitter. 463 | unsubscribe 464 | :: forall state input output action slots o m 465 | . MonadAff m 466 | => H.HalogenM (State state input output) action slots o m Unit 467 | unsubscribe = 468 | H.gets _.subscriptions 469 | >>= traverse_ \subs -> do 470 | H.unsubscribe subs.resize 471 | H.unsubscribe subs.emitter 472 | 473 | -- | Subscribe to window resize events and fire the `HandleResize` `Action` when 474 | -- | they occur. 475 | subscribeResize 476 | :: forall state input output slots o m 477 | . MonadAff m 478 | => H.HalogenM (State state input output) (Action state) slots o m 479 | H.SubscriptionId 480 | subscribeResize = do 481 | wnd <- H.liftEffect window 482 | H.subscribe 483 | $ HE.eventListener 484 | (EventType "resize") 485 | (Window.toEventTarget wnd) 486 | (const $ Just HandleResize) 487 | 488 | -- | Subscribe to document visibility events and fire the 489 | -- | `HandleVisibilityChange` `Action` when they occur. 490 | subscribeVisibility 491 | :: forall state input output slots o m 492 | . MonadAff m 493 | => H.HalogenM (State state input output) (Action state) slots o m 494 | H.SubscriptionId 495 | subscribeVisibility = do 496 | doc <- H.liftEffect $ document =<< window 497 | H.subscribe 498 | $ HE.eventListener 499 | (EventType "visibilitychange") 500 | (Document.toEventTarget doc) 501 | (const $ Just HandleVisibilityChange) 502 | 503 | -- | Save the updated local state of the application. Compare the old and new 504 | -- | states in the `OutputProducer` function and send output, if necessary. 505 | saveNewState 506 | :: forall state input output slots m 507 | . MonadAff m 508 | => T.Delta 509 | -> Geo.Scalers 510 | -> Compare state 511 | -> H.HalogenM (State state input output) (Action state) slots 512 | (CanvasOutput output) 513 | m 514 | Unit 515 | saveNewState delta scalers stateVersions = do 516 | { output } <- H.gets _.behavior 517 | H.modify_ (_ { localState = stateVersions.new }) 518 | mOutput <- liftEffect $ output delta scalers stateVersions 519 | traverse_ (H.raise <<< CanvasOutput) mOutput 520 | 521 | -- | Receiving input from the host application. Convert it into an `Update` and 522 | -- | call `handleAction` to add it to the update queue. 523 | handleQuery 524 | :: forall state input output slots a m 525 | . MonadAff m 526 | => CanvasInput input a 527 | -> H.HalogenM 528 | (State state input output) 529 | (Action state) 530 | slots 531 | (CanvasOutput output) 532 | m 533 | (Maybe a) 534 | handleQuery (CanvasInput inData a) = do 535 | { input } <- H.gets _.behavior 536 | handleAction $ QueueUpdate $ input inData 537 | pure (Just a) 538 | -------------------------------------------------------------------------------- /src/Gesso/Canvas/Element.purs: -------------------------------------------------------------------------------- 1 | -- | Internal helper functions that the Canvas component uses to style and 2 | -- | position itself and access the canvas's drawing context. 3 | module Gesso.Canvas.Element 4 | ( Canvas 5 | , getCanvasByAppName 6 | , getCanvasClientRect 7 | , getContextByAppName 8 | , style 9 | , toSizeProps 10 | ) where 11 | 12 | import Prelude 13 | 14 | import CSS (CSS) 15 | import CSS as CSS 16 | import Data.Int (round) 17 | import Data.Maybe (Maybe, fromMaybe) 18 | import Data.Traversable (traverse) 19 | import Effect (Effect) 20 | import Gesso.Application (WindowMode(..)) as App 21 | import Gesso.Geometry (Rect, Size) as Geo 22 | import Graphics.Canvas (Context2D, getCanvasElementById, getContext2D) 23 | import Halogen.HTML (AttrName(..), attr) 24 | import Halogen.HTML.Properties (IProp, CSSPixel) 25 | import Halogen.HTML.Properties (width, height) as HP 26 | import Web.DOM.Element (Element, DOMRect, getBoundingClientRect) 27 | import Web.DOM.NonElementParentNode (getElementById) 28 | import Web.HTML (window) 29 | import Web.HTML.HTMLDocument (toNonElementParentNode) 30 | import Web.HTML.Window (document) 31 | 32 | -- | Wrapper for a `Web.DOM.Element.Element` to tag elements that came from this 33 | -- | module. 34 | newtype Canvas = Canvas Element 35 | 36 | -- | Wrapper for `getElementById` which returns a `Canvas`. 37 | -- | 38 | -- | `getElementById` from `Web.DOM.NonElementParentNode`, which returns a 39 | -- | `Web.DOM.Element.Element`, is different from `getCanvasElementById` from 40 | -- | `Graphics.Canvas`, which returns a `Graphics.Canvas.CanvasElement`, so 41 | -- | they're unfortunately incompatible. 42 | getCanvasByAppName :: String -> Effect (Maybe Canvas) 43 | getCanvasByAppName name = 44 | window 45 | >>= document 46 | >>> map toNonElementParentNode 47 | >>= getElementById name 48 | >>> map (map Canvas) 49 | 50 | -- | Get the bounding client rect for a `Canvas` element and convert it to a 51 | -- | `ClientRect` value. 52 | getCanvasClientRect :: Canvas -> Effect Geo.Rect 53 | getCanvasClientRect (Canvas canvas) = 54 | fromDOMRect <$> getBoundingClientRect canvas 55 | 56 | fromDOMRect :: DOMRect -> Geo.Rect 57 | fromDOMRect { left, top, width, height } = { x: left, y: top, width, height } 58 | 59 | -- | Attempt to get the `Context2D` for this component's `canvas` element. 60 | getContextByAppName :: String -> Effect (Maybe Context2D) 61 | getContextByAppName name = getCanvasElementById name >>= traverse getContext2D 62 | 63 | -- | Get size and positioning CSS based on the app's window mode. 64 | style :: forall r i. App.WindowMode -> IProp (style :: String | r) i 65 | style = 66 | attr (AttrName "style") 67 | <<< fromMaybe "" 68 | <<< CSS.renderedInline 69 | <<< CSS.rules [] 70 | <<< CSS.runS 71 | <<< windowCss 72 | 73 | -- | Get the appropriate CSS for the screen element based on the `WindowMode`. 74 | windowCss :: App.WindowMode -> CSS 75 | windowCss = case _ of 76 | App.Fixed size -> fix size 77 | App.Stretch -> stretched 78 | App.Fullscreen -> full 79 | where 80 | common = do 81 | CSS.key (CSS.fromString "outline") "none" 82 | 83 | fix { width, height } = do 84 | CSS.width $ CSS.px width 85 | CSS.height $ CSS.px height 86 | common 87 | 88 | stretched = do 89 | CSS.width $ CSS.pct 100.0 90 | CSS.height $ CSS.pct 100.0 91 | common 92 | 93 | full = do 94 | CSS.width $ CSS.pct 100.0 95 | CSS.height $ CSS.pct 100.0 96 | CSS.position CSS.absolute 97 | CSS.left $ CSS.pct 50.0 98 | CSS.top $ CSS.pct 50.0 99 | CSS.transform $ CSS.translate (CSS.pct $ -50.0) (CSS.pct $ -50.0) 100 | common 101 | 102 | -- | Convert a `width` and `height` to HTML properties. 103 | toSizeProps 104 | :: forall i r s 105 | . { | Geo.Size Number s } 106 | -> Array (IProp (width :: CSSPixel, height :: CSSPixel | r) i) 107 | toSizeProps { width, height } = 108 | [ HP.width $ round width 109 | , HP.height $ round height 110 | ] 111 | -------------------------------------------------------------------------------- /src/Gesso/Geometry.purs: -------------------------------------------------------------------------------- 1 | module Gesso.Geometry 2 | ( fromMouseEvent 3 | , module Exports 4 | ) where 5 | 6 | import Prelude 7 | 8 | import Data.Int (toNumber) 9 | import Gesso.Geometry.Dimensions (Area, Point, Position, Rect, Rectangular, Size, null, origin, sizeless) as Exports 10 | import Gesso.Geometry.Dimensions (Point) 11 | import Gesso.Geometry.Internal (Scalers) as Exports 12 | import Gesso.Geometry.Scaler ((*~>), (-~>), (/~>), (<~*), (<~-), (<~/), (<~|), (|~>), Scaler, from, lengthFrom, lengthTo, to, xFrom, xTo, yFrom, yTo) as Exports 13 | import Web.UIEvent.MouseEvent (MouseEvent) 14 | import Web.UIEvent.MouseEvent (pageX, pageY) as MouseEvent 15 | 16 | -- | Extract `x` and `y` coordinates from a `MouseEvent` using the 17 | -- | [`pageX` and `pageY` properties](https://developer.mozilla.org/en-US/docs/Web/API/MouseEvent/pageX) 18 | fromMouseEvent :: MouseEvent -> Point 19 | fromMouseEvent event = 20 | { x: toNumber $ MouseEvent.pageX event 21 | , y: toNumber $ MouseEvent.pageY event 22 | } 23 | -------------------------------------------------------------------------------- /src/Gesso/Geometry/Dimensions.purs: -------------------------------------------------------------------------------- 1 | -- | A collection of types and functions for specifying sizes and positions. 2 | module Gesso.Geometry.Dimensions 3 | ( Area 4 | , Point 5 | , Position 6 | , Rect 7 | , Rectangular 8 | , Size 9 | , largestContainedArea 10 | , null 11 | , origin 12 | , sizeless 13 | ) where 14 | 15 | import Prelude 16 | 17 | import Type.Row (type (+)) 18 | 19 | -- | A row representing anything that can have `x` and `y` values. 20 | type Position :: Type -> Row Type -> Row Type 21 | type Position a r = 22 | ( x :: a 23 | , y :: a 24 | | r 25 | ) 26 | 27 | -- | An `(x, y)` coordinate 28 | type Point :: Type 29 | type Point = { | Position Number () } 30 | 31 | -- | A row representing anything that can have a `width` and `height`. 32 | type Size :: Type -> Row Type -> Row Type 33 | type Size a r = 34 | ( width :: a 35 | , height :: a 36 | | r 37 | ) 38 | 39 | -- | The size of a rectangle. 40 | type Area :: Type 41 | type Area = { | Size Number () } 42 | 43 | -- | A row representing anything that can have `x`, `y`, `width`, and `height` 44 | -- | properties. 45 | type Rectangular :: Type -> Row Type -> Row Type 46 | type Rectangular a r = Position a + Size a + r 47 | 48 | -- | A rectangle positioned in space. 49 | type Rect :: Type 50 | type Rect = { | Rectangular Number () } 51 | 52 | -- | Given the sizes of an inner and an outer rectangle, find the largest size 53 | -- | the inner can be scaled to while still fitting entirely within the outer. 54 | largestContainedArea 55 | :: forall r1 r2 56 | . { | Size Number r1 } 57 | -> { | Size Number r2 } 58 | -> Area 59 | largestContainedArea drawing canvas = area 60 | where 61 | area 62 | | widthLimited.height <= canvas.height = widthLimited 63 | | otherwise = heightLimited 64 | 65 | ratio = drawing.width / drawing.height 66 | 67 | widthLimited = 68 | { width: canvas.width 69 | , height: canvas.width / ratio 70 | } 71 | 72 | heightLimited = 73 | { height: canvas.height 74 | , width: canvas.height * ratio 75 | } 76 | 77 | -- | A `Point` at `(0.0, 0.0)` 78 | origin :: Point 79 | origin = { x: 0.0, y: 0.0 } 80 | 81 | -- | An `Area` with no width or height 82 | sizeless :: Area 83 | sizeless = { width: 0.0, height: 0.0 } 84 | 85 | -- | A `Rect` with no width or height, located at the origin. 86 | null :: Rect 87 | null = { x: 0.0, y: 0.0, width: 0.0, height: 0.0 } 88 | -------------------------------------------------------------------------------- /src/Gesso/Geometry/Internal.purs: -------------------------------------------------------------------------------- 1 | module Gesso.Geometry.Internal (Scalers, mkScalers) where 2 | 3 | import Prelude 4 | 5 | import Gesso.Geometry.Dimensions (Rect, largestContainedArea) 6 | import Gesso.Geometry.Scaler (Scaler, mkScaler) 7 | 8 | -- | Data and functions for converting between the coordinate systems of the 9 | -- | canvas element on the page and the view box of the application/drawing. 10 | -- | 11 | -- | `scale` is the amount that the view box has been scaled up or down to fit 12 | -- | within the canvas element. 13 | -- | 14 | -- | `canvas` and `drawing` contain the dimensions of the named space and 15 | -- | functions for converting coordinates to itself. 16 | type Scalers = 17 | { scale :: Number 18 | , canvas :: Scaler 19 | , drawing :: Scaler 20 | } 21 | 22 | -- | Create a `Scalers` record based on the view box of the application and the 23 | -- | client rect ([`Gesso.Canvas.Element.getCanvasClientRect`](Gesso.Canvas.Element.html#v:getCanvasClientRect), 24 | -- | [MDN: DOMRect](https://developer.mozilla.org/en-US/docs/Web/API/DOMRect)) 25 | -- | of the canvas. 26 | mkScalers :: Rect -> Rect -> Scalers 27 | mkScalers viewBox clientRect = 28 | { scale: k 29 | , drawing: mkScaler viewBox toDrawing 30 | , canvas: mkScaler 31 | clientRect { x = 0.0, y = 0.0 } 32 | toCanvas 33 | } 34 | where 35 | fullView = largestContainedArea viewBox clientRect 36 | 37 | margin = 38 | { width: (clientRect.width - fullView.width) / 2.0 39 | , height: (clientRect.height - fullView.height) / 2.0 40 | } 41 | 42 | k = viewBox.width / fullView.width 43 | 44 | toCanvas = 45 | { x: (_ / k) >>> add margin.width >>> (_ - (viewBox.x / k)) 46 | , y: (_ / k) >>> add margin.height >>> (_ - (viewBox.y / k)) 47 | , length: (_ / k) 48 | } 49 | 50 | toDrawing = 51 | { x: (_ - (clientRect.x + margin.width)) >>> mul k >>> add viewBox.x 52 | , y: (_ - (clientRect.y + margin.height)) >>> mul k >>> add viewBox.y 53 | , length: mul k 54 | } 55 | -------------------------------------------------------------------------------- /src/Gesso/Geometry/Scaler.purs: -------------------------------------------------------------------------------- 1 | module Gesso.Geometry.Scaler 2 | ( (*~>) 3 | , (-~>) 4 | , (/~>) 5 | , (<~*) 6 | , (<~-) 7 | , (<~/) 8 | , (<~|) 9 | , (|~>) 10 | , Scaler 11 | , ScalingFunctions 12 | , class Scalable 13 | , from 14 | , lengthFrom 15 | , lengthTo 16 | , mkScaler 17 | , scale 18 | , to 19 | , xFrom 20 | , xTo 21 | , yFrom 22 | , yTo 23 | ) where 24 | 25 | import Prelude 26 | 27 | import Data.Map (Map) 28 | import Data.Map (fromFoldable, lookup) as Map 29 | import Data.Maybe (Maybe, fromMaybe) 30 | import Data.Symbol (reflectSymbol, class IsSymbol) 31 | import Data.Tuple.Nested ((/\)) 32 | import Gesso.Geometry.Dimensions (Position, Rect, Rectangular) 33 | import Record (delete, get) as Record 34 | import Record.Builder (Builder, buildFromScratch, nub) 35 | import Record.Builder (insert) as Builder 36 | import Type.Proxy (Proxy(..)) 37 | import Type.Row (class Cons, class Lacks, type (+)) 38 | import Type.RowList (RowList, class RowToList, Cons, Nil) 39 | 40 | -- ┌───────────────────────────┐ 41 | -- │ Dimension & scaling types │ 42 | -- └───────────────────────────┘ 43 | 44 | -- | `x`, `y`, and `length` `Number -> Number` functions for converting between 45 | -- | coordinate systems. 46 | type ScalingFunctions :: Row Type 47 | type ScalingFunctions = 48 | Position (Number -> Number) + (length :: Number -> Number) 49 | 50 | -- | Data and functions for working with a coordinate system: 51 | -- | 52 | -- | The `x`, `y`, `width`, and `height` fields are the origin and size of the 53 | -- | system. The `rect` field contains all of them as well - sometimes it's 54 | -- | easier to access them indiviually, and sometimes it's easier to access them 55 | -- | as a complete `Rect`. 56 | -- | 57 | -- | `scaling` contains functions to scale `x`, `y`, `length`, and entire 58 | -- | records, but they're more convenient to use with the `to` and `from` 59 | -- | functions rather than being called directly: 60 | -- | 61 | -- | ```purescript 62 | -- | -- this: 63 | -- | { x: 1.0, y: 2.0 } `to` canvas 64 | -- | 65 | -- | -- not: 66 | -- | canvas.scaling.all { x: 1.0, y: 2.0 } 67 | -- | ``` 68 | type Scaler :: Type 69 | type Scaler = 70 | { | Rectangular Number + 71 | ( scaling :: 72 | { all :: 73 | forall rl r 74 | . RowToList r rl 75 | => Scalable rl r Number 76 | => { | r } 77 | -> Builder {} { | r } 78 | | ScalingFunctions 79 | } 80 | , rect :: Rect 81 | ) 82 | } 83 | 84 | -- ┌────────────────────┐ 85 | -- │ Scaling operations │ 86 | -- └────────────────────┘ 87 | 88 | -- | Convert fields in an arbitrary record to the coordinate system of a 89 | -- | `Scaler`. If any of these fields is found and has type `Number`, it will be 90 | -- | converted: 91 | -- | 92 | -- | - `x` fields: `x`, `x1`, `x2` 93 | -- | - `y` fields: `y`, `y1`, `y2` 94 | -- | - `length` fields: `width`, `w`, `height`, `h`, `radius`, `r`, `length`, 95 | -- | `len`, `l` 96 | -- | 97 | -- | ```purescript 98 | -- | line' = { x1: 0.0, y1: 0.0, x2: 1.0, y2: 1.0 } `to` canvas 99 | -- | circle' = { x: 0.0, y: 0.0, r: 1.0 } `to` canvas 100 | -- | ``` 101 | to 102 | :: forall rl r 103 | . RowToList r rl 104 | => Scalable rl r Number 105 | => { | r } 106 | -> Scaler 107 | -> { | r } 108 | to r { scaling: { all } } = buildFromScratch $ all r 109 | 110 | -- | [`to`](#v:to) with arguments flipped: 111 | -- | 112 | -- | ```purescript 113 | -- | line' = canvas `from` { x1: 0.0, y1: 0.0, x2: 1.0, y2: 1.0 } 114 | -- | circle' = canvas `from` { x: 0.0, y: 0.0, r: 1.0 } 115 | -- | ``` 116 | from 117 | :: forall rl r 118 | . RowToList r rl 119 | => Scalable rl r Number 120 | => Scaler 121 | -> { | r } 122 | -> { | r } 123 | from = flip to 124 | 125 | -- | Convert a single `x` value to the coordinate system of a `Scaler`: 126 | -- | ```purescript 127 | -- | x' = x `xTo` canvas 128 | -- | ``` 129 | xTo :: Number -> Scaler -> Number 130 | xTo n { scaling: { x } } = x n 131 | 132 | -- | [`xTo`](#v:xTo) with arguments flipped: 133 | -- | ```purescript 134 | -- | x' = canvas `xFrom` x 135 | -- | ``` 136 | xFrom :: Scaler -> Number -> Number 137 | xFrom = flip xTo 138 | 139 | -- | Convert a single `y` value to the coordinate system of a `Scaler`: 140 | -- | ```purescript 141 | -- | y' = y `yTo` canvas 142 | -- | ``` 143 | yTo :: Number -> Scaler -> Number 144 | yTo n { scaling: { y } } = y n 145 | 146 | -- | [`yTo`](#v:yTo) with arguments flipped: 147 | -- | ```purescript 148 | -- | y' = canvas `yFrom` y 149 | -- | ``` 150 | yFrom :: Scaler -> Number -> Number 151 | yFrom = flip yTo 152 | 153 | -- | Convert a single `length` value to the coordinate system of a `Scaler`: 154 | -- | ```purescript 155 | -- | l' = l `lengthTo` canvas 156 | -- | ``` 157 | lengthTo :: Number -> Scaler -> Number 158 | lengthTo n { scaling: { length } } = length n 159 | 160 | -- | [`lengthTo`](#v:lengthTo) with arguments flipped: 161 | -- | ```purescript 162 | -- | l' = canvas `lengthFrom` l 163 | -- | ``` 164 | lengthFrom :: Scaler -> Number -> Number 165 | lengthFrom = flip lengthTo 166 | 167 | -- | Convert an arbitrary record to the coordinate system of a `Scaler`: 168 | -- | ```purescript 169 | -- | line' = { x1: 0.0, y1: 0.0, x2: 1.0, y2: 1.0 } *~> canvas 170 | -- | circle' = { x: 0.0, y: 0.0, r: 1.0 } *~> canvas 171 | -- | ``` 172 | infix 2 to as *~> 173 | 174 | -- | [`to`](#v:to) with arguments flipped: 175 | -- | ```purescript 176 | -- | line' = canvas <~* { x1: 0.0, y1: 0.0, x2: 1.0, y2: 1.0 } 177 | -- | circle' = canvas <~* { x: 0.0, y: 0.0, r: 1.0 } 178 | -- | ``` 179 | infix 2 from as <~* 180 | 181 | -- | Convert a single `x` value to the coordinate system of a `Scaler`: 182 | -- | ```purescript 183 | -- | x' = x -~> canvas 184 | -- | ``` 185 | infix 2 xTo as -~> 186 | 187 | -- | [`xTo`](#v:xTo) with arguments flipped: 188 | -- | ```purescript 189 | -- | x' = canvas <~- x 190 | -- | ``` 191 | infix 2 xFrom as <~- 192 | 193 | -- | Convert a single `y` value to the coordinate system of a `Scaler`: 194 | -- | ```purescript 195 | -- | y' = y |~> canvas 196 | -- | ``` 197 | infix 2 yTo as |~> 198 | 199 | -- | [`yTo`](#v:yTo) with arguments flipped: 200 | -- | ```purescript 201 | -- | y' = canvas <~| y 202 | -- | ``` 203 | infix 2 yFrom as <~| 204 | 205 | -- | Convert a single `length` value to the coordinate system of a `Scaler`: 206 | -- | ```purescript 207 | -- | l' = l /~> canvas 208 | -- | ``` 209 | infix 2 lengthTo as /~> 210 | 211 | -- | [`lengthTo`](#v:lengthTo) with arguments flipped: 212 | -- | ```purescript 213 | -- | l' = canvas <~/ l 214 | -- | ``` 215 | infix 2 lengthFrom as <~/ 216 | 217 | -- ┌─────────────────┐ 218 | -- │ Scaler creation │ 219 | -- └─────────────────┘ 220 | 221 | -- | Create a `Scaler` record for a coordinate system using its dimensions and 222 | -- | `x`, `y`, and `length` scaling functions. 223 | mkScaler :: Rect -> { | ScalingFunctions } -> Scaler 224 | mkScaler rect fns = 225 | { x: rect.x 226 | , y: rect.y 227 | , width: rect.width 228 | , height: rect.height 229 | , rect 230 | , scaling: 231 | { x: fns.x 232 | , y: fns.y 233 | , length: fns.length 234 | , all 235 | } 236 | } 237 | where 238 | all 239 | :: forall rl r 240 | . RowToList r rl 241 | => Scalable rl r Number 242 | => { | r } 243 | -> Builder {} { | r } 244 | all = scale @rl $ toMap fns 245 | 246 | toMap :: { | ScalingFunctions } -> Map String (Number -> Number) 247 | toMap { x, y, length } = Map.fromFoldable 248 | [ "x" /\ x 249 | , "x1" /\ x 250 | , "x2" /\ x 251 | , "y" /\ y 252 | , "y1" /\ y 253 | , "y2" /\ y 254 | , "width" /\ length 255 | , "w" /\ length 256 | , "height" /\ length 257 | , "h" /\ length 258 | , "radius" /\ length 259 | , "r" /\ length 260 | , "length" /\ length 261 | , "len" /\ length 262 | , "l" /\ length 263 | ] 264 | 265 | -- | Typeclass for an arbitrary record. `scale` walks through the fields of a 266 | -- | record, and if any value `:: a`, checks if the map has a function with the 267 | -- | same key. If so, applies the function to the value. 268 | class Scalable :: RowList Type -> Row Type -> Type -> Constraint 269 | class (RowToList r rl) <= Scalable rl r a | rl -> r where 270 | scale :: Map String (a -> a) -> { | r } -> Builder {} { | r } 271 | 272 | instance scalableRecEmpty :: Scalable Nil () a where 273 | scale _ _ = nub 274 | 275 | instance scalableRecScalableType :: 276 | ( RowToList r (Cons k a tl) 277 | , IsSymbol k 278 | , Cons k a t r 279 | , Lacks k t 280 | , Scalable tl t a 281 | ) => 282 | Scalable (Cons k a tl) r a where 283 | scale m r = scaleRecScalableType @k m r <<< scaleRecRecur @tl @k m r 284 | 285 | else instance scalableRecOtherType :: 286 | ( RowToList r (Cons k v tl) 287 | , IsSymbol k 288 | , Cons k v t r 289 | , Lacks k t 290 | , Scalable tl t a 291 | ) => 292 | Scalable (Cons k v tl) r a where 293 | scale m r = scaleRecOtherType @k r <<< scaleRecRecur @tl @k m r 294 | 295 | scaleRecScalableType 296 | :: forall @k a t r 297 | . IsSymbol k 298 | => Cons k a t r 299 | => Lacks k t 300 | => Map String (a -> a) 301 | -> { | r } 302 | -> Builder { | t } { | r } 303 | scaleRecScalableType m = 304 | insert @k <<< fromMaybe identity (lookup @k m) <<< get @k 305 | 306 | scaleRecOtherType 307 | :: forall @k a t r 308 | . IsSymbol k 309 | => Cons k a t r 310 | => Lacks k t 311 | => { | r } 312 | -> Builder { | t } { | r } 313 | scaleRecOtherType = insert @k <<< get @k 314 | 315 | scaleRecRecur 316 | :: forall @tl @k a v t r 317 | . RowToList t tl 318 | => Scalable tl t a 319 | => IsSymbol k 320 | => Cons k v t r 321 | => Lacks k t 322 | => Map String (a -> a) 323 | -> { | r } 324 | -> Builder {} { | t } 325 | scaleRecRecur m = scale @tl m <<< delete @k 326 | 327 | -- Aliases for functions that use proxies 328 | lookup :: forall @k a. IsSymbol k => Map String (a -> a) -> Maybe (a -> a) 329 | lookup = Map.lookup $ reflectSymbol $ Proxy @k 330 | 331 | insert 332 | :: forall @k a t r 333 | . IsSymbol k 334 | => Cons k a t r 335 | => Lacks k t 336 | => a 337 | -> Builder { | t } { | r } 338 | insert = Builder.insert $ Proxy @k 339 | 340 | get :: forall @k a t r. IsSymbol k => Cons k a t r => Lacks k t => { | r } -> a 341 | get = Record.get $ Proxy @k 342 | 343 | delete 344 | :: forall @k a t r 345 | . IsSymbol k 346 | => Cons k a t r 347 | => Lacks k t 348 | => { | r } 349 | -> { | t } 350 | delete = Record.delete $ Proxy @k 351 | -------------------------------------------------------------------------------- /src/Gesso/Interactions.purs: -------------------------------------------------------------------------------- 1 | -- | Interactions are a wrapper for HTML events that allow specifying event 2 | -- | types and handlers which are attached to the canvas when it's created. 3 | -- | Interactions are part of the `AppSpec` and will typically be specified as 4 | -- | an update of the [`default`](#v:default) record, similar to `mkEval` and 5 | -- | `defaultEval` in Halogen. 6 | -- | 7 | -- | The [`Interactions`](#t:Interactions) type is a record of arrays of 8 | -- | interactions for each event type. 9 | module Gesso.Interactions 10 | ( ClipboardInteraction 11 | , DragInteraction 12 | , EventInteraction 13 | , FocusInteraction 14 | , KeyboardInteraction 15 | , MouseInteraction 16 | , PointerInteraction 17 | , TouchInteraction 18 | , WheelInteraction 19 | , default 20 | , module Exports 21 | ) where 22 | 23 | import Gesso.Interactions.Internal (Interactions, Interaction) 24 | import Gesso.Interactions.Internal (ClipboardEvent, DragEvent, Event, FocusEvent, Handler, Interaction, Interactions, KeyboardEvent, MouseEvent, PointerEvent, TouchEvent, WheelEvent) as Exports 25 | import Gesso.Interactions.Events (onAuxClick, onBlur, onClick, onCopy, onCut, onDoubleClick, onDrag, onDragEnd, onDragEnter, onDragExit, onDragLeave, onDragOver, onDragStart, onDrop, onFocus, onFocusIn, onFocusOut, onInput, onKeyDown, onKeyUp, onMouseDown, onMouseEnter, onMouseLeave, onMouseMove, onMouseOut, onMouseOver, onMouseUp, onPaste, onTouchCancel, onTouchEnd, onTouchEnter, onTouchLeave, onTouchMove, onTouchStart, onTransitionEnd, onWheel) as Exports 26 | 27 | -- | A default `Interactions` record containing no interactions. The attributes 28 | -- | can be overridden individually instead of manually creating a complete but 29 | -- | mostly empty record. For example, 30 | -- | ``` 31 | -- | Interactions.default { keyboard = [ handleKeyDown ] } 32 | -- | ``` 33 | default :: forall state. Interactions state 34 | default = 35 | { base: [] 36 | , clipboard: [] 37 | , focus: [] 38 | , keyboard: [] 39 | , touch: [] 40 | , drag: [] 41 | , mouse: [] 42 | , wheel: [] 43 | , pointer: [] 44 | } 45 | 46 | type ClipboardInteraction state = Interaction Exports.ClipboardEvent state 47 | 48 | type DragInteraction state = Interaction Exports.DragEvent state 49 | 50 | type EventInteraction state = Interaction Exports.Event state 51 | 52 | type FocusInteraction state = Interaction Exports.FocusEvent state 53 | 54 | type KeyboardInteraction state = Interaction Exports.KeyboardEvent state 55 | 56 | type MouseInteraction state = Interaction Exports.MouseEvent state 57 | 58 | type PointerInteraction state = Interaction Exports.PointerEvent state 59 | 60 | type TouchInteraction state = Interaction Exports.TouchEvent state 61 | 62 | type WheelInteraction state = Interaction Exports.WheelEvent state 63 | -------------------------------------------------------------------------------- /src/Gesso/Interactions/Events.purs: -------------------------------------------------------------------------------- 1 | -- | This module contains constructors for Interactions for event properties 2 | -- | that Canvas supports. The list of properties comes from 3 | -- | [`DOM.HTML.Indexed.HTMLcanvas`](https://pursuit.purescript.org/packages/purescript-dom-indexed/7.0.0/docs/DOM.HTML.Indexed#t:HTMLcanvas). 4 | -- | A number of those event properties are not currently exported by 5 | -- | `Halogen.HTML.Events`. For completeness, they are included here but 6 | -- | commented out. 7 | module Gesso.Interactions.Events 8 | ( onAuxClick 9 | -- , onBeforeInput 10 | , onBlur 11 | , onClick 12 | -- , onContextMenu 13 | , onCopy 14 | , onCut 15 | , onDoubleClick 16 | , onDrag 17 | , onDragEnd 18 | , onDragEnter 19 | , onDragExit 20 | , onDragLeave 21 | , onDragOver 22 | , onDragStart 23 | , onDrop 24 | , onFocus 25 | , onFocusIn 26 | , onFocusOut 27 | -- , onGotPointerCapture 28 | , onInput 29 | , onKeyDown 30 | -- , onKeyPress 31 | , onKeyUp 32 | -- , onLostPointerCapture 33 | , onMouseDown 34 | , onMouseEnter 35 | , onMouseLeave 36 | , onMouseMove 37 | , onMouseOut 38 | , onMouseOver 39 | , onMouseUp 40 | , onPaste 41 | -- , onPointerCancel 42 | -- , onPointerDown 43 | -- , onPointerEnter 44 | -- , onPointerLeave 45 | -- , onPointerMove 46 | -- , onPointerOut 47 | -- , onPointerOver 48 | -- , onPointerUp 49 | , onTouchCancel 50 | , onTouchEnd 51 | , onTouchEnter 52 | , onTouchLeave 53 | , onTouchMove 54 | , onTouchStart 55 | , onTransitionEnd 56 | , onWheel 57 | ) where 58 | 59 | import Gesso.Interactions.Internal (ClipboardEvent, DragEvent, Event, FocusEvent, Handler, Interaction(..), KeyboardEvent, MouseEvent, TouchEvent, WheelEvent) 60 | import Halogen.HTML.Events (onAuxClick, onBlur, onClick, onCopy, onCut, onDoubleClick, onDrag, onDragEnd, onDragEnter, onDragExit, onDragLeave, onDragOver, onDragStart, onDrop, onFocus, onFocusIn, onFocusOut, onInput, onKeyDown, onKeyUp, onMouseDown, onMouseEnter, onMouseLeave, onMouseMove, onMouseOut, onMouseOver, onMouseUp, onPaste, onTouchCancel, onTouchEnd, onTouchEnter, onTouchLeave, onTouchMove, onTouchStart, onTransitionEnd, onWheel) as HE 61 | 62 | onAuxClick :: forall s. Handler MouseEvent s -> Interaction MouseEvent s 63 | onAuxClick = Interaction HE.onAuxClick 64 | 65 | -- onBeforeInput :: forall s. Handler Event s -> Interaction Event s 66 | -- onBeforeInput = Interaction HE.onBeforeInput 67 | 68 | onBlur :: forall s. Handler FocusEvent s -> Interaction FocusEvent s 69 | onBlur = Interaction HE.onBlur 70 | 71 | onClick :: forall s. Handler MouseEvent s -> Interaction MouseEvent s 72 | onClick = Interaction HE.onClick 73 | 74 | -- onContextMenu :: forall s. Handler MouseEvent s -> Interaction MouseEvent s 75 | -- onContextMenu = Interaction HE.onContextMenu 76 | 77 | onCopy :: forall s. Handler ClipboardEvent s -> Interaction ClipboardEvent s 78 | onCopy = Interaction HE.onCopy 79 | 80 | onCut :: forall s. Handler ClipboardEvent s -> Interaction ClipboardEvent s 81 | onCut = Interaction HE.onCut 82 | 83 | onDoubleClick :: forall s. Handler MouseEvent s -> Interaction MouseEvent s 84 | onDoubleClick = Interaction HE.onDoubleClick 85 | 86 | onDrag :: forall s. Handler DragEvent s -> Interaction DragEvent s 87 | onDrag = Interaction HE.onDrag 88 | 89 | onDragEnd :: forall s. Handler DragEvent s -> Interaction DragEvent s 90 | onDragEnd = Interaction HE.onDragEnd 91 | 92 | onDragEnter :: forall s. Handler DragEvent s -> Interaction DragEvent s 93 | onDragEnter = Interaction HE.onDragEnter 94 | 95 | onDragExit :: forall s. Handler DragEvent s -> Interaction DragEvent s 96 | onDragExit = Interaction HE.onDragExit 97 | 98 | onDragLeave :: forall s. Handler DragEvent s -> Interaction DragEvent s 99 | onDragLeave = Interaction HE.onDragLeave 100 | 101 | onDragOver :: forall s. Handler DragEvent s -> Interaction DragEvent s 102 | onDragOver = Interaction HE.onDragOver 103 | 104 | onDragStart :: forall s. Handler DragEvent s -> Interaction DragEvent s 105 | onDragStart = Interaction HE.onDragStart 106 | 107 | onDrop :: forall s. Handler DragEvent s -> Interaction DragEvent s 108 | onDrop = Interaction HE.onDrop 109 | 110 | onFocus :: forall s. Handler FocusEvent s -> Interaction FocusEvent s 111 | onFocus = Interaction HE.onFocus 112 | 113 | onFocusIn :: forall s. Handler FocusEvent s -> Interaction FocusEvent s 114 | onFocusIn = Interaction HE.onFocusIn 115 | 116 | onFocusOut :: forall s. Handler FocusEvent s -> Interaction FocusEvent s 117 | onFocusOut = Interaction HE.onFocusOut 118 | 119 | -- onGotPointerCapture :: forall s. Handler PointerEvent s -> Interaction PointerEvent s 120 | -- onGotPointerCapture = Interaction HE.onGotPointerCapture 121 | 122 | onInput :: forall s. Handler Event s -> Interaction Event s 123 | onInput = Interaction HE.onInput 124 | 125 | onKeyDown :: forall s. Handler KeyboardEvent s -> Interaction KeyboardEvent s 126 | onKeyDown = Interaction HE.onKeyDown 127 | 128 | -- onKeyPress :: forall s. Handler KeyboardEvent s -> Interaction KeyboardEvent s 129 | -- onKeyPress = Interaction HE.onKeyPress 130 | 131 | onKeyUp :: forall s. Handler KeyboardEvent s -> Interaction KeyboardEvent s 132 | onKeyUp = Interaction HE.onKeyUp 133 | 134 | -- onLostPointerCapture :: forall s. Handler PointerEvent s -> Interaction PointerEvent s 135 | -- onLostPointerCapture = Interaction HE.onLostPointerCapture 136 | 137 | onMouseDown :: forall s. Handler MouseEvent s -> Interaction MouseEvent s 138 | onMouseDown = Interaction HE.onMouseDown 139 | 140 | onMouseEnter :: forall s. Handler MouseEvent s -> Interaction MouseEvent s 141 | onMouseEnter = Interaction HE.onMouseEnter 142 | 143 | onMouseLeave :: forall s. Handler MouseEvent s -> Interaction MouseEvent s 144 | onMouseLeave = Interaction HE.onMouseLeave 145 | 146 | onMouseMove :: forall s. Handler MouseEvent s -> Interaction MouseEvent s 147 | onMouseMove = Interaction HE.onMouseMove 148 | 149 | onMouseOut :: forall s. Handler MouseEvent s -> Interaction MouseEvent s 150 | onMouseOut = Interaction HE.onMouseOut 151 | 152 | onMouseOver :: forall s. Handler MouseEvent s -> Interaction MouseEvent s 153 | onMouseOver = Interaction HE.onMouseOver 154 | 155 | onMouseUp :: forall s. Handler MouseEvent s -> Interaction MouseEvent s 156 | onMouseUp = Interaction HE.onMouseUp 157 | 158 | onPaste :: forall s. Handler ClipboardEvent s -> Interaction ClipboardEvent s 159 | onPaste = Interaction HE.onPaste 160 | 161 | -- onPointerCancel :: forall s. Handler PointerEvent s -> Interaction PointerEvent s 162 | -- onPointerCancel = Interaction HE.onPointerCancel 163 | 164 | -- onPointerDown :: forall s. Handler PointerEvent s -> Interaction PointerEvent s 165 | -- onPointerDown = Interaction HE.onPointerDown 166 | 167 | -- onPointerEnter :: forall s. Handler PointerEvent s -> Interaction PointerEvent s 168 | -- onPointerEnter = Interaction HE.onPointerEnter 169 | 170 | -- onPointerLeave :: forall s. Handler PointerEvent s -> Interaction PointerEvent s 171 | -- onPointerLeave = Interaction HE.onPointerLeave 172 | 173 | -- onPointerMove :: forall s. Handler PointerEvent s -> Interaction PointerEvent s 174 | -- onPointerMove = Interaction HE.onPointerMove 175 | 176 | -- onPointerOut :: forall s. Handler PointerEvent s -> Interaction PointerEvent s 177 | -- onPointerOut = Interaction HE.onPointerOut 178 | 179 | -- onPointerOver :: forall s. Handler PointerEvent s -> Interaction PointerEvent s 180 | -- onPointerOver = Interaction HE.onPointerOver 181 | 182 | -- onPointerUp :: forall s. Handler PointerEvent s -> Interaction PointerEvent s 183 | -- onPointerUp = Interaction HE.onPointerUp 184 | 185 | onTouchCancel :: forall s. Handler TouchEvent s -> Interaction TouchEvent s 186 | onTouchCancel = Interaction HE.onTouchCancel 187 | 188 | onTouchEnd :: forall s. Handler TouchEvent s -> Interaction TouchEvent s 189 | onTouchEnd = Interaction HE.onTouchEnd 190 | 191 | onTouchEnter :: forall s. Handler TouchEvent s -> Interaction TouchEvent s 192 | onTouchEnter = Interaction HE.onTouchEnter 193 | 194 | onTouchLeave :: forall s. Handler TouchEvent s -> Interaction TouchEvent s 195 | onTouchLeave = Interaction HE.onTouchLeave 196 | 197 | onTouchMove :: forall s. Handler TouchEvent s -> Interaction TouchEvent s 198 | onTouchMove = Interaction HE.onTouchMove 199 | 200 | onTouchStart :: forall s. Handler TouchEvent s -> Interaction TouchEvent s 201 | onTouchStart = Interaction HE.onTouchStart 202 | 203 | onTransitionEnd :: forall s. Handler Event s -> Interaction Event s 204 | onTransitionEnd = Interaction HE.onTransitionEnd 205 | 206 | onWheel :: forall s. Handler WheelEvent s -> Interaction WheelEvent s 207 | onWheel = Interaction HE.onWheel 208 | -------------------------------------------------------------------------------- /src/Gesso/Interactions/Internal.purs: -------------------------------------------------------------------------------- 1 | -- | Definitions of the Interaction type as well as event handlers and event 2 | -- | listener HTML properties. 3 | module Gesso.Interactions.Internal 4 | ( EventProp 5 | , Handler 6 | , Interaction(..) 7 | , Interactions 8 | , toProps 9 | , module Exports 10 | ) where 11 | 12 | import Prelude 13 | 14 | import DOM.HTML.Indexed (HTMLcanvas) 15 | import Gesso.Application.Behavior (UpdateFunction) as App 16 | import Halogen.HTML.Properties (IProp) 17 | import Web.Clipboard.ClipboardEvent (ClipboardEvent) as Exports 18 | import Web.Event.Internal.Types (Event) as Exports 19 | import Web.HTML.Event.DragEvent (DragEvent) as Exports 20 | import Web.PointerEvent (PointerEvent) as Exports 21 | import Web.TouchEvent.TouchEvent (TouchEvent) as Exports 22 | import Web.UIEvent.FocusEvent (FocusEvent) as Exports 23 | import Web.UIEvent.KeyboardEvent (KeyboardEvent) as Exports 24 | import Web.UIEvent.MouseEvent (MouseEvent) as Exports 25 | import Web.UIEvent.WheelEvent (WheelEvent) as Exports 26 | 27 | -- | An `IProp` is an HTML property, with kind 28 | -- | `IProp :: Row Type -> Type -> Type`, where the row type is the set of all 29 | -- | valid properties for the element that this property will be attached to. 30 | -- | 31 | -- | Typically, an event listener type would look like this: 32 | -- | ``` 33 | -- | onMouseMove 34 | -- | :: forall r i 35 | -- | . (MouseEvent -> i) 36 | -- | -> IProp (onMouseMove :: MouseEvent | r) i 37 | -- | ``` 38 | -- | where the event type is predetermined and the row type is parameterized to 39 | -- | allow any element with an `onMouseMove` property. 40 | -- | 41 | -- | This generic `EventProp` is the inverse: parameterized to allow any event 42 | -- | type, but the property must be a valid property of the `HTMLcanvas` row. 43 | type EventProp event i = (event -> i) -> IProp HTMLcanvas i 44 | 45 | -- | An event handler is a variant of an update function, which receives an 46 | -- | event and produces an update function in response. 47 | type Handler event state = event -> App.UpdateFunction state 48 | 49 | -- | An Interaction is a combination event listener and handler which is turned 50 | -- | into an HTML property and attached to a Gesso canvas. They can be 51 | -- | constructed with the "`on`" functions (`onMouseMove`, `onKeyDown`, etc.) 52 | data Interaction event state = 53 | Interaction (forall i. EventProp event i) (Handler event state) 54 | 55 | -- | `Interactions` is a record containing arrays of interactions for each type 56 | -- | of event that Canvas supports. It's used in 57 | -- | [`Gesso.Application.AppBehavior`](Gesso.Application.html#t:AppBehavior) 58 | -- | to add event handlers to a component. 59 | type Interactions state = 60 | { base :: Array (Interaction Exports.Event state) 61 | , clipboard :: Array (Interaction Exports.ClipboardEvent state) 62 | , focus :: Array (Interaction Exports.FocusEvent state) 63 | , keyboard :: Array (Interaction Exports.KeyboardEvent state) 64 | , touch :: Array (Interaction Exports.TouchEvent state) 65 | , drag :: Array (Interaction Exports.DragEvent state) 66 | , mouse :: Array (Interaction Exports.MouseEvent state) 67 | , wheel :: Array (Interaction Exports.WheelEvent state) 68 | , pointer :: Array (Interaction Exports.PointerEvent state) 69 | } 70 | 71 | -- | Convert an `Interactions` record to an array of HTML properties. The return 72 | -- | value of the `toCallback` parameter, `i`, is only known by the component 73 | -- | and should be whatever `Action` type the component has, like `QueueUpdate` 74 | -- | in Canvas. 75 | toProps 76 | :: forall state i 77 | . (App.UpdateFunction state -> i) 78 | -> Interactions state 79 | -> Array (IProp HTMLcanvas i) 80 | toProps 81 | toCallback 82 | { base, clipboard, focus, keyboard, touch, drag, mouse, wheel } = 83 | map toProp base 84 | <> map toProp clipboard 85 | <> map toProp focus 86 | <> map toProp keyboard 87 | <> map toProp touch 88 | <> map toProp drag 89 | <> map toProp mouse 90 | <> map toProp wheel 91 | where 92 | toProp :: forall e. Interaction e state -> IProp HTMLcanvas i 93 | toProp (Interaction onEvent handler) = 94 | onEvent $ toCallback <<< handler 95 | -------------------------------------------------------------------------------- /src/Gesso/State.purs: -------------------------------------------------------------------------------- 1 | -- | Types used when dealing with multiple versions of the same thing - most 2 | -- | often, the application state. 3 | module Gesso.State 4 | ( Compare 5 | , History 6 | , States 7 | , lerp 8 | ) where 9 | 10 | import Prelude 11 | 12 | -- | Two different versions of the same thing. Used when the old and new 13 | -- | versions are probably not immediately sequential - there may have been many 14 | -- | versions between `old` and `new`. 15 | type Compare a = { old :: a, new :: a } 16 | 17 | -- | A record for keeping track of changes to a value which may change many 18 | -- | times, when it is important to track the original, current, and previous 19 | -- | values, and comparing the values directly is impossible. Useful as an 20 | -- | accumulator when folding. 21 | type History a = 22 | { old :: a 23 | , new :: a 24 | , original :: a 25 | , changed :: Boolean 26 | } 27 | 28 | -- | Two different, sequential versions of the same thing, and the amount of 29 | -- | progress from the earlier to the later. `t` should be in the interval 30 | -- | `[0, 1]`. 31 | type States a = { current :: a, previous :: a, t :: Number } 32 | 33 | -- | Calculate the linear interpolation between two values 34 | lerp :: States Number -> Number 35 | lerp { current, previous, t } = (1.0 - t) * previous + t * current 36 | -------------------------------------------------------------------------------- /src/Gesso/Time.js: -------------------------------------------------------------------------------- 1 | export function _requestAnimationFrame(fn) { 2 | return function (window) { 3 | return function () { 4 | return window.requestAnimationFrame(fn); 5 | }; 6 | }; 7 | }; 8 | 9 | export function cancelAnimationFrame(id) { 10 | return function (window) { 11 | return function () { 12 | return window.cancelAnimationFrame(id); 13 | }; 14 | }; 15 | }; 16 | 17 | export function _now() { 18 | return performance.now(); 19 | } 20 | -------------------------------------------------------------------------------- /src/Gesso/Time.purs: -------------------------------------------------------------------------------- 1 | -- | Timestamps, time deltas, intervals, and `requestAnimationFrame` 2 | module Gesso.Time 3 | ( Delta 4 | , Interval 5 | , Last 6 | , Now 7 | , RequestAnimationFrameId 8 | , Stamped 9 | , StampedBatch 10 | , cancelAnimationFrame 11 | , delta 12 | , elapse 13 | , hz 14 | , never 15 | , requestAnimationFrame 16 | , sort 17 | , stamp 18 | , stampInterval 19 | , started 20 | , toRatio 21 | ) where 22 | 23 | import Prelude 24 | 25 | import Data.Function (on) 26 | import Data.List (List(..), head, (:), sortBy) 27 | import Data.Maybe (maybe) 28 | import Data.Number (isFinite) 29 | import Effect (Effect) 30 | import Effect.Uncurried (EffectFn1, mkEffectFn1) 31 | import Web.HTML (Window) 32 | 33 | -- | A `RequestAnimationFrameId` is returned when calling 34 | -- | `requestAnimationFrame`. This can be used to cancel the request. 35 | newtype RequestAnimationFrameId = RequestAnimationFrameId Int 36 | 37 | -- | Cancel a request for an animation frame using the `RequestAnimationFrameId` 38 | -- | returned by `requestAnimationFrame`. 39 | foreign import cancelAnimationFrame 40 | :: RequestAnimationFrameId -> Window -> Effect Unit 41 | 42 | foreign import _requestAnimationFrame 43 | :: EffectFn1 Now Unit -> Window -> Effect RequestAnimationFrameId 44 | 45 | -- | An interface to `window.requestAnimationFrame` which passes the timestamp 46 | -- | argument to the callback function. 47 | -- | 48 | -- | Provided because `requestAnimationFrame` in `Web.HTML.Window` only accepts 49 | -- | an `Effect Unit` instead of a `Number -> Effect Unit`. 50 | requestAnimationFrame 51 | :: (Now -> Effect Unit) 52 | -> Window 53 | -> Effect RequestAnimationFrameId 54 | requestAnimationFrame = _requestAnimationFrame <<< mkEffectFn1 55 | 56 | -- | The current time in milliseconds, or the time at which a value became 57 | -- | `Stamped`. 58 | newtype Now = Now Number 59 | 60 | -- | A time in the past, in milliseconds. 61 | newtype Last = Last Number 62 | 63 | -- | Convert a current time into a previous time. 64 | elapse :: Now -> Last 65 | elapse (Now t) = Last t 66 | 67 | -- | A current time, a previous time, and the difference between them. All 68 | -- | values are in milliseconds. 69 | -- | 70 | -- | For per-frame updates and the rendering function, `last` is the time of the 71 | -- | previous animation frame and `now` is the time of the current animation 72 | -- | frame. 73 | -- | 74 | -- | For fixed-rate updates, `last` is the scheduled time of the previous 75 | -- | fixed-rate update and `now` is the update's scheduled time. 76 | -- | 77 | -- | For interaction events and Halogen queries, `last` is the time of the 78 | -- | previous animation frame and `now` is the event's arrival time. 79 | type Delta = { now :: Number, last :: Number, delta :: Number } 80 | 81 | -- | Create a Delta from a current time and a previous time. 82 | delta :: Now -> Last -> Delta 83 | delta (Now now) (Last last) = { now, last, delta: now - last } 84 | 85 | -- | Get the current `DOMHighResTimeStamp` from `performance.now`. 86 | -- | 87 | -- | See [`DOMHighResTimeStamp`](https://developer.mozilla.org/en-US/docs/Web/API/DOMHighResTimeStamp) 88 | foreign import _now :: Effect Now 89 | 90 | -- | Get a single `Last` value at the current time, useful for starting a timer. 91 | started :: Effect Last 92 | started = elapse <$> _now 93 | 94 | -- | An item and a specific time associated with that item. Used for comparing 95 | -- | timestamped values produced by [`stamp`](#v:stamp) and 96 | -- | [`stampInterval`](#v:stampInterval). 97 | type Stamped a = { time :: Number, item :: a } 98 | 99 | -- | Sort a list of `Stamped` records ascending chronologically. 100 | sort :: forall a. List (Stamped a) -> List (Stamped a) 101 | sort = sortBy (compare `on` _.time) 102 | 103 | -- | For a `last` timestamp and a function `f :: Delta -> a` (such as 104 | -- | [`Gesso.Application.Behavior.UpdateFunction`](Gesso.Application.Behavior.html#t:UpdateFunction), create a 105 | -- | `Delta` between `last` and the current time, apply the delta to `f`, and 106 | -- | return a record containing the current time and the result of `f delta`. 107 | stamp :: forall a. Last -> (Delta -> a) -> Effect (Stamped a) 108 | stamp last f = do 109 | n@(Now t) <- _now 110 | let d = delta n last 111 | pure { time: t, item: f d } 112 | 113 | -- | A interval of time, in milliseconds, to space out repeating an action, or 114 | -- | `Never` perform the action. Constructed with [`hz`](#v:hz) or 115 | -- | [`never`](#v:never). 116 | data Interval 117 | = Interval Number 118 | | Never 119 | 120 | -- | Convert the span between two periods of time to a unitless number of 121 | -- | intervals, typically between `0.0` and `1.0`. The result is used with 122 | -- | linear interpolation to find a weighted average between two values. 123 | -- | 124 | -- | For a `Never` interval, returns `1`, signalling to use the newer value and 125 | -- | ignore the older. 126 | toRatio :: Last -> Interval -> Now -> Number 127 | toRatio (Last l) interval (Now n) = case interval of 128 | Never -> 1.0 129 | Interval i -> (n - l) / i 130 | 131 | -- | Construct an `Interval` from Hz or frames per second. Invalid frequencies 132 | -- | (`±Infinity`, `NaN`, zero, or negative) result in a `Never` interval. 133 | hz :: Number -> Interval 134 | hz fps 135 | | not (isFinite fps) = Never 136 | | fps <= 0.0 = Never 137 | | otherwise = Interval $ 1000.0 / fps 138 | 139 | -- | An interval that never occurs. 140 | never :: Interval 141 | never = Never 142 | 143 | -- | Results of repeatedly timestamping a function at certain interval: 144 | -- | 145 | -- | * `last`: the timestamp of the latest item in the list 146 | -- | * `items`: a list of repeated applications of `Delta`s to the function, 147 | -- | with timestamps 148 | type StampedBatch a = 149 | { last :: Last 150 | , items :: List (Stamped a) 151 | } 152 | 153 | -- | A dummy `StampedBatch` for `Never` intervals. Contains a valid `Last` time 154 | -- | just in case. 155 | emptyBatch :: forall a. Effect (StampedBatch a) 156 | emptyBatch = { last: _, items: Nil } <$> elapse <$> _now 157 | 158 | -- | Repeatedly timestamp a function at a given interval, starting at the `last` 159 | -- | time plus the interval, as long as the timestamp does not pass the current 160 | -- | time. 161 | -- | 162 | -- | The `last` value in the returned record should be saved by the caller to 163 | -- | pass in as the `last` argument for the next call to `stampInterval`. 164 | stampInterval 165 | :: forall a 166 | . Last 167 | -> (Delta -> a) 168 | -> Interval 169 | -> Effect (StampedBatch a) 170 | stampInterval last fn = case _ of 171 | Never -> emptyBatch 172 | Interval ms -> batch <$> schedule Nil last <$> _now 173 | where 174 | batch :: List (Stamped a) -> StampedBatch a 175 | batch items = { last: lastTime items, items } 176 | 177 | lastTime :: List (Stamped a) -> Last 178 | lastTime l = maybe last (Last <<< _.time) $ head l 179 | 180 | schedule :: List (Stamped a) -> Last -> Now -> List (Stamped a) 181 | schedule items prev@(Last p) now@(Now n) 182 | | p + ms >= n = items 183 | | otherwise = schedule items' (elapse cur) now 184 | where 185 | cur@(Now c) = Now $ p + ms 186 | items' = { time: c, item: fn (delta cur prev) } : items 187 | -------------------------------------------------------------------------------- /test/Main.purs: -------------------------------------------------------------------------------- 1 | module Test.Main where 2 | 3 | import Prelude 4 | 5 | import Effect (Effect) 6 | import Effect.Class.Console (log) 7 | 8 | main :: Effect Unit 9 | main = do 10 | log "🍝" 11 | log "You should add some tests." 12 | --------------------------------------------------------------------------------