├── .envrc ├── .git-blame-ignore-revs ├── .github └── workflows │ └── flake-ci.yml ├── .gitignore ├── .travis.yml ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── app └── Examples.hs ├── flake.lock ├── flake.nix ├── fourmolu.yaml ├── hamilton.cabal ├── src └── Numeric │ └── Hamilton.hs └── test └── Spec.hs /.envrc: -------------------------------------------------------------------------------- 1 | watch_file *.cabal 2 | use flake 3 | -------------------------------------------------------------------------------- /.git-blame-ignore-revs: -------------------------------------------------------------------------------- 1 | # fourmolu 2 | 2f6ca862e31ddf33c86c8fb2660d7e0194b6fc2e 3 | -------------------------------------------------------------------------------- /.github/workflows/flake-ci.yml: -------------------------------------------------------------------------------- 1 | name: "Flake CI" 2 | on: 3 | pull_request: 4 | push: 5 | jobs: 6 | checks: 7 | runs-on: ubuntu-latest 8 | steps: 9 | - name: Free Disk Space 10 | uses: insightsengineering/free-disk-space@v1.1.0 11 | - uses: actions/checkout@v3 12 | - uses: webfactory/ssh-agent@v0.9.0 13 | with: 14 | ssh-private-key: ${{ secrets.SSH_PRIVATE_KEY }} 15 | - uses: cachix/install-nix-action@v22 16 | with: 17 | nix_path: nixpkgs=channel:nixos-unstable 18 | github_access_token: ${{ secrets.GITHUB_TOKEN }} 19 | extra_nix_config: | 20 | trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= loony-tools:pr9m4BkM/5/eSTZlkQyRt57Jz7OMBxNSUiMC4FkcNfk= 21 | allow-import-from-derivation = true 22 | auto-optimise-store = true 23 | substituters = https://hydra.iohk.io https://cache.nixos.org/ https://cache.iog.io https://cache.zw3rk.com https://mstksg.cachix.org 24 | - uses: cachix/cachix-action@v13 25 | with: 26 | name: mstksg 27 | authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' 28 | - run: nix flake check --show-trace 29 | 30 | cache: 31 | runs-on: ubuntu-latest 32 | steps: 33 | - name: Free Disk Space 34 | uses: insightsengineering/free-disk-space@v1.1.0 35 | - uses: actions/checkout@v4.1.1 36 | - uses: webfactory/ssh-agent@v0.9.0 37 | with: 38 | ssh-private-key: ${{ secrets.SSH_PRIVATE_KEY }} 39 | - uses: cachix/install-nix-action@v22 40 | with: 41 | nix_path: nixpkgs=channel:nixos-unstable 42 | github_access_token: ${{ secrets.GITHUB_TOKEN }} 43 | extra_nix_config: | 44 | trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= loony-tools:pr9m4BkM/5/eSTZlkQyRt57Jz7OMBxNSUiMC4FkcNfk= 45 | allow-import-from-derivation = true 46 | auto-optimise-store = true 47 | substituters = https://hydra.iohk.io https://cache.nixos.org/ https://cache.iog.io https://cache.zw3rk.com https://mstksg.cachix.org 48 | - uses: cachix/cachix-action@v13 49 | with: 50 | name: mstksg 51 | authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' 52 | - run: nix build --show-trace 53 | - run: nix develop --show-trace 54 | 55 | every-compiler: 56 | runs-on: ubuntu-latest 57 | steps: 58 | - name: Free Disk Space 59 | uses: insightsengineering/free-disk-space@v1.1.0 60 | - uses: actions/checkout@v3 61 | - uses: webfactory/ssh-agent@v0.9.0 62 | with: 63 | ssh-private-key: ${{ secrets.SSH_PRIVATE_KEY }} 64 | - uses: cachix/install-nix-action@v22 65 | with: 66 | nix_path: nixpkgs=channel:nixos-unstable 67 | github_access_token: ${{ secrets.GITHUB_TOKEN }} 68 | extra_nix_config: | 69 | trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= loony-tools:pr9m4BkM/5/eSTZlkQyRt57Jz7OMBxNSUiMC4FkcNfk= 70 | allow-import-from-derivation = true 71 | auto-optimise-store = true 72 | substituters = https://hydra.iohk.io https://cache.nixos.org/ https://cache.iog.io https://cache.zw3rk.com https://mstksg.cachix.org 73 | - uses: cachix/cachix-action@v13 74 | with: 75 | name: mstksg 76 | authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' 77 | - run: nix build .#everyCompiler 78 | 79 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /.stack-work 2 | /src/highlight.js 3 | /src/style.css 4 | /dist-newstyle 5 | /.direnv 6 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | script: 2 | - | 3 | set -ex 4 | case "$BUILD" in 5 | stack) 6 | stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps 7 | ;; 8 | cabal) 9 | cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 10 | 11 | ORIGDIR=$(pwd) 12 | for dir in $PACKAGES 13 | do 14 | cd $dir 15 | cabal check || [ "$CABALVER" == "1.16" ] 16 | cabal sdist 17 | PKGVER=$(cabal info . | awk '{print $2;exit}') 18 | SRC_TGZ=$PKGVER.tar.gz 19 | cd dist 20 | tar zxfv "$SRC_TGZ" 21 | cd "$PKGVER" 22 | cabal configure --enable-tests --ghc-options -O0 23 | cabal build 24 | if [ "$CABALVER" = "1.16" ] || [ "$CABALVER" = "1.18" ]; then 25 | cabal test 26 | else 27 | cabal test --show-details=streaming --log=/dev/stdout 28 | fi 29 | cd $ORIGDIR 30 | done 31 | ;; 32 | esac 33 | set +ex 34 | install: 35 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo 36 | '?')]" 37 | - if [ -f configure.ac ]; then autoreconf -i; fi 38 | - | 39 | set -ex 40 | case "$BUILD" in 41 | stack) 42 | # Add in extra-deps for older snapshots, as necessary 43 | # 44 | # This is disabled by default, as relying on the solver like this can 45 | # make builds unreliable. Instead, if you have this situation, it's 46 | # recommended that you maintain multiple stack-lts-X.yaml files. 47 | 48 | #stack --no-terminal --install-ghc $ARGS test --bench --dry-run || ( \ 49 | # stack --no-terminal $ARGS build cabal-install && \ 50 | # stack --no-terminal $ARGS solver --update-config) 51 | 52 | # Build the dependencies 53 | stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies 54 | ;; 55 | cabal) 56 | cabal --version 57 | travis_retry cabal update 58 | 59 | # Get the list of packages from the stack.yaml file. Note that 60 | # this will also implicitly run hpack as necessary to generate 61 | # the .cabal files needed by cabal-install. 62 | PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') 63 | 64 | cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 65 | ;; 66 | esac 67 | set +ex 68 | jobs: 69 | include: 70 | - env: BUILD=cabal GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 71 | addons: 72 | apt: 73 | sources: 74 | - hvr-ghc 75 | packages: 76 | - cabal-install-1.24 77 | - ghc-8.0.2 78 | - happy-1.19.5 79 | - alex-3.1.7 80 | compiler: ': #GHC 8.0.2' 81 | - env: BUILD=cabal GHCVER=8.2.2 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 82 | addons: 83 | apt: 84 | sources: 85 | - hvr-ghc 86 | packages: 87 | - cabal-install-2.0 88 | - ghc-8.2.2 89 | - happy-1.19.5 90 | - alex-3.1.7 91 | compiler: ': #GHC 8.2.2' 92 | - env: BUILD=cabal GHCVER=8.4.4 CABALVER=2.2 HAPPYVER=1.19.5 ALEXVER=3.1.7 93 | addons: 94 | apt: 95 | sources: 96 | - hvr-ghc 97 | packages: 98 | - cabal-install-2.2 99 | - ghc-8.4.4 100 | - happy-1.19.5 101 | - alex-3.1.7 102 | compiler: ': #GHC 8.4.4' 103 | - env: BUILD=cabal GHCVER=8.6.5 CABALVER=2.4 HAPPYVER=1.19.5 ALEXVER=3.1.7 104 | addons: 105 | apt: 106 | sources: 107 | - hvr-ghc 108 | packages: 109 | - cabal-install-2.4 110 | - ghc-8.6.5 111 | - happy-1.19.5 112 | - alex-3.1.7 113 | compiler: ': #GHC 8.6.5' 114 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 115 | addons: 116 | apt: 117 | sources: 118 | - hvr-ghc 119 | packages: 120 | - cabal-install-head 121 | - ghc-head 122 | - happy-1.19.5 123 | - alex-3.1.7 124 | compiler: ': #GHC HEAD' 125 | - env: BUILD=stack ARGS="" 126 | addons: 127 | apt: 128 | packages: 129 | - libgmp-dev 130 | compiler: ': #stack default' 131 | - env: BUILD=stack ARGS="--resolver lts-9" 132 | addons: 133 | apt: 134 | packages: 135 | - libgmp-dev 136 | compiler: ': #stack 8.0.2' 137 | - env: BUILD=stack ARGS="--resolver lts-11" 138 | addons: 139 | apt: 140 | packages: 141 | - libgmp-dev 142 | compiler: ': #stack 8.2.2' 143 | - env: BUILD=stack ARGS="--resolver lts-12" 144 | addons: 145 | apt: 146 | packages: 147 | - libgmp-dev 148 | compiler: ': #stack 8.4.4' 149 | - env: BUILD=stack ARGS="--resolver lts-14" 150 | addons: 151 | apt: 152 | packages: 153 | - libgmp-dev 154 | compiler: ': #stack 8.6.5' 155 | - env: BUILD=stack ARGS="--resolver nightly" 156 | addons: 157 | apt: 158 | packages: 159 | - libgmp-dev 160 | compiler: ': #stack nightly' 161 | - env: BUILD=stack ARGS="" 162 | os: osx 163 | compiler: ': #stack default osx' 164 | - env: BUILD=stack ARGS="--resolver lts-9" 165 | os: osx 166 | compiler: ': #stack 8.0.2 osx' 167 | - env: BUILD=stack ARGS="--resolver lts-11" 168 | os: osx 169 | compiler: ': #stack 8.2.2 osx' 170 | - env: BUILD=stack ARGS="--resolver lts-12" 171 | os: osx 172 | compiler: ': #stack 8.4.4 osx' 173 | - env: BUILD=stack ARGS="--resolver lts-14" 174 | os: osx 175 | compiler: ': #stack 8.6.5 osx' 176 | - env: BUILD=stack ARGS="--resolver nightly" 177 | os: osx 178 | compiler: ': #stack nightly osx' 179 | allow_failures: 180 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 181 | - env: BUILD=stack ARGS="--resolver nightly" 182 | os: linux 183 | cache: 184 | directories: 185 | - $HOME/.ghc 186 | - $HOME/.cabal 187 | - $HOME/.stack 188 | - $TRAVIS_BUILD_DIR/.stack-work 189 | before_install: 190 | - unset CC 191 | - CABALARGS="" 192 | - if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi 193 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH 194 | - mkdir -p ~/.local/bin 195 | - | 196 | if [ `uname` = "Darwin" ] 197 | then 198 | travis_retry curl --insecure -L https://get.haskellstack.org/stable/osx-x86_64.tar.gz | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 199 | else 200 | travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 201 | fi 202 | 203 | # Use the more reliable S3 mirror of Hackage 204 | mkdir -p $HOME/.cabal 205 | echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config 206 | echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config 207 | - | 208 | if [ `uname` = "Darwin" ] 209 | then 210 | brew update 211 | brew install gsl 212 | fi 213 | language: generic 214 | 215 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | Changelog 2 | ========= 3 | 4 | Version 0.1.0.4 5 | --------------- 6 | 7 | *Unreleased* 8 | 9 | 10 | 11 | *Internal* 12 | 13 | * Rewrote more internal functions using *hmatrix-vector-sized*, which should 14 | yield performance benefits. 15 | 16 | Version 0.1.0.3 17 | --------------- 18 | 19 | *Mar 20, 2018* 20 | 21 | 22 | 23 | * Compatibility with *base-4.11.0.0* and GHC 8.4 24 | * Compatibility with *vector-sized-1.0.0.0* 25 | 26 | *Internal* 27 | 28 | * Internal conversion functions refactored using *hmatrix-vector-sized*, 29 | *hessianF*. 30 | 31 | Version 0.1.0.2 32 | --------------- 33 | 34 | *Jan 21, 2018* 35 | 36 | 37 | 38 | * Compatibility with *typelits-witneses-0.3.0.0* 39 | 40 | Version 0.1.0.1 41 | --------------- 42 | 43 | *Aug 17, 2017* 44 | 45 | 46 | 47 | * Removed `Num` instance in the examples file, to account for 48 | *vector-sized*'s new `Num` instances. 49 | * COMPLETE pragmas for examples file. 50 | 51 | Version 0.1.0.0 52 | --------------- 53 | 54 | *Nov 27, 2016* 55 | 56 | 57 | 58 | * Initial release. 59 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Justin Le (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Justin Le nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Hamilton 2 | ======== 3 | 4 | [![Build Status](https://travis-ci.org/mstksg/hamilton.svg?branch=master)](https://travis-ci.org/mstksg/hamilton) 5 | 6 | Simulate physics on arbitrary coordinate systems using [automatic 7 | differentiation][ad] and [Hamiltonian mechanics][]. State only an arbitrary 8 | parameterization of your system and a potential energy function! 9 | 10 | [ad]: http://hackage.haskell.org/package/ad 11 | [Hamiltonian mechanics]: https://en.wikipedia.org/wiki/Hamiltonian_mechanics 12 | 13 | For example, a simulating a [double pendulum system][dps] by simulating the 14 | progression of the angles of each bob: 15 | 16 | [dps]: https://en.wikipedia.org/wiki/Double_pendulum 17 | 18 | [![My name is William Rowan Hamilton](http://i.imgur.com/Vaaa2EC.gif)][gifv] 19 | 20 | [gifv]: http://i.imgur.com/Vaaa2EC.gifv 21 | 22 | You only need: 23 | 24 | 1. Your generalized coordinates (in this case, `θ1` and `θ2`), and equations 25 | to convert them to cartesian coordinates of your objects: 26 | 27 | ~~~haskell 28 | x1 = sin θ1 29 | y1 = -cos θ1 30 | x2 = sin θ1 + sin θ2 / 2 -- second pendulum is half-length 31 | y2 = -cos θ1 - cos θ2 / 2 32 | ~~~ 33 | 34 | 2. The masses/inertias of each of those cartesian coordinates (`m1` for `x1` 35 | and `y1`, `m2` for `x2` and `y2`) 36 | 37 | 3. A potential energy function for your objects: 38 | 39 | ~~~haskell 40 | U = (m1 y1 + m2 y2) * g 41 | ~~~ 42 | 43 | And that's it! Hamiltonian mechanics steps your generalized coordinates (`θ1` 44 | and `θ2`) through time, without needing to do any simulation involving 45 | `x1`/`y1`/`x2`/`y2`! And you don't need to worry about tension or any other 46 | stuff like that. All you need is a description of your coordinate system 47 | itself, and the potential energy! 48 | 49 | ~~~haskell 50 | doublePendulum :: System 4 2 51 | doublePendulum = 52 | mkSystem' (vec4 m1 m1 m2 m2) -- masses 53 | (\(V2 θ1 θ2) -> V4 (sin θ1) (-cos θ1) 54 | (sin θ1 + sin θ2/2) (-cos θ1 - cos θ2/2) 55 | ) -- coordinates 56 | (\(V4 _ y1 _ y2) -> (m1 * y1 + m2 * y2) * g) 57 | -- potential 58 | ~~~ 59 | 60 | Thanks to [~~Alexander~~ William Rowan Hamilton][WRH], we can express our 61 | system parameterized by arbitrary coordinates and get back equations of motions 62 | as first-order differential equations. This library solves those first-order 63 | differential equations for you using automatic differentiation and some matrix 64 | manipulation. 65 | 66 | [WRH]: https://www.youtube.com/watch?v=SZXHoWwBcDc 67 | 68 | See a [blog post][] I wrote on this, and also the [hackage documentation][] and the 69 | [example runner user guide][user guide] (and its [source][example runner]). 70 | 71 | [blog post]: https://blog.jle.im/entry/introducing-the-hamilton-library.html 72 | [hackage documentation]: http://hackage.haskell.org/package/hamilton 73 | [example runner]: https://github.com/mstksg/hamilton/blob/master/app/Examples.hs 74 | [user guide]: https://github.com/mstksg/hamilton#example-app-runner 75 | 76 | ### Full Example 77 | 78 | Let's turn our double pendulum (with the second pendulum half as long) into an 79 | actual running program. Let's say that `g = 5`, `m1 = 1`, and `m2 = 2`. 80 | 81 | First, the system: 82 | 83 | ~~~haskell 84 | import Numeric.LinearAlgebra.Static 85 | import qualified Data.Vector.Sized as V 86 | 87 | 88 | doublePendulum :: System 4 2 89 | doublePendulum = mkSystem' masses coordinates potential 90 | where 91 | masses :: R 4 92 | masses = vec4 1 1 2 2 93 | coordinates 94 | :: Floating a 95 | => V.Vector 2 a 96 | -> V.Vector 4 a 97 | coordinates (V2 θ1 θ2) = V4 (sin θ1) (-cos θ1) 98 | (sin θ1 + sin θ2/2) (-cos θ1 - cos θ2/2) 99 | potential 100 | :: Num a 101 | => V.Vector 4 a 102 | -> a 103 | potential (V4 _ y1 _ y2) = (y1 + 2 * y2) * 5 104 | 105 | 106 | -- some helper patterns to pattern match on sized vectors 107 | pattern V2 :: a -> a -> V.Vector 2 a 108 | pattern V2 x y <- (V.toList->[x,y]) 109 | where 110 | V2 x y = fromJust (V.fromList [x,y]) 111 | 112 | pattern V4 :: a -> a -> a -> a -> V.Vector 4 a 113 | pattern V4 x y z a <- (V.toList->[x,y,z,a]) 114 | where 115 | V4 x y z a = fromJust (V.fromList [x,y,z,a]) 116 | ~~~ 117 | 118 | Neat! Easy, right? 119 | 120 | Okay, now let's run it. Let's pick a starting configuration (state of the 121 | system) of `θ1` and `θ2`: 122 | 123 | ~~~haskell 124 | config0 :: Config 2 125 | config0 = Cfg (vec2 1 0 ) -- initial positions 126 | (vec2 0 0.5) -- initial velocities 127 | ~~~ 128 | 129 | Configurations are nice, but Hamiltonian dynamics is all about motion through 130 | phase space, so let's convert this configuration-space representation of the 131 | state into a phase-space representation of the state: 132 | 133 | ~~~haskell 134 | phase0 :: Phase 2 135 | phase0 = toPhase doublePendulum config0 136 | ~~~ 137 | 138 | And now we can ask for the state of our system at any amount of points in time! 139 | 140 | ~~~haskell 141 | ghci> evolveHam doublePendulum phase0 [0,0.1 .. 1] 142 | -- result: state of the system at times 0, 0.1, 0.2, 0.3 ... etc. 143 | ~~~ 144 | 145 | Or, if you want to run the system step-by-step: 146 | 147 | 148 | ~~~haskell 149 | evolution :: [Phase 2] 150 | evolution = iterate (stepHam 0.1 doublePendulum) phase0 151 | ~~~ 152 | 153 | And you can get the position of the coordinates as: 154 | 155 | ~~~haskell 156 | positions :: [R 2] 157 | positions = phsPositions <$> evolution 158 | ~~~ 159 | 160 | And the position in the underlying cartesian space as: 161 | 162 | ~~~haskell 163 | positions' :: [R 4] 164 | positions' = underlyingPos doublePendulum <$> positions 165 | ~~~ 166 | 167 | Example App runner 168 | ------------------ 169 | 170 | *([Source][example runner])* 171 | 172 | Installation: 173 | 174 | ~~~bash 175 | $ git clone https://github.com/mstksg/hamilton 176 | $ cd hamilton 177 | $ stack install 178 | ~~~ 179 | 180 | Usage: 181 | 182 | ~~~bash 183 | $ hamilton-examples [EXAMPLE] (options) 184 | $ hamilton-examples --help 185 | $ hamilton-examples [EXAMPLE] --help 186 | ~~~ 187 | 188 | The example runner is a command line application that plots the progression of 189 | several example system through time. 190 | 191 | 192 | | Example | Description | Coordinates | Options | 193 | |--------------|------------------------------------------------------------|---------------------------------------------------------------------|---------------------------------------------------------------| 194 | | `doublepend` | Double pendulum, described above | `θ1`, `θ2` (angles of bobs) | Masses of each bob | 195 | | `pend` | Single pendulum | `θ` (angle of bob) | Initial angle and velocity of bob | 196 | | `room` | Object bounding around walled room | `x`, `y` | Initial launch angle of object | 197 | | `twobody` | Two gravitationally attracted bodies, described below | `r`, `θ` (distance between bodies, angle of rotation) | Masses of bodies and initial angular veocity | 198 | | `spring` | Spring hanging from a block on a rail, holding up a weight | `r`, `x`, `θ` (position of block, spring compression, spring angle) | Masses of block, weight, spring constant, initial compression | 199 | | `bezier` | Bead sliding at constant velocity along bezier curve | `t` (Bezier time parameter) | Control points for arbitrary bezier curve | 200 | 201 | Call with `--help` (or `[EXAMPLE] --help`) for more information. 202 | 203 | More examples 204 | ------------- 205 | 206 | ### Two-body system under gravity 207 | 208 | [![The two-body solution](http://i.imgur.com/TDEHTcb.gif)][gifv2] 209 | 210 | [gifv2]: http://i.imgur.com/TDEHTcb.gifv 211 | 212 | 1. The generalized coordinates are just: 213 | 214 | * `r`, the distance between the two bodies 215 | * `θ`, the current angle of rotation 216 | 217 | ~~~haskell 218 | x1 = m2/(m1+m2) * r * sin θ -- assuming (0,0) is the center of mass 219 | y1 = m2/(m1+m2) * r * cos θ 220 | x2 = -m1/(m1+m2) * r * sin θ 221 | y2 = -m1/(m1+m2) * r * cos θ 222 | ~~~ 223 | 224 | 2. The masses/inertias are again `m1` for `x1` and `y1`, and `m2` for `x2` and 225 | `y2` 226 | 227 | 3. The potential energy function is the classic gravitational potential: 228 | 229 | ~~~haskell 230 | U = - m1 * m2 / r 231 | ~~~ 232 | 233 | And...that's all you need! 234 | 235 | Here is the actual code for the two-body system, assuming `m1` is `100` and 236 | `m2` is `1`: 237 | 238 | ~~~haskell 239 | twoBody :: System 4 2 240 | twoBody = mkSystem masses coordinates potential 241 | where 242 | masses :: R 4 243 | masses = vec4 100 100 1 1 244 | coordinates 245 | :: Floating a 246 | => V.Vector 2 a 247 | -> V.Vector 4 a 248 | coordinates (V2 r θ) = V4 (r1 * cos θ) (r1 * sin θ) 249 | (r2 * cos θ) (r2 * sin θ) 250 | where 251 | r1 = r * 1 / 101 252 | r2 = - r * 100 / 101 253 | potential 254 | :: Num a 255 | => V.Vector 4 a 256 | -> a 257 | potential (V2 r _) = - 100 / r 258 | ~~~ 259 | 260 | Potential improvements 261 | ---------------------- 262 | 263 | * **Time-dependent systems**: Shouldn't be an problem in theory/math; just 264 | add a time parameter before all of the functions. This opens a lot of 265 | doors, like deriving inertial forces for free (like the famous Coriolis 266 | force and centrifugal force). 267 | 268 | The only thing is that it makes the API pretty inconvenient, because it'd 269 | require all of the functions to also take a time parameter. Of course, the 270 | easy way out/ugly solution would be to just offer two versions of the same 271 | function (one for time-independent systems and one for time-dependent 272 | systems. But this is un-ideal. 273 | 274 | * Velocity-dependent potentials: Would give us the ability to model systems 275 | with velocity-dependent Lagrangians like a charged particle in an 276 | electromagnetic field, and also dissipative systems, like systems with 277 | friction (dependent on `signum v`) and linear & quadratic wind resistance. 278 | 279 | This issue is much harder, theoretically. It involves inverting arbitrary 280 | functions `forall a. RealFloat a => V.Vector n a -> V.Vector m a`. It 281 | might be possible with the help of some 282 | [bidirectionalization techniques][bff-pearl], but I can't get the [bff][] 283 | package to compile, and I'm not sure how to get [bff-mono][] to work with 284 | numeric functions. 285 | 286 | If anyone is familiar with bidirectionalization techniques and is willing 287 | to help out, please send me a message or open an issue! :) 288 | 289 | [bff-pearl]: https://pdfs.semanticscholar.org/5f0d/ef02dbd96e102be9104d2ceb728d2a2a5beb.pdf 290 | [bff]: http://hackage.haskell.org/package/bff 291 | [bff-mono]: http://hackage.haskell.org/package/bff-mono 292 | 293 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /app/Examples.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE PatternSynonyms #-} 9 | {-# LANGUAGE RecordWildCards #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | {-# LANGUAGE TypeOperators #-} 13 | {-# LANGUAGE ViewPatterns #-} 14 | {-# OPTIONS_GHC -fno-warn-orphans #-} 15 | {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} 16 | 17 | -- \| Hamilton example suite 18 | -- 19 | -- See: https://github.com/mstksg/hamilton#example-app-runner 20 | -- 21 | -- Or just run with: 22 | -- 23 | -- > $ hamilton-examples --help 24 | -- > $ hamilton-examples [EXAMPLE] --help 25 | 26 | import Control.Concurrent 27 | import Control.Monad 28 | import Data.Bifunctor 29 | import Data.Finite 30 | import Data.Foldable 31 | import Data.IORef 32 | import Data.List 33 | import qualified Data.List.NonEmpty as NE 34 | import qualified Data.Map.Strict as M 35 | import qualified Data.Vector as VV 36 | import qualified Data.Vector.Sized as V 37 | import qualified Data.Vector.Storable.Sized as VS 38 | import GHC.TypeLits 39 | import Graphics.Vty hiding ((<|>)) 40 | import Graphics.Vty.CrossPlatform (mkVty) 41 | import Numeric.Hamilton 42 | import Numeric.LinearAlgebra.Static hiding (dim, (<>)) 43 | import Numeric.LinearAlgebra.Static.Vector 44 | import Options.Applicative 45 | import qualified Prettyprinter as PP 46 | import System.Exit 47 | import Text.Printf 48 | import Text.Read 49 | 50 | data SysExample where 51 | SE :: 52 | (KnownNat m, KnownNat n) => 53 | { seName :: String 54 | , seCoords :: V.Vector n String 55 | , seSystem :: System m n 56 | , seDraw :: R m -> [V2 Double] 57 | , seInit :: Phase n 58 | } -> 59 | SysExample 60 | 61 | pendulum :: Double -> Double -> SysExample 62 | pendulum θ0 ω0 = SE "Single pendulum" (V1 "θ") s f (toPhase s c0) 63 | where 64 | s :: System 2 1 65 | s = 66 | mkSystem' 67 | (vec2 1 1) -- masses 68 | (\(V1 θ) -> V2 (sin θ) (0.5 - cos θ)) -- coordinates 69 | (\(V2 _ y) -> y) -- potential 70 | f :: R 2 -> [V2 Double] 71 | f xs = [grVec xs] 72 | c0 :: Config 1 73 | c0 = Cfg (konst θ0 :: R 1) (konst ω0 :: R 1) 74 | 75 | doublePendulum :: Double -> Double -> SysExample 76 | doublePendulum m1 m2 = SE "Double pendulum" (V2 "θ1" "θ2") s f (toPhase s c0) 77 | where 78 | s :: System 4 2 79 | s = 80 | mkSystem' 81 | (vec4 m1 m1 m2 m2) -- masses 82 | ( \(V2 θ1 θ2) -> 83 | V4 84 | (sin θ1) 85 | (1 - cos θ1) 86 | (sin θ1 + sin θ2 / 2) 87 | (1 - cos θ1 - cos θ2 / 2) 88 | ) -- coordinates 89 | (\(V4 _ y1 _ y2) -> 5 * (realToFrac m1 * y1 + realToFrac m2 * y2)) 90 | -- potential 91 | f :: R 4 -> [V2 Double] 92 | f (split -> (xs, ys)) = grVec <$> [xs, ys] 93 | c0 :: Config 2 94 | c0 = Cfg (vec2 (pi / 2) 0) (vec2 0 0) 95 | 96 | room :: Double -> SysExample 97 | room θ = SE "Room" (V2 "x" "y") s f (toPhase s c0) 98 | where 99 | s :: System 2 2 100 | s = 101 | mkSystem 102 | (vec2 1 1) -- masses 103 | id -- coordinates 104 | ( \(V2 x y) -> 105 | sum 106 | [ 2 * y -- gravity 107 | , 1 - logistic (-1) 10 0.1 y -- bottom wall 108 | , logistic 1 10 0.1 y -- top wall 109 | , 1 - logistic (-2) 10 0.1 x -- left wall 110 | , logistic 2 10 0.1 x -- right wall 111 | ] 112 | ) -- potential 113 | f :: R 2 -> [V2 Double] 114 | f xs = [grVec xs] 115 | c0 :: Config 2 116 | c0 = Cfg (vec2 (-1) 0.25) (vec2 (cos θ) (sin θ)) 117 | 118 | twoBody :: Double -> Double -> Double -> SysExample 119 | twoBody m1 m2 ω0 = SE "Two-Body" (V2 "r" "θ") s f (toPhase s c0) 120 | where 121 | mT :: Double 122 | mT = m1 + m2 123 | s :: System 4 2 124 | s = 125 | mkSystem 126 | (vec4 m1 m1 m2 m2) -- masses 127 | -- positions are calculated assuming (0,0) is the center 128 | -- of mass 129 | ( \(V2 r θ) -> 130 | let r1 = r * realToFrac (-(m2 / mT)) 131 | r2 = r * realToFrac (m1 / mT) 132 | in V4 133 | (r1 * cos θ) 134 | (r1 * sin θ) 135 | (r2 * cos θ) 136 | (r2 * sin θ) 137 | ) -- coordinates 138 | (\(V2 r _) -> -(realToFrac (m1 * m2) / r)) -- potential 139 | f :: R 4 -> [V2 Double] 140 | f (split -> (xs, ys)) = grVec <$> [xs, ys] 141 | c0 :: Config 2 142 | c0 = Cfg (vec2 2 0) (vec2 0 ω0) 143 | 144 | spring :: 145 | Double -> Double -> Double -> Double -> SysExample 146 | spring mB mW k x0 = SE "Spring hanging from block" (V3 "r" "x" "θ") s f (toPhase s c0) 147 | where 148 | s :: System 3 3 149 | s = 150 | mkSystem 151 | (vec3 mB mW mW) -- masses 152 | (\(V3 r x θ) -> V3 r (r + (1 + x) * sin θ) ((1 + x) * (-cos θ))) -- coordinates 153 | ( \(V3 r x θ) -> 154 | realToFrac k * x ** 2 / 2 -- spring 155 | + (1 - logistic (-1.5) 25 0.1 r) -- left rail wall 156 | + logistic 1.5 25 0.1 r -- right rail wall 157 | + realToFrac mB * ((1 + x) * (-cos θ)) -- gravity 158 | ) 159 | f :: R 3 -> [V2 Double] 160 | f (headTail -> (b, w)) = [V2 b 1, V2 0 1 + grVec w] 161 | c0 :: Config 3 162 | c0 = Cfg (vec3 0 x0 0) (vec3 1 0 (-0.5)) 163 | 164 | bezier :: 165 | forall n. 166 | KnownNat (1 + n) => 167 | V.Vector (1 + n) (V2 Double) -> 168 | SysExample 169 | bezier ps = SE "Bezier" (V1 "t") s f (toPhase s c0) 170 | where 171 | s :: System 2 1 172 | s = 173 | mkSystem 174 | (vec2 1 1) -- masses 175 | (\(V1 t) -> bezierCurve (fmap realToFrac <$> ps) t) -- coordinates 176 | ( \(V1 t) -> 177 | (1 - logistic 0 5 0.05 t) -- left wall 178 | + logistic 1 5 0.05 t -- right wall 179 | ) 180 | f :: R 2 -> [V2 Double] 181 | f xs = [grVec xs] 182 | c0 :: Config 1 183 | c0 = Cfg (0.5 :: R 1) (0.25 :: R 1) 184 | 185 | newtype ExampleOpts = EO {eoChoice :: SysExampleChoice} 186 | 187 | data SysExampleChoice 188 | = SECDoublePend Double Double 189 | | SECPend Double Double 190 | | SECRoom Double 191 | | SECTwoBody Double Double Double 192 | | SECSpring Double Double Double Double 193 | | SECBezier (NE.NonEmpty (V2 Double)) 194 | 195 | parseEO :: Parser ExampleOpts 196 | parseEO = EO <$> (parseSEC <|> pure (SECDoublePend 1 1)) 197 | 198 | parseSEC :: Parser SysExampleChoice 199 | parseSEC = 200 | subparser . mconcat $ 201 | [ command "doublepend" $ 202 | info 203 | (helper <*> parseDoublePend) 204 | (progDesc "Double pendulum (default)") 205 | , command "pend" $ 206 | info 207 | (helper <*> parsePend) 208 | (progDesc "Single pendulum") 209 | , command "room" $ 210 | info 211 | (helper <*> parseRoom) 212 | (progDesc "Ball in room, bouncing off of walls") 213 | , command "twobody" $ 214 | info 215 | (helper <*> parseTwoBody) 216 | (progDesc "Two-body graviational simulation. Note that bodies will only orbit if H < 0.") 217 | , command "spring" $ 218 | info 219 | (helper <*> parseSpring) 220 | ( progDesc 221 | "A spring hanging from a block on a rail, holding up a mass. Block is constrained to bounce between -1.5 and 1.5." 222 | ) 223 | , command "bezier" $ 224 | info 225 | (helper <*> parseBezier) 226 | (progDesc "Particle moving along a parameterized bezier curve") 227 | , metavar "EXAMPLE" 228 | ] 229 | where 230 | parsePend = 231 | SECPend 232 | <$> option 233 | auto 234 | ( long "angle" 235 | <> short 'a' 236 | <> metavar "ANGLE" 237 | <> help "Intitial rightward angle (in degrees) of bob" 238 | <> value 0 239 | <> showDefault 240 | ) 241 | <*> option 242 | auto 243 | ( long "vel" 244 | <> short 'v' 245 | <> metavar "VELOCITY" 246 | <> help "Initial rightward angular velocity of bob" 247 | <> value 1 248 | <> showDefault 249 | ) 250 | parseDoublePend = 251 | SECDoublePend 252 | <$> option 253 | auto 254 | ( long "m1" 255 | <> metavar "MASS" 256 | <> help "Mass of first bob" 257 | <> value 1 258 | <> showDefault 259 | ) 260 | <*> option 261 | auto 262 | ( long "m2" 263 | <> metavar "MASS" 264 | <> help "Mass of second bob" 265 | <> value 1 266 | <> showDefault 267 | ) 268 | parseRoom = 269 | SECRoom 270 | <$> option 271 | auto 272 | ( long "angle" 273 | <> short 'a' 274 | <> metavar "ANGLE" 275 | <> help "Initial upward launch angle (in degrees) of object" 276 | <> value 45 277 | <> showDefault 278 | ) 279 | parseTwoBody = 280 | SECTwoBody 281 | <$> option 282 | auto 283 | ( long "m1" 284 | <> metavar "MASS" 285 | <> help "Mass of first body" 286 | <> value 5 287 | <> showDefault 288 | ) 289 | <*> option 290 | auto 291 | ( long "m2" 292 | <> metavar "MASS" 293 | <> help "Mass of second body" 294 | <> value 0.5 295 | <> showDefault 296 | ) 297 | <*> option 298 | auto 299 | ( long "vel" 300 | <> short 'v' 301 | <> metavar "VELOCITY" 302 | <> help "Initial angular velocity of system" 303 | <> value 0.5 304 | <> showDefault 305 | ) 306 | parseSpring = 307 | SECSpring 308 | <$> option 309 | auto 310 | ( long "block" 311 | <> short 'b' 312 | <> metavar "MASS" 313 | <> help "Mass of block on rail" 314 | <> value 2 315 | <> showDefault 316 | ) 317 | <*> option 318 | auto 319 | ( long "weight" 320 | <> short 'w' 321 | <> metavar "MASS" 322 | <> help "Mass of weight hanging from spring" 323 | <> value 1 324 | <> showDefault 325 | ) 326 | <*> option 327 | auto 328 | ( short 'k' 329 | <> metavar "NUM" 330 | <> help "Spring constant / stiffness of spring" 331 | <> value 10 332 | <> showDefault 333 | ) 334 | <*> option 335 | auto 336 | ( short 'x' 337 | <> metavar "DIST" 338 | <> help "Initial displacement of spring" 339 | <> value 0.1 340 | <> showDefault 341 | ) 342 | parseBezier = 343 | SECBezier 344 | <$> option 345 | f 346 | ( long "points" 347 | <> short 'p' 348 | <> metavar "POINTS" 349 | <> help "List of control points (at least one), as tuples" 350 | <> value (V2 (-1) (-1) NE.:| [V2 (-2) 1, V2 0 1, V2 1 (-1), V2 2 1]) 351 | <> showDefaultWith (show . map (\(V2 x y) -> (x, y)) . toList) 352 | ) 353 | where 354 | f = eitherReader $ \s -> do 355 | ps <- 356 | maybe (Left "Bad parse") Right $ 357 | readMaybe s 358 | maybe (Left "At least one control point required") Right $ 359 | NE.nonEmpty (uncurry V2 <$> ps) 360 | 361 | data SimOpts = SO 362 | { soZoom :: Double 363 | , soRate :: Double 364 | , soHist :: Int 365 | } 366 | deriving (Show) 367 | 368 | data SimEvt 369 | = SEQuit 370 | | SEZoom Double 371 | | SERate Double 372 | | SEHist Int 373 | 374 | main :: IO () 375 | main = do 376 | EO{..} <- 377 | execParser $ 378 | info 379 | (helper <*> parseEO) 380 | ( fullDesc 381 | <> header "hamilton-examples - hamilton library example suite" 382 | <> progDescDoc (Just descr) 383 | ) 384 | 385 | vty <- mkVty defaultConfig 386 | 387 | opts <- newIORef $ SO 0.5 1 25 388 | 389 | t <- forkIO . loop vty opts $ case eoChoice of 390 | SECDoublePend m1 m2 -> doublePendulum m1 m2 391 | SECPend d0 ω0 -> pendulum (d0 / 180 * pi) ω0 392 | SECRoom d0 -> room (d0 / 180 * pi) 393 | SECTwoBody m1 m2 ω0 -> twoBody m1 m2 ω0 394 | SECSpring mB mW k x0 -> spring mB mW k x0 395 | SECBezier (p NE.:| ps) -> 396 | V.withSized 397 | (VV.fromList ps) 398 | (bezier . V.cons p) 399 | 400 | forever $ do 401 | e <- nextEvent vty 402 | forM_ (processEvt e) $ \case 403 | SEQuit -> do 404 | killThread t 405 | shutdown vty 406 | exitSuccess 407 | SEZoom s -> 408 | modifyIORef opts $ \o -> o{soZoom = soZoom o * s} 409 | SERate r -> 410 | modifyIORef opts $ \o -> o{soRate = soRate o * r} 411 | SEHist h -> 412 | modifyIORef opts $ \o -> o{soHist = soHist o + h} 413 | where 414 | fps :: Double 415 | fps = 12 416 | screenRatio :: Double 417 | screenRatio = 2.1 418 | ptAttrs :: [(Char, Color)] 419 | ptAttrs = ptChars `zip` ptColors 420 | where 421 | ptColors = cycle [white, yellow, blue, red, green] 422 | ptChars = cycle "o*+~" 423 | loop :: Vty -> IORef SimOpts -> SysExample -> IO () 424 | loop vty oRef SE{..} = go M.empty seInit 425 | where 426 | qVec = intercalate "," . V.toList $ seCoords 427 | go hists p = do 428 | SO{..} <- readIORef oRef 429 | let p' = stepHam (soRate / fps) seSystem p -- progress the simulation 430 | xb = (-recip soZoom, recip soZoom) 431 | infobox = 432 | vertCat . map (string defAttr) $ 433 | [ printf "[ %s ]" seName 434 | , printf " <%s> : <%s>" qVec 435 | . intercalate ", " 436 | . map (printf "%.4f") 437 | . VS.toList 438 | . rVec 439 | . phsPositions 440 | $ p 441 | , printf "d<%s>/dt: <%s>" qVec 442 | . intercalate ", " 443 | . map (printf "%.4f") 444 | . VS.toList 445 | . rVec 446 | . velocities seSystem 447 | $ p 448 | , printf "KE: %.4f" . keP seSystem $ p 449 | , printf "PE: %.4f" . pe seSystem . phsPositions $ p 450 | , printf "H : %.4f" . hamiltonian seSystem $ p 451 | , " " 452 | , printf "rate: x%.2f <>" soRate 453 | , printf "hist: % 5d []" soHist 454 | , printf "zoom: x%.2f -+" soZoom 455 | ] 456 | pts = 457 | (`zip` ptAttrs) . seDraw . underlyingPos seSystem . phsPositions $ 458 | p 459 | hists' = foldl' (\h (r, a) -> M.insertWith (addHist soHist) a [r] h) hists pts 460 | dr <- displayBounds $ outputIface vty 461 | update vty . picForLayers . (infobox :) . plot dr (PX xb (RR 0.5 screenRatio)) $ 462 | ((second . second) (defAttr `withForeColor`) <$> pts) 463 | ++ ( map (\((_, c), r) -> (r, ('.', defAttr `withForeColor` c))) 464 | . concatMap sequence 465 | . M.toList 466 | $ hists' 467 | ) 468 | threadDelay (round (1000000 / fps)) 469 | go hists' p' 470 | addHist hl new old = take hl (new ++ old) 471 | descr :: PP.Doc x 472 | descr = 473 | PP.vcat 474 | [ "Run examples from the hamilton library example suite." 475 | , "Use with [EXAMPLE] --help for more per-example options." 476 | , "" 477 | , "To adjust rate/history/zoom, use keys <>/[]/-+, respectively." 478 | , "" 479 | , "See: https://github.com/mstksg/hamilton#example-app-runner" 480 | ] 481 | 482 | processEvt :: 483 | Event -> Maybe SimEvt 484 | processEvt = \case 485 | EvKey KEsc [] -> Just SEQuit 486 | EvKey (KChar 'c') [MCtrl] -> Just SEQuit 487 | EvKey (KChar 'q') [] -> Just SEQuit 488 | EvKey (KChar '+') [] -> Just $ SEZoom (sqrt 2) 489 | EvKey (KChar '-') [] -> Just $ SEZoom (sqrt 0.5) 490 | EvKey (KChar '>') [] -> Just $ SERate (sqrt 2) 491 | EvKey (KChar '<') [] -> Just $ SERate (sqrt (1 / 2)) 492 | EvKey (KChar ']') [] -> Just $ SEHist 5 493 | EvKey (KChar '[') [] -> Just $ SEHist (-5) 494 | _ -> Nothing 495 | 496 | data RangeRatio = RR 497 | { rrZero :: Double 498 | -- ^ Where on the screen (0 to 1) to place the other axis 499 | , rrRatio :: Double 500 | -- ^ Ratio of height of a terminal character to width 501 | } 502 | deriving (Show) 503 | 504 | data PlotRange 505 | = PXY (Double, Double) (Double, Double) 506 | | PX (Double, Double) RangeRatio 507 | | PY RangeRatio (Double, Double) 508 | 509 | plot :: 510 | -- | display bounds 511 | (Int, Int) -> 512 | PlotRange -> 513 | -- | points to plot 514 | [(V2 Double, (Char, Attr))] -> 515 | [Image] 516 | plot (wd, ht) pr = 517 | map (crop wd ht) 518 | . (++ bgs) 519 | . map (\(p, (c, a)) -> place EQ EQ p $ char a c) 520 | where 521 | wd' = fromIntegral wd 522 | ht' = fromIntegral ht 523 | ((xmin, xmax), (ymin, ymax)) = mkRange (wd', ht') pr 524 | origin = place EQ EQ (V2 0 0) $ char defAttr '+' 525 | xaxis = place EQ EQ (V2 0 0) $ charFill defAttr '-' wd 1 526 | yaxis = place EQ EQ (V2 0 0) $ charFill defAttr '|' 1 ht 527 | xrange = xmax - xmin 528 | yrange = ymax - ymin 529 | bg = backgroundFill wd ht 530 | scale (V2 pX pY) = V2 x y 531 | where 532 | x = round $ (pX - xmin) * (wd' / xrange) 533 | y = round $ (pY - ymin) * (ht' / yrange) 534 | place aX aY p i = case scale p of 535 | V2 pX pY -> 536 | translate 537 | (fAlign aX (imageWidth i)) 538 | (fAlign aY (imageHeight i)) 539 | . translate pX pY 540 | $ i 541 | labels = 542 | [ place LT EQ (V2 xmin 0) . string defAttr $ printf "%.2f" xmin 543 | , place GT EQ (V2 xmax 0) . string defAttr $ printf "%.2f" xmax 544 | , place EQ LT (V2 0 ymin) . string defAttr $ printf "%.2f" ymin 545 | , place EQ GT (V2 0 ymax) . string defAttr $ printf "%.2f" ymax 546 | ] 547 | bgs = labels ++ [origin, xaxis, yaxis, bg] 548 | fAlign = \case 549 | LT -> const 0 550 | EQ -> negate . (`div` 2) 551 | GT -> negate 552 | 553 | mkRange :: 554 | (Double, Double) -> 555 | PlotRange -> 556 | ((Double, Double), (Double, Double)) 557 | mkRange (wd, ht) = \case 558 | PXY xb yb -> (xb, yb) 559 | PX xb RR{..} -> 560 | let yr = uncurry (-) xb * ht / wd * rrRatio 561 | y0 = (rrZero - 1) * yr 562 | in (xb, (y0, y0 + yr)) 563 | PY RR{..} yb -> 564 | let xr = uncurry (-) yb * wd / ht / rrRatio 565 | x0 = rrZero - 1 * xr 566 | in ((x0, x0 + xr), yb) 567 | 568 | pattern V1 :: a -> V.Vector 1 a 569 | pattern V1 x <- (V.head -> x) 570 | where 571 | V1 x = V.singleton x 572 | #if __GLASGOW_HASKELL__ >= 802 573 | {-# COMPLETE V1 #-} 574 | #endif 575 | 576 | type V2 = V.Vector 2 577 | pattern V2 :: a -> a -> V2 a 578 | pattern V2 x y <- (V.toList -> [x, y]) 579 | where 580 | V2 x y = V.fromTuple (x, y) 581 | #if __GLASGOW_HASKELL__ >= 802 582 | {-# COMPLETE V2 #-} 583 | #endif 584 | 585 | pattern V3 :: a -> a -> a -> V.Vector 3 a 586 | pattern V3 x y z <- (V.toList -> [x, y, z]) 587 | where 588 | V3 x y z = V.fromTuple (x, y, z) 589 | #if __GLASGOW_HASKELL__ >= 802 590 | {-# COMPLETE V3 #-} 591 | #endif 592 | 593 | pattern V4 :: a -> a -> a -> a -> V.Vector 4 a 594 | pattern V4 x y z a <- (V.toList -> [x, y, z, a]) 595 | where 596 | V4 x y z a = V.fromTuple (x, y, z, a) 597 | #if __GLASGOW_HASKELL__ >= 802 598 | {-# COMPLETE V4 #-} 599 | #endif 600 | 601 | logistic :: 602 | Floating a => a -> a -> a -> a -> a 603 | logistic pos ht width = \x -> ht / (1 + exp (-(beta * (x - pos)))) 604 | where 605 | beta = log (0.9 / (1 - 0.9)) / width 606 | 607 | bezierCurve :: 608 | forall n f a. 609 | (KnownNat (1 + n), Applicative f, Num a) => 610 | V.Vector (1 + n) (f a) -> 611 | a -> 612 | f a 613 | bezierCurve ps t = 614 | foldl' (liftA2 (+)) (pure 0) 615 | . V.imap 616 | ( \i -> 617 | let i' = fromIntegral i 618 | in fmap (* (fromIntegral (n' `choose` i') * (1 - t) ^ (n' - i') * t ^ i)) 619 | ) 620 | $ ps 621 | where 622 | n' :: Int 623 | n' = fromIntegral (maxBound :: Finite (1 + n)) 624 | choose :: Int -> Int -> Int 625 | n `choose` k = factorial n `div` (factorial (n - k) * factorial k) 626 | factorial :: Int -> Int 627 | factorial m = product [1 .. m] 628 | 629 | deriving instance Ord Color 630 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "HTTP": { 4 | "flake": false, 5 | "locked": { 6 | "lastModified": 1451647621, 7 | "narHash": "sha256-oHIyw3x0iKBexEo49YeUDV1k74ZtyYKGR2gNJXXRxts=", 8 | "owner": "phadej", 9 | "repo": "HTTP", 10 | "rev": "9bc0996d412fef1787449d841277ef663ad9a915", 11 | "type": "github" 12 | }, 13 | "original": { 14 | "owner": "phadej", 15 | "repo": "HTTP", 16 | "type": "github" 17 | } 18 | }, 19 | "cabal-32": { 20 | "flake": false, 21 | "locked": { 22 | "lastModified": 1603716527, 23 | "narHash": "sha256-X0TFfdD4KZpwl0Zr6x+PLxUt/VyKQfX7ylXHdmZIL+w=", 24 | "owner": "haskell", 25 | "repo": "cabal", 26 | "rev": "48bf10787e27364730dd37a42b603cee8d6af7ee", 27 | "type": "github" 28 | }, 29 | "original": { 30 | "owner": "haskell", 31 | "ref": "3.2", 32 | "repo": "cabal", 33 | "type": "github" 34 | } 35 | }, 36 | "cabal-34": { 37 | "flake": false, 38 | "locked": { 39 | "lastModified": 1645834128, 40 | "narHash": "sha256-wG3d+dOt14z8+ydz4SL7pwGfe7SiimxcD/LOuPCV6xM=", 41 | "owner": "haskell", 42 | "repo": "cabal", 43 | "rev": "5ff598c67f53f7c4f48e31d722ba37172230c462", 44 | "type": "github" 45 | }, 46 | "original": { 47 | "owner": "haskell", 48 | "ref": "3.4", 49 | "repo": "cabal", 50 | "type": "github" 51 | } 52 | }, 53 | "cabal-36": { 54 | "flake": false, 55 | "locked": { 56 | "lastModified": 1669081697, 57 | "narHash": "sha256-I5or+V7LZvMxfbYgZATU4awzkicBwwok4mVoje+sGmU=", 58 | "owner": "haskell", 59 | "repo": "cabal", 60 | "rev": "8fd619e33d34924a94e691c5fea2c42f0fc7f144", 61 | "type": "github" 62 | }, 63 | "original": { 64 | "owner": "haskell", 65 | "ref": "3.6", 66 | "repo": "cabal", 67 | "type": "github" 68 | } 69 | }, 70 | "cardano-shell": { 71 | "flake": false, 72 | "locked": { 73 | "lastModified": 1608537748, 74 | "narHash": "sha256-PulY1GfiMgKVnBci3ex4ptk2UNYMXqGjJOxcPy2KYT4=", 75 | "owner": "input-output-hk", 76 | "repo": "cardano-shell", 77 | "rev": "9392c75087cb9a3d453998f4230930dea3a95725", 78 | "type": "github" 79 | }, 80 | "original": { 81 | "owner": "input-output-hk", 82 | "repo": "cardano-shell", 83 | "type": "github" 84 | } 85 | }, 86 | "flake-compat": { 87 | "flake": false, 88 | "locked": { 89 | "lastModified": 1672831974, 90 | "narHash": "sha256-z9k3MfslLjWQfnjBtEtJZdq3H7kyi2kQtUThfTgdRk0=", 91 | "owner": "input-output-hk", 92 | "repo": "flake-compat", 93 | "rev": "45f2638735f8cdc40fe302742b79f248d23eb368", 94 | "type": "github" 95 | }, 96 | "original": { 97 | "owner": "input-output-hk", 98 | "ref": "hkm/gitlab-fix", 99 | "repo": "flake-compat", 100 | "type": "github" 101 | } 102 | }, 103 | "flake-utils": { 104 | "inputs": { 105 | "systems": "systems" 106 | }, 107 | "locked": { 108 | "lastModified": 1710146030, 109 | "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=", 110 | "owner": "numtide", 111 | "repo": "flake-utils", 112 | "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a", 113 | "type": "github" 114 | }, 115 | "original": { 116 | "id": "flake-utils", 117 | "type": "indirect" 118 | } 119 | }, 120 | "flake-utils_2": { 121 | "inputs": { 122 | "systems": "systems_2" 123 | }, 124 | "locked": { 125 | "lastModified": 1710146030, 126 | "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=", 127 | "owner": "numtide", 128 | "repo": "flake-utils", 129 | "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a", 130 | "type": "github" 131 | }, 132 | "original": { 133 | "owner": "numtide", 134 | "repo": "flake-utils", 135 | "type": "github" 136 | } 137 | }, 138 | "ghc-8.6.5-iohk": { 139 | "flake": false, 140 | "locked": { 141 | "lastModified": 1600920045, 142 | "narHash": "sha256-DO6kxJz248djebZLpSzTGD6s8WRpNI9BTwUeOf5RwY8=", 143 | "owner": "input-output-hk", 144 | "repo": "ghc", 145 | "rev": "95713a6ecce4551240da7c96b6176f980af75cae", 146 | "type": "github" 147 | }, 148 | "original": { 149 | "owner": "input-output-hk", 150 | "ref": "release/8.6.5-iohk", 151 | "repo": "ghc", 152 | "type": "github" 153 | } 154 | }, 155 | "hackage": { 156 | "flake": false, 157 | "locked": { 158 | "lastModified": 1719880711, 159 | "narHash": "sha256-l6O9JzsNm0hK7AKHeegzQZ7FvAlzM5qxHIWOXMebzCk=", 160 | "owner": "input-output-hk", 161 | "repo": "hackage.nix", 162 | "rev": "4b1044b947c482975b30a029a42e8e73a3bec073", 163 | "type": "github" 164 | }, 165 | "original": { 166 | "owner": "input-output-hk", 167 | "repo": "hackage.nix", 168 | "type": "github" 169 | } 170 | }, 171 | "haskellNix": { 172 | "inputs": { 173 | "HTTP": "HTTP", 174 | "cabal-32": "cabal-32", 175 | "cabal-34": "cabal-34", 176 | "cabal-36": "cabal-36", 177 | "cardano-shell": "cardano-shell", 178 | "flake-compat": "flake-compat", 179 | "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", 180 | "hackage": "hackage", 181 | "hls-1.10": "hls-1.10", 182 | "hls-2.0": "hls-2.0", 183 | "hls-2.2": "hls-2.2", 184 | "hls-2.3": "hls-2.3", 185 | "hls-2.4": "hls-2.4", 186 | "hls-2.5": "hls-2.5", 187 | "hls-2.6": "hls-2.6", 188 | "hls-2.7": "hls-2.7", 189 | "hls-2.8": "hls-2.8", 190 | "hpc-coveralls": "hpc-coveralls", 191 | "hydra": "hydra", 192 | "iserv-proxy": "iserv-proxy", 193 | "nixpkgs": [ 194 | "haskellProjectFlake", 195 | "haskellNix", 196 | "nixpkgs-unstable" 197 | ], 198 | "nixpkgs-2003": "nixpkgs-2003", 199 | "nixpkgs-2105": "nixpkgs-2105", 200 | "nixpkgs-2111": "nixpkgs-2111", 201 | "nixpkgs-2205": "nixpkgs-2205", 202 | "nixpkgs-2211": "nixpkgs-2211", 203 | "nixpkgs-2305": "nixpkgs-2305", 204 | "nixpkgs-2311": "nixpkgs-2311", 205 | "nixpkgs-unstable": "nixpkgs-unstable", 206 | "old-ghc-nix": "old-ghc-nix", 207 | "stackage": "stackage" 208 | }, 209 | "locked": { 210 | "lastModified": 1719881433, 211 | "narHash": "sha256-q995hk+Ez6itYO9no8zeF0hrmTm4RmtSPy38E1qdgyE=", 212 | "owner": "input-output-hk", 213 | "repo": "haskell.nix", 214 | "rev": "ba1756105ba7c77bbffbc1e39e6a72a33257e8d1", 215 | "type": "github" 216 | }, 217 | "original": { 218 | "owner": "input-output-hk", 219 | "repo": "haskell.nix", 220 | "type": "github" 221 | } 222 | }, 223 | "haskellProjectFlake": { 224 | "inputs": { 225 | "flake-utils": "flake-utils_2", 226 | "haskellNix": "haskellNix", 227 | "nixpkgs": [ 228 | "haskellProjectFlake", 229 | "haskellNix", 230 | "nixpkgs-unstable" 231 | ] 232 | }, 233 | "locked": { 234 | "lastModified": 1720638378, 235 | "narHash": "sha256-D8NUpQGw2WlC34kQ2IJATLGuFkwNvu18TYQok5lp40s=", 236 | "owner": "mstksg", 237 | "repo": "haskell-project-flake", 238 | "rev": "ef0afa913c13947793e77b1b844775071bfdb988", 239 | "type": "github" 240 | }, 241 | "original": { 242 | "owner": "mstksg", 243 | "repo": "haskell-project-flake", 244 | "type": "github" 245 | } 246 | }, 247 | "hls-1.10": { 248 | "flake": false, 249 | "locked": { 250 | "lastModified": 1680000865, 251 | "narHash": "sha256-rc7iiUAcrHxwRM/s0ErEsSPxOR3u8t7DvFeWlMycWgo=", 252 | "owner": "haskell", 253 | "repo": "haskell-language-server", 254 | "rev": "b08691db779f7a35ff322b71e72a12f6e3376fd9", 255 | "type": "github" 256 | }, 257 | "original": { 258 | "owner": "haskell", 259 | "ref": "1.10.0.0", 260 | "repo": "haskell-language-server", 261 | "type": "github" 262 | } 263 | }, 264 | "hls-2.0": { 265 | "flake": false, 266 | "locked": { 267 | "lastModified": 1687698105, 268 | "narHash": "sha256-OHXlgRzs/kuJH8q7Sxh507H+0Rb8b7VOiPAjcY9sM1k=", 269 | "owner": "haskell", 270 | "repo": "haskell-language-server", 271 | "rev": "783905f211ac63edf982dd1889c671653327e441", 272 | "type": "github" 273 | }, 274 | "original": { 275 | "owner": "haskell", 276 | "ref": "2.0.0.1", 277 | "repo": "haskell-language-server", 278 | "type": "github" 279 | } 280 | }, 281 | "hls-2.2": { 282 | "flake": false, 283 | "locked": { 284 | "lastModified": 1693064058, 285 | "narHash": "sha256-8DGIyz5GjuCFmohY6Fa79hHA/p1iIqubfJUTGQElbNk=", 286 | "owner": "haskell", 287 | "repo": "haskell-language-server", 288 | "rev": "b30f4b6cf5822f3112c35d14a0cba51f3fe23b85", 289 | "type": "github" 290 | }, 291 | "original": { 292 | "owner": "haskell", 293 | "ref": "2.2.0.0", 294 | "repo": "haskell-language-server", 295 | "type": "github" 296 | } 297 | }, 298 | "hls-2.3": { 299 | "flake": false, 300 | "locked": { 301 | "lastModified": 1695910642, 302 | "narHash": "sha256-tR58doOs3DncFehHwCLczJgntyG/zlsSd7DgDgMPOkI=", 303 | "owner": "haskell", 304 | "repo": "haskell-language-server", 305 | "rev": "458ccdb55c9ea22cd5d13ec3051aaefb295321be", 306 | "type": "github" 307 | }, 308 | "original": { 309 | "owner": "haskell", 310 | "ref": "2.3.0.0", 311 | "repo": "haskell-language-server", 312 | "type": "github" 313 | } 314 | }, 315 | "hls-2.4": { 316 | "flake": false, 317 | "locked": { 318 | "lastModified": 1699862708, 319 | "narHash": "sha256-YHXSkdz53zd0fYGIYOgLt6HrA0eaRJi9mXVqDgmvrjk=", 320 | "owner": "haskell", 321 | "repo": "haskell-language-server", 322 | "rev": "54507ef7e85fa8e9d0eb9a669832a3287ffccd57", 323 | "type": "github" 324 | }, 325 | "original": { 326 | "owner": "haskell", 327 | "ref": "2.4.0.1", 328 | "repo": "haskell-language-server", 329 | "type": "github" 330 | } 331 | }, 332 | "hls-2.5": { 333 | "flake": false, 334 | "locked": { 335 | "lastModified": 1701080174, 336 | "narHash": "sha256-fyiR9TaHGJIIR0UmcCb73Xv9TJq3ht2ioxQ2mT7kVdc=", 337 | "owner": "haskell", 338 | "repo": "haskell-language-server", 339 | "rev": "27f8c3d3892e38edaef5bea3870161815c4d014c", 340 | "type": "github" 341 | }, 342 | "original": { 343 | "owner": "haskell", 344 | "ref": "2.5.0.0", 345 | "repo": "haskell-language-server", 346 | "type": "github" 347 | } 348 | }, 349 | "hls-2.6": { 350 | "flake": false, 351 | "locked": { 352 | "lastModified": 1705325287, 353 | "narHash": "sha256-+P87oLdlPyMw8Mgoul7HMWdEvWP/fNlo8jyNtwME8E8=", 354 | "owner": "haskell", 355 | "repo": "haskell-language-server", 356 | "rev": "6e0b342fa0327e628610f2711f8c3e4eaaa08b1e", 357 | "type": "github" 358 | }, 359 | "original": { 360 | "owner": "haskell", 361 | "ref": "2.6.0.0", 362 | "repo": "haskell-language-server", 363 | "type": "github" 364 | } 365 | }, 366 | "hls-2.7": { 367 | "flake": false, 368 | "locked": { 369 | "lastModified": 1708965829, 370 | "narHash": "sha256-LfJ+TBcBFq/XKoiNI7pc4VoHg4WmuzsFxYJ3Fu+Jf+M=", 371 | "owner": "haskell", 372 | "repo": "haskell-language-server", 373 | "rev": "50322b0a4aefb27adc5ec42f5055aaa8f8e38001", 374 | "type": "github" 375 | }, 376 | "original": { 377 | "owner": "haskell", 378 | "ref": "2.7.0.0", 379 | "repo": "haskell-language-server", 380 | "type": "github" 381 | } 382 | }, 383 | "hls-2.8": { 384 | "flake": false, 385 | "locked": { 386 | "lastModified": 1715153580, 387 | "narHash": "sha256-Vi/iUt2pWyUJlo9VrYgTcbRviWE0cFO6rmGi9rmALw0=", 388 | "owner": "haskell", 389 | "repo": "haskell-language-server", 390 | "rev": "dd1be1beb16700de59e0d6801957290bcf956a0a", 391 | "type": "github" 392 | }, 393 | "original": { 394 | "owner": "haskell", 395 | "ref": "2.8.0.0", 396 | "repo": "haskell-language-server", 397 | "type": "github" 398 | } 399 | }, 400 | "hpc-coveralls": { 401 | "flake": false, 402 | "locked": { 403 | "lastModified": 1607498076, 404 | "narHash": "sha256-8uqsEtivphgZWYeUo5RDUhp6bO9j2vaaProQxHBltQk=", 405 | "owner": "sevanspowell", 406 | "repo": "hpc-coveralls", 407 | "rev": "14df0f7d229f4cd2e79f8eabb1a740097fdfa430", 408 | "type": "github" 409 | }, 410 | "original": { 411 | "owner": "sevanspowell", 412 | "repo": "hpc-coveralls", 413 | "type": "github" 414 | } 415 | }, 416 | "hydra": { 417 | "inputs": { 418 | "nix": "nix", 419 | "nixpkgs": [ 420 | "haskellProjectFlake", 421 | "haskellNix", 422 | "hydra", 423 | "nix", 424 | "nixpkgs" 425 | ] 426 | }, 427 | "locked": { 428 | "lastModified": 1671755331, 429 | "narHash": "sha256-hXsgJj0Cy0ZiCiYdW2OdBz5WmFyOMKuw4zyxKpgUKm4=", 430 | "owner": "NixOS", 431 | "repo": "hydra", 432 | "rev": "f48f00ee6d5727ae3e488cbf9ce157460853fea8", 433 | "type": "github" 434 | }, 435 | "original": { 436 | "id": "hydra", 437 | "type": "indirect" 438 | } 439 | }, 440 | "iserv-proxy": { 441 | "flake": false, 442 | "locked": { 443 | "lastModified": 1717479972, 444 | "narHash": "sha256-7vE3RQycHI1YT9LHJ1/fUaeln2vIpYm6Mmn8FTpYeVo=", 445 | "owner": "stable-haskell", 446 | "repo": "iserv-proxy", 447 | "rev": "2ed34002247213fc435d0062350b91bab920626e", 448 | "type": "github" 449 | }, 450 | "original": { 451 | "owner": "stable-haskell", 452 | "ref": "iserv-syms", 453 | "repo": "iserv-proxy", 454 | "type": "github" 455 | } 456 | }, 457 | "lowdown-src": { 458 | "flake": false, 459 | "locked": { 460 | "lastModified": 1633514407, 461 | "narHash": "sha256-Dw32tiMjdK9t3ETl5fzGrutQTzh2rufgZV4A/BbxuD4=", 462 | "owner": "kristapsdz", 463 | "repo": "lowdown", 464 | "rev": "d2c2b44ff6c27b936ec27358a2653caaef8f73b8", 465 | "type": "github" 466 | }, 467 | "original": { 468 | "owner": "kristapsdz", 469 | "repo": "lowdown", 470 | "type": "github" 471 | } 472 | }, 473 | "nix": { 474 | "inputs": { 475 | "lowdown-src": "lowdown-src", 476 | "nixpkgs": "nixpkgs", 477 | "nixpkgs-regression": "nixpkgs-regression" 478 | }, 479 | "locked": { 480 | "lastModified": 1661606874, 481 | "narHash": "sha256-9+rpYzI+SmxJn+EbYxjGv68Ucp22bdFUSy/4LkHkkDQ=", 482 | "owner": "NixOS", 483 | "repo": "nix", 484 | "rev": "11e45768b34fdafdcf019ddbd337afa16127ff0f", 485 | "type": "github" 486 | }, 487 | "original": { 488 | "owner": "NixOS", 489 | "ref": "2.11.0", 490 | "repo": "nix", 491 | "type": "github" 492 | } 493 | }, 494 | "nixpkgs": { 495 | "locked": { 496 | "lastModified": 1657693803, 497 | "narHash": "sha256-G++2CJ9u0E7NNTAi9n5G8TdDmGJXcIjkJ3NF8cetQB8=", 498 | "owner": "NixOS", 499 | "repo": "nixpkgs", 500 | "rev": "365e1b3a859281cf11b94f87231adeabbdd878a2", 501 | "type": "github" 502 | }, 503 | "original": { 504 | "owner": "NixOS", 505 | "ref": "nixos-22.05-small", 506 | "repo": "nixpkgs", 507 | "type": "github" 508 | } 509 | }, 510 | "nixpkgs-2003": { 511 | "locked": { 512 | "lastModified": 1620055814, 513 | "narHash": "sha256-8LEHoYSJiL901bTMVatq+rf8y7QtWuZhwwpKE2fyaRY=", 514 | "owner": "NixOS", 515 | "repo": "nixpkgs", 516 | "rev": "1db42b7fe3878f3f5f7a4f2dc210772fd080e205", 517 | "type": "github" 518 | }, 519 | "original": { 520 | "owner": "NixOS", 521 | "ref": "nixpkgs-20.03-darwin", 522 | "repo": "nixpkgs", 523 | "type": "github" 524 | } 525 | }, 526 | "nixpkgs-2105": { 527 | "locked": { 528 | "lastModified": 1659914493, 529 | "narHash": "sha256-lkA5X3VNMKirvA+SUzvEhfA7XquWLci+CGi505YFAIs=", 530 | "owner": "NixOS", 531 | "repo": "nixpkgs", 532 | "rev": "022caabb5f2265ad4006c1fa5b1ebe69fb0c3faf", 533 | "type": "github" 534 | }, 535 | "original": { 536 | "owner": "NixOS", 537 | "ref": "nixpkgs-21.05-darwin", 538 | "repo": "nixpkgs", 539 | "type": "github" 540 | } 541 | }, 542 | "nixpkgs-2111": { 543 | "locked": { 544 | "lastModified": 1659446231, 545 | "narHash": "sha256-hekabNdTdgR/iLsgce5TGWmfIDZ86qjPhxDg/8TlzhE=", 546 | "owner": "NixOS", 547 | "repo": "nixpkgs", 548 | "rev": "eabc38219184cc3e04a974fe31857d8e0eac098d", 549 | "type": "github" 550 | }, 551 | "original": { 552 | "owner": "NixOS", 553 | "ref": "nixpkgs-21.11-darwin", 554 | "repo": "nixpkgs", 555 | "type": "github" 556 | } 557 | }, 558 | "nixpkgs-2205": { 559 | "locked": { 560 | "lastModified": 1685573264, 561 | "narHash": "sha256-Zffu01pONhs/pqH07cjlF10NnMDLok8ix5Uk4rhOnZQ=", 562 | "owner": "NixOS", 563 | "repo": "nixpkgs", 564 | "rev": "380be19fbd2d9079f677978361792cb25e8a3635", 565 | "type": "github" 566 | }, 567 | "original": { 568 | "owner": "NixOS", 569 | "ref": "nixpkgs-22.05-darwin", 570 | "repo": "nixpkgs", 571 | "type": "github" 572 | } 573 | }, 574 | "nixpkgs-2211": { 575 | "locked": { 576 | "lastModified": 1688392541, 577 | "narHash": "sha256-lHrKvEkCPTUO+7tPfjIcb7Trk6k31rz18vkyqmkeJfY=", 578 | "owner": "NixOS", 579 | "repo": "nixpkgs", 580 | "rev": "ea4c80b39be4c09702b0cb3b42eab59e2ba4f24b", 581 | "type": "github" 582 | }, 583 | "original": { 584 | "owner": "NixOS", 585 | "ref": "nixpkgs-22.11-darwin", 586 | "repo": "nixpkgs", 587 | "type": "github" 588 | } 589 | }, 590 | "nixpkgs-2305": { 591 | "locked": { 592 | "lastModified": 1701362232, 593 | "narHash": "sha256-GVdzxL0lhEadqs3hfRLuj+L1OJFGiL/L7gCcelgBlsw=", 594 | "owner": "NixOS", 595 | "repo": "nixpkgs", 596 | "rev": "d2332963662edffacfddfad59ff4f709dde80ffe", 597 | "type": "github" 598 | }, 599 | "original": { 600 | "owner": "NixOS", 601 | "ref": "nixpkgs-23.05-darwin", 602 | "repo": "nixpkgs", 603 | "type": "github" 604 | } 605 | }, 606 | "nixpkgs-2311": { 607 | "locked": { 608 | "lastModified": 1701386440, 609 | "narHash": "sha256-xI0uQ9E7JbmEy/v8kR9ZQan6389rHug+zOtZeZFiDJk=", 610 | "owner": "NixOS", 611 | "repo": "nixpkgs", 612 | "rev": "293822e55ec1872f715a66d0eda9e592dc14419f", 613 | "type": "github" 614 | }, 615 | "original": { 616 | "owner": "NixOS", 617 | "ref": "nixpkgs-23.11-darwin", 618 | "repo": "nixpkgs", 619 | "type": "github" 620 | } 621 | }, 622 | "nixpkgs-regression": { 623 | "locked": { 624 | "lastModified": 1643052045, 625 | "narHash": "sha256-uGJ0VXIhWKGXxkeNnq4TvV3CIOkUJ3PAoLZ3HMzNVMw=", 626 | "owner": "NixOS", 627 | "repo": "nixpkgs", 628 | "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", 629 | "type": "github" 630 | }, 631 | "original": { 632 | "owner": "NixOS", 633 | "repo": "nixpkgs", 634 | "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", 635 | "type": "github" 636 | } 637 | }, 638 | "nixpkgs-unstable": { 639 | "locked": { 640 | "lastModified": 1694822471, 641 | "narHash": "sha256-6fSDCj++lZVMZlyqOe9SIOL8tYSBz1bI8acwovRwoX8=", 642 | "owner": "NixOS", 643 | "repo": "nixpkgs", 644 | "rev": "47585496bcb13fb72e4a90daeea2f434e2501998", 645 | "type": "github" 646 | }, 647 | "original": { 648 | "owner": "NixOS", 649 | "repo": "nixpkgs", 650 | "rev": "47585496bcb13fb72e4a90daeea2f434e2501998", 651 | "type": "github" 652 | } 653 | }, 654 | "old-ghc-nix": { 655 | "flake": false, 656 | "locked": { 657 | "lastModified": 1631092763, 658 | "narHash": "sha256-sIKgO+z7tj4lw3u6oBZxqIhDrzSkvpHtv0Kki+lh9Fg=", 659 | "owner": "angerman", 660 | "repo": "old-ghc-nix", 661 | "rev": "af48a7a7353e418119b6dfe3cd1463a657f342b8", 662 | "type": "github" 663 | }, 664 | "original": { 665 | "owner": "angerman", 666 | "ref": "master", 667 | "repo": "old-ghc-nix", 668 | "type": "github" 669 | } 670 | }, 671 | "root": { 672 | "inputs": { 673 | "flake-utils": "flake-utils", 674 | "haskellProjectFlake": "haskellProjectFlake", 675 | "nixpkgs": [ 676 | "haskellProjectFlake", 677 | "nixpkgs" 678 | ] 679 | } 680 | }, 681 | "stackage": { 682 | "flake": false, 683 | "locked": { 684 | "lastModified": 1719879847, 685 | "narHash": "sha256-6dqYwS1aUwn8bm+8Tan/tNGmEoWbjArBKO/jTh964f8=", 686 | "owner": "input-output-hk", 687 | "repo": "stackage.nix", 688 | "rev": "562135a1623b181e8a4fd8d76c63827d9f4417c6", 689 | "type": "github" 690 | }, 691 | "original": { 692 | "owner": "input-output-hk", 693 | "repo": "stackage.nix", 694 | "type": "github" 695 | } 696 | }, 697 | "systems": { 698 | "locked": { 699 | "lastModified": 1681028828, 700 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 701 | "owner": "nix-systems", 702 | "repo": "default", 703 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 704 | "type": "github" 705 | }, 706 | "original": { 707 | "owner": "nix-systems", 708 | "repo": "default", 709 | "type": "github" 710 | } 711 | }, 712 | "systems_2": { 713 | "locked": { 714 | "lastModified": 1681028828, 715 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 716 | "owner": "nix-systems", 717 | "repo": "default", 718 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 719 | "type": "github" 720 | }, 721 | "original": { 722 | "owner": "nix-systems", 723 | "repo": "default", 724 | "type": "github" 725 | } 726 | } 727 | }, 728 | "root": "root", 729 | "version": 7 730 | } 731 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "Basic Haskell Project Flake"; 3 | inputs = { 4 | haskellProjectFlake.url = "github:mstksg/haskell-project-flake"; 5 | nixpkgs.follows = "haskellProjectFlake/nixpkgs"; 6 | }; 7 | outputs = 8 | { self 9 | , nixpkgs 10 | , flake-utils 11 | , haskellProjectFlake 12 | }: 13 | flake-utils.lib.eachDefaultSystem (system: 14 | let 15 | name = "hamilton"; 16 | pkgs = import nixpkgs { 17 | inherit system; 18 | overlays = [ haskellProjectFlake.overlays."${system}".default ]; 19 | }; 20 | project-flake = pkgs.haskell-project-flake 21 | { 22 | inherit name; 23 | src = ./.; 24 | excludeCompilerMajors = [ "ghc911" ]; 25 | defaultCompiler = "ghc982"; 26 | }; 27 | in 28 | { 29 | packages = project-flake.packages; 30 | apps = project-flake.apps; 31 | checks = project-flake.checks; 32 | devShells = project-flake.devShells; 33 | legacyPackages."${name}" = project-flake; 34 | } 35 | ); 36 | } 37 | 38 | -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | column-limit: 100 2 | comma-style: leading 3 | fixities: [] 4 | function-arrows: trailing 5 | haddock-style: single-line 6 | haddock-style-module: null 7 | import-export-style: diff-friendly 8 | in-style: right-align 9 | indent-wheres: true 10 | indentation: 2 11 | let-style: inline 12 | newlines-between-decls: 1 13 | record-break-space: true 14 | reexports: [] 15 | respectful: true 16 | single-constraint-parens: never 17 | unicode: detect 18 | -------------------------------------------------------------------------------- /hamilton.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.36.1. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: hamilton 8 | version: 0.1.0.4 9 | synopsis: 10 | Physics on generalized coordinate systems using Hamiltonian Mechanics and AD 11 | 12 | description: 13 | See README.md (or read online at ) 14 | 15 | category: Physics 16 | homepage: https://github.com/mstksg/hamilton#readme 17 | bug-reports: https://github.com/mstksg/hamilton/issues 18 | author: Justin Le 19 | maintainer: justin@jle.im 20 | copyright: (c) Justin Le 2024 21 | license: BSD3 22 | license-file: LICENSE 23 | build-type: Simple 24 | tested-with: GHC >=8.10 25 | extra-source-files: 26 | CHANGELOG.md 27 | README.md 28 | 29 | source-repository head 30 | type: git 31 | location: https://github.com/mstksg/hamilton 32 | 33 | library 34 | exposed-modules: Numeric.Hamilton 35 | other-modules: Paths_hamilton 36 | hs-source-dirs: src 37 | ghc-options: -Wall -O2 38 | build-depends: 39 | ad 40 | , base >=4.9 && <5 41 | , ghc-typelits-natnormalise 42 | , hmatrix >=0.18 43 | , hmatrix-gsl >=0.18 44 | , hmatrix-vector-sized >=0.1.3 45 | , typelits-witnesses >=0.2.3 46 | , vector-sized >=1.0 47 | 48 | default-language: Haskell2010 49 | 50 | executable hamilton-examples 51 | main-is: Examples.hs 52 | other-modules: Paths_hamilton 53 | hs-source-dirs: app 54 | ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N 55 | build-depends: 56 | base >=4.9 && <5 57 | , containers 58 | , finite-typelits 59 | , ghc-typelits-knownnat 60 | , hamilton 61 | , hmatrix >=0.18 62 | , hmatrix-vector-sized >=0.1.3 63 | , optparse-applicative >=0.13 64 | , prettyprinter 65 | , vector 66 | , vector-sized >=1.0 67 | , vty 68 | , vty-crossplatform 69 | 70 | default-language: Haskell2010 71 | -------------------------------------------------------------------------------- /src/Numeric/Hamilton.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE StandaloneDeriving #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} 12 | 13 | -- | 14 | -- Module : Numeric.Hamilton 15 | -- Description : Hamiltonian dynamics for physical systems on generalized 16 | -- coordinates using automatic differentiation 17 | -- Copyright : (c) Justin Le 2024 18 | -- License : BSD-3 19 | -- Maintainer : justin@jle.im 20 | -- Stability : unstable 21 | -- Portability : portable 22 | -- 23 | -- Simulate physical systems on generalized/arbitrary coordinates using 24 | -- Hamiltonian mechanics and automatic differentiation! 25 | -- 26 | -- See the for more 27 | -- information on usage! 28 | module Numeric.Hamilton ( 29 | -- * Systems and states 30 | 31 | -- ** Systems 32 | System, 33 | mkSystem, 34 | mkSystem', 35 | underlyingPos, 36 | 37 | -- ** States 38 | Config (..), 39 | Phase (..), 40 | toPhase, 41 | fromPhase, 42 | 43 | -- * State functions 44 | momenta, 45 | velocities, 46 | keC, 47 | keP, 48 | pe, 49 | lagrangian, 50 | hamiltonian, 51 | hamEqs, 52 | 53 | -- * Simulating hamiltonian dynamics 54 | 55 | -- ** Over phase space 56 | stepHam, 57 | evolveHam, 58 | evolveHam', 59 | 60 | -- ** Over configuration space 61 | 62 | -- | Convenience wrappers over the normal phase-space 63 | -- steppers/simulators that allow you to provide input and expect 64 | -- output in configuration space instead of in phase space. Note that 65 | -- the simulation itself still runs in phase space, so these all 66 | -- require conversions to and from phase space under the hood. 67 | stepHamC, 68 | evolveHamC, 69 | evolveHamC', 70 | ) where 71 | 72 | import Control.Monad 73 | import Data.Bifunctor 74 | import Data.Foldable 75 | import Data.Kind 76 | import Data.Maybe 77 | import Data.Proxy 78 | import Data.Type.Equality 79 | import qualified Data.Vector.Generic.Sized as VG 80 | import qualified Data.Vector.Sized as V 81 | import GHC.Generics (Generic) 82 | import GHC.TypeLits 83 | import GHC.TypeLits.Compare 84 | import Numeric.AD 85 | import Numeric.GSL.ODE 86 | import qualified Numeric.LinearAlgebra as LA 87 | import Numeric.LinearAlgebra.Static as H 88 | import Numeric.LinearAlgebra.Static.Vector 89 | 90 | -- | Represents the full state of a system of @n@ generalized coordinates 91 | -- in configuration space (informally, "positions and velocities") 92 | -- 93 | -- A configuration space representaiton is more directly "physically 94 | -- meaningful" and intuitive/understandable to humans than a phase space 95 | -- representation. However, it's much less mathematically ideal to work 96 | -- with because of the lack of some neat underlying symmetries. 97 | -- 98 | -- You can convert a @'Config' n@ into a @'Phase' n@ (convert from 99 | -- configuration space to phase space) for a given system with 'toPhase'. 100 | -- This allows you to state your system in configuration space and then 101 | -- convert it to phase space before handing it off to the hamiltonian 102 | -- machinery. 103 | data Config :: Nat -> Type where 104 | Cfg :: 105 | { cfgPositions :: !(R n) 106 | -- ^ The current values ("positions") of each of the @n@ 107 | -- generalized coordinates 108 | , cfgVelocities :: !(R n) 109 | -- ^ The current rate of changes ("velocities") of each of the 110 | -- @n@ generalized coordinates 111 | } -> 112 | Config n 113 | deriving (Generic) 114 | 115 | deriving instance KnownNat n => Show (Config n) 116 | 117 | -- | Represents the full state of a system of @n@ generalized coordinates 118 | -- in phase space (informally, "positions and momentums"). 119 | -- 120 | -- Phase space representations are much nicer to work with mathematically 121 | -- because of some neat underlying symmetries. For one, positions and 122 | -- momentums are "interchangeable" in a system; if you swap every 123 | -- coordinate's positions with their momentums, and also swap them in the 124 | -- equations of motions, you get the same system back. This isn't the case 125 | -- with configuration space representations. 126 | -- 127 | -- A hamiltonian simulation basically describes the trajectory of each 128 | -- coordinate through phase space, so this is the /state/ of the 129 | -- simulation. However, configuration space representations are much more 130 | -- understandable to humans, so it might be useful to give an initial state 131 | -- in configuration space using 'Config', and then convert it to a 'Phase' 132 | -- with 'toPhase'. 133 | data Phase :: Nat -> Type where 134 | Phs :: 135 | { phsPositions :: !(R n) 136 | -- ^ The current values ("positions") of each of the @n@ 137 | -- generalized coordinates. 138 | , phsMomenta :: !(R n) 139 | -- ^ The current conjugate momenta ("momentums") to each of 140 | -- the @n@ generalized coordinates 141 | } -> 142 | Phase n 143 | deriving (Generic) 144 | 145 | deriving instance KnownNat n => Show (Phase n) 146 | 147 | -- | Represents a physical system in which physics happens. A @'System' 148 | -- m n@ is a system whose state described using @n@ generalized coordinates 149 | -- (an "@n@-dimensional" system), where the underlying cartesian coordinate 150 | -- space is @m@-dimensional. 151 | -- 152 | -- For the most part, you are supposed to be able to ignore @m@. @m@ is 153 | -- only provided because it's useful when plotting/drawing the system with 154 | -- a given state back in rectangular coordinates. (The only function that 155 | -- use the @m@ at the moment is 'underlyingPos') 156 | -- 157 | -- A @'System' m n@'s state is described using a @'Config' n@ (which 158 | -- describes the system in configuration space) or a @'Phase' n@ (which 159 | -- describes the system in phase space). 160 | data System :: Nat -> Nat -> Type where 161 | Sys :: 162 | { _sysInertia :: R m 163 | , _sysCoords :: R n -> R m 164 | , _sysJacobian :: R n -> L m n 165 | , _sysHessian :: R n -> V.Vector n (L m n) 166 | , _sysPotential :: R n -> Double 167 | , _sysPotentialGrad :: R n -> R n 168 | } -> 169 | System m n 170 | 171 | -- | Converts the position of generalized coordinates of a system to the 172 | -- coordinates of the system's underlying cartesian coordinate system. 173 | -- Useful for plotting/drawing the system in cartesian space. 174 | underlyingPos :: 175 | System m n -> 176 | R n -> 177 | R m 178 | underlyingPos = _sysCoords 179 | 180 | -- | The potential energy of a system, given the position in the 181 | -- generalized coordinates of the system. 182 | pe :: 183 | System m n -> 184 | R n -> 185 | Double 186 | pe = _sysPotential 187 | 188 | vec2l :: 189 | (KnownNat m, KnownNat n) => 190 | V.Vector m (V.Vector n Double) -> 191 | L m n 192 | vec2l = rowsL . fmap gvecR 193 | 194 | -- | Create a system with @n@ generalized coordinates by describing its 195 | -- coordinate space (by a function from the generalized coordinates to the 196 | -- underlying cartesian coordinates), the inertia of each of those 197 | -- underlying coordinates, and the pontential energy function. 198 | -- 199 | -- The potential energy function is expressed in terms of the genearlized 200 | -- coordinate space's positions. 201 | mkSystem :: 202 | forall m n. 203 | (KnownNat m, KnownNat n) => 204 | -- | The "inertia" of each of the @m@ coordinates 205 | -- in the underlying cartesian space of the system. This 206 | -- should be mass for linear coordinates and rotational 207 | -- inertia for angular coordinates. 208 | R m -> 209 | -- | Conversion function to convert points in the 210 | -- generalized coordinate space to the underlying cartesian 211 | -- space of the system. 212 | (forall a. RealFloat a => V.Vector n a -> V.Vector m a) -> 213 | -- | The potential energy of the system as a function of 214 | -- the generalized coordinate space's positions. 215 | (forall a. RealFloat a => V.Vector n a -> a) -> 216 | System m n 217 | mkSystem m f u = 218 | Sys 219 | { _sysInertia = m 220 | , _sysCoords = gvecR . f . grVec 221 | , _sysJacobian = tr . vec2l . jacobianT f . grVec 222 | , _sysHessian = tr2 . fmap vec2l . hessianF f . grVec 223 | , _sysPotential = u . grVec 224 | , _sysPotentialGrad = gvecR . grad u . grVec 225 | } 226 | where 227 | tr2 :: 228 | forall o. 229 | (KnownNat n, KnownNat o) => 230 | V.Vector m (L n o) -> 231 | V.Vector n (L m o) 232 | tr2 = fmap rowsL . traverse lRows 233 | {-# INLINE tr2 #-} 234 | 235 | -- | Convenience wrapper over 'mkSystem' that allows you to specify the 236 | -- potential energy function in terms of the underlying cartesian 237 | -- coordinate space. 238 | mkSystem' :: 239 | forall m n. 240 | (KnownNat m, KnownNat n) => 241 | -- | The "inertia" of each of the @m@ coordinates 242 | -- in the underlying cartesian space of the system. This 243 | -- should be mass for linear coordinates and rotational 244 | -- inertia for angular coordinates. 245 | R m -> 246 | -- | Conversion function to convert points in the 247 | -- generalized coordinate space to the underlying cartesian 248 | -- space of the system. 249 | (forall a. RealFloat a => V.Vector n a -> V.Vector m a) -> 250 | -- | The potential energy of the system as a function of 251 | -- the underlying cartesian coordinate space's positions. 252 | (forall a. RealFloat a => V.Vector m a -> a) -> 253 | System m n 254 | mkSystem' m f u = mkSystem m f (u . f) 255 | 256 | -- | Compute the generalized momenta conjugate to each generalized 257 | -- coordinate of a system by giving the configuration-space state of the 258 | -- system. 259 | -- 260 | -- Note that getting the momenta from a @'Phase' n@ involves just using 261 | -- 'phsMomenta'. 262 | momenta :: 263 | (KnownNat m, KnownNat n) => 264 | System m n -> 265 | Config n -> 266 | R n 267 | momenta Sys{..} Cfg{..} = tr j #> diag _sysInertia #> j #> cfgVelocities 268 | where 269 | j = _sysJacobian cfgPositions 270 | 271 | -- | Convert a configuration-space representaiton of the state of the 272 | -- system to a phase-space representation. 273 | -- 274 | -- Useful because the hamiltonian simulations use 'Phase' as its working 275 | -- state, but 'Config' is a much more human-understandable and intuitive 276 | -- representation. This allows you to state your starting state in 277 | -- configuration space and convert to phase space for your simulation to 278 | -- use. 279 | toPhase :: 280 | (KnownNat m, KnownNat n) => 281 | System m n -> 282 | Config n -> 283 | Phase n 284 | toPhase s = Phs <$> cfgPositions <*> momenta s 285 | 286 | -- | The kinetic energy of a system, given the system's state in 287 | -- configuration space. 288 | keC :: 289 | (KnownNat m, KnownNat n) => 290 | System m n -> 291 | Config n -> 292 | Double 293 | keC s = do 294 | vs <- cfgVelocities 295 | ps <- momenta s 296 | return $ (vs <.> ps) / 2 297 | 298 | -- | The Lagrangian of a system (the difference between the kinetic energy 299 | -- and the potential energy), given the system's state in configuration 300 | -- space. 301 | lagrangian :: 302 | (KnownNat m, KnownNat n) => 303 | System m n -> 304 | Config n -> 305 | Double 306 | lagrangian s = do 307 | t <- keC s 308 | u <- pe s . cfgPositions 309 | return (t - u) 310 | 311 | -- | Compute the rate of change of each generalized coordinate by giving 312 | -- the state of the system in phase space. 313 | -- 314 | -- Note that getting the velocities from a @'Config' n@ involves just using 315 | -- 'cfgVelocities'. 316 | velocities :: 317 | (KnownNat m, KnownNat n) => 318 | System m n -> 319 | Phase n -> 320 | R n 321 | velocities Sys{..} Phs{..} = inv jmj #> phsMomenta 322 | where 323 | j = _sysJacobian phsPositions 324 | jmj = tr j H.<> diag _sysInertia H.<> j 325 | 326 | -- | Invert 'toPhase' and convert a description of a system's state in 327 | -- phase space to a description of the system's state in configuration 328 | -- space. 329 | -- 330 | -- Possibly useful for showing the phase space representation of a system's 331 | -- state in a more human-readable/human-understandable way. 332 | fromPhase :: 333 | (KnownNat m, KnownNat n) => 334 | System m n -> 335 | Phase n -> 336 | Config n 337 | fromPhase s = Cfg <$> phsPositions <*> velocities s 338 | 339 | -- | The kinetic energy of a system, given the system's state in 340 | -- phase space. 341 | keP :: 342 | (KnownNat m, KnownNat n) => 343 | System m n -> 344 | Phase n -> 345 | Double 346 | keP s = do 347 | ps <- phsMomenta 348 | vs <- velocities s 349 | return $ (vs <.> ps) / 2 350 | 351 | -- | The Hamiltonian of a system (the sum of kinetic energy and the 352 | -- potential energy), given the system's state in phase space. 353 | hamiltonian :: 354 | (KnownNat m, KnownNat n) => 355 | System m n -> 356 | Phase n -> 357 | Double 358 | hamiltonian s = do 359 | t <- keP s 360 | u <- pe s . phsPositions 361 | return (t + u) 362 | 363 | -- | The "hamiltonian equations" for a given system at a given state in 364 | -- phase space. Returns the rate of change of the positions and 365 | -- conjugate momenta, which can be used to progress the simulation through 366 | -- time. 367 | -- 368 | -- Computed using the maths derived in 369 | -- . 370 | hamEqs :: 371 | (KnownNat m, KnownNat n) => 372 | System m n -> 373 | Phase n -> 374 | (R n, R n) 375 | hamEqs Sys{..} Phs{..} = (dHdp, -dHdq) 376 | where 377 | mm = diag _sysInertia 378 | j = _sysJacobian phsPositions 379 | trj = tr j 380 | jmj = trj H.<> mm H.<> j 381 | ijmj = inv jmj 382 | dTdq = gvecR 383 | . flip fmap (_sysHessian phsPositions) 384 | $ \djdq -> 385 | -(phsMomenta <.> ijmj #> trj #> mm #> djdq #> ijmj #> phsMomenta) 386 | dHdp = ijmj #> phsMomenta 387 | dHdq = dTdq + _sysPotentialGrad phsPositions 388 | 389 | -- | Step a system through phase space over over a single timestep. 390 | stepHam :: 391 | forall m n. 392 | (KnownNat m, KnownNat n) => 393 | -- | timestep to step through 394 | Double -> 395 | -- | system to simulate 396 | System m n -> 397 | -- | initial state, in phase space 398 | Phase n -> 399 | Phase n 400 | stepHam r s p = 401 | evolveHam @m @n @2 s p (V.fromTuple (0, r)) 402 | `V.unsafeIndex` 1 403 | 404 | -- | Evolve a system using a hamiltonian stepper, with the given initial 405 | -- phase space state. 406 | -- 407 | -- Desired solution times provided as a list instead of a sized 'V.Vector'. 408 | -- The output list should be the same length as the input list. 409 | evolveHam' :: 410 | forall m n. 411 | (KnownNat m, KnownNat n) => 412 | -- | system to simulate 413 | System m n -> 414 | -- | initial state, in phase space 415 | Phase n -> 416 | -- | desired solution times 417 | [Double] -> 418 | [Phase n] 419 | evolveHam' _ _ [] = [] 420 | evolveHam' s p0 ts = V.withSizedList (toList ts') $ \(v :: V.Vector s Double) -> 421 | case Proxy @2 %<=? Proxy @s of 422 | LE Refl -> 423 | (if l1 then toList . V.tail @(s - 1) else toList) $ 424 | evolveHam s p0 v 425 | NLE{} -> error "evolveHam': Internal error" 426 | where 427 | (l1, ts') = case ts of 428 | [x] -> (True, [0, x]) 429 | _ -> (False, ts) 430 | 431 | -- | Evolve a system using a hamiltonian stepper, with the given initial 432 | -- phase space state. 433 | evolveHam :: 434 | forall m n s. 435 | (KnownNat m, KnownNat n, KnownNat s, 2 <= s) => 436 | -- | system to simulate 437 | System m n -> 438 | -- | initial state, in phase space 439 | Phase n -> 440 | -- | desired solution times 441 | V.Vector s Double -> 442 | V.Vector s (Phase n) 443 | evolveHam s p0 ts = 444 | fmap toPs . fromJust . V.fromList . LA.toRows $ 445 | odeSolveV RKf45 hi eps eps (const f) (fromPs p0) ts' 446 | where 447 | hi = (V.unsafeIndex ts 1 - V.unsafeIndex ts 0) / 100 448 | eps = 1.49012e-08 449 | f :: LA.Vector Double -> LA.Vector Double 450 | f = 451 | (\(p, m) -> LA.vjoin [p, m]) 452 | . join bimap extract 453 | . hamEqs s 454 | . toPs 455 | ts' = VG.fromSized . VG.convert $ ts 456 | n = fromInteger $ natVal (Proxy @n) 457 | fromPs :: Phase n -> LA.Vector Double 458 | fromPs p = LA.vjoin . map extract $ [phsPositions p, phsMomenta p] 459 | toPs :: LA.Vector Double -> Phase n 460 | toPs v = case traverse create . LA.takesV [n, n] $ v of 461 | Just [pP, pM] -> Phs pP pM 462 | _ -> error "evolveHam: internal error" 463 | 464 | -- | A convenience wrapper for 'evolveHam'' that works on configuration 465 | -- space states instead of phase space states. 466 | -- 467 | -- Note that the simulation itself still runs in phase space; this function 468 | -- just abstracts over converting to and from phase space for the inputs 469 | -- and outputs. 470 | evolveHamC' :: 471 | forall m n. 472 | (KnownNat m, KnownNat n) => 473 | -- | system to simulate 474 | System m n -> 475 | -- | initial state, in configuration space 476 | Config n -> 477 | -- | desired solution times 478 | [Double] -> 479 | [Config n] 480 | evolveHamC' s c0 = fmap (fromPhase s) . evolveHam' s (toPhase s c0) 481 | 482 | -- | A convenience wrapper for 'evolveHam' that works on configuration 483 | -- space states instead of phase space states. 484 | -- 485 | -- Note that the simulation itself still runs in phase space; this function 486 | -- just abstracts over converting to and from phase space for the inputs 487 | -- and outputs. 488 | evolveHamC :: 489 | forall m n s. 490 | (KnownNat m, KnownNat n, KnownNat s, 2 <= s) => 491 | -- | system to simulate 492 | System m n -> 493 | -- | initial state, in configuration space 494 | Config n -> 495 | -- | desired solution times 496 | V.Vector s Double -> 497 | V.Vector s (Config n) 498 | evolveHamC s c0 = fmap (fromPhase s) . evolveHam s (toPhase s c0) 499 | 500 | -- | Step a system through configuration space over over a single timestep. 501 | -- 502 | -- Note that the simulation itself still runs in phase space; this function 503 | -- just abstracts over converting to and from phase space for the input 504 | -- and output. 505 | stepHamC :: 506 | forall m n. 507 | (KnownNat m, KnownNat n) => 508 | -- | timestep to step through 509 | Double -> 510 | -- | system to simulate 511 | System m n -> 512 | -- | initial state, in phase space 513 | Config n -> 514 | Config n 515 | stepHamC r s = fromPhase s . stepHam r s . toPhase s 516 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | --------------------------------------------------------------------------------