[
  {
    "path": ".envrc",
    "content": "watch_file *.cabal\nuse flake\n"
  },
  {
    "path": ".git-blame-ignore-revs",
    "content": "# fourmolu\n2f6ca862e31ddf33c86c8fb2660d7e0194b6fc2e\n"
  },
  {
    "path": ".github/workflows/flake-ci.yml",
    "content": "name: \"Flake CI\"\non:\n  pull_request:\n  push:\njobs:\n  checks:\n    runs-on: ubuntu-latest\n    steps:\n    - name: Free Disk Space\n      uses: insightsengineering/free-disk-space@v1.1.0\n    - uses: actions/checkout@v3\n    - uses: webfactory/ssh-agent@v0.9.0\n      with:\n        ssh-private-key: ${{ secrets.SSH_PRIVATE_KEY }}\n    - uses: cachix/install-nix-action@v22\n      with:\n        nix_path: nixpkgs=channel:nixos-unstable\n        github_access_token: ${{ secrets.GITHUB_TOKEN }}\n        extra_nix_config: |\n          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=\n          allow-import-from-derivation = true\n          auto-optimise-store = true\n          substituters = https://hydra.iohk.io https://cache.nixos.org/ https://cache.iog.io https://cache.zw3rk.com https://mstksg.cachix.org\n    - uses: cachix/cachix-action@v13\n      with:\n        name: mstksg\n        authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}'\n    - run: nix flake check --show-trace\n\n  cache:\n    runs-on: ubuntu-latest\n    steps:\n    - name: Free Disk Space\n      uses: insightsengineering/free-disk-space@v1.1.0\n    - uses: actions/checkout@v4.1.1\n    - uses: webfactory/ssh-agent@v0.9.0\n      with:\n        ssh-private-key: ${{ secrets.SSH_PRIVATE_KEY }}\n    - uses: cachix/install-nix-action@v22\n      with:\n        nix_path: nixpkgs=channel:nixos-unstable\n        github_access_token: ${{ secrets.GITHUB_TOKEN }}\n        extra_nix_config: |\n          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=\n          allow-import-from-derivation = true\n          auto-optimise-store = true\n          substituters = https://hydra.iohk.io https://cache.nixos.org/ https://cache.iog.io https://cache.zw3rk.com https://mstksg.cachix.org\n    - uses: cachix/cachix-action@v13\n      with:\n        name: mstksg\n        authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}'\n    - run: nix build --show-trace\n    - run: nix develop --show-trace\n\n  every-compiler:\n    runs-on: ubuntu-latest\n    steps:\n    - name: Free Disk Space\n      uses: insightsengineering/free-disk-space@v1.1.0\n    - uses: actions/checkout@v3\n    - uses: webfactory/ssh-agent@v0.9.0\n      with:\n        ssh-private-key: ${{ secrets.SSH_PRIVATE_KEY }}\n    - uses: cachix/install-nix-action@v22\n      with:\n        nix_path: nixpkgs=channel:nixos-unstable\n        github_access_token: ${{ secrets.GITHUB_TOKEN }}\n        extra_nix_config: |\n          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=\n          allow-import-from-derivation = true\n          auto-optimise-store = true\n          substituters = https://hydra.iohk.io https://cache.nixos.org/ https://cache.iog.io https://cache.zw3rk.com https://mstksg.cachix.org\n    - uses: cachix/cachix-action@v13\n      with:\n        name: mstksg\n        authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}'\n    - run: nix build .#everyCompiler\n\n"
  },
  {
    "path": ".gitignore",
    "content": "/.stack-work\n/src/highlight.js\n/src/style.css\n/dist-newstyle\n/.direnv\n"
  },
  {
    "path": ".travis.yml",
    "content": "script:\n- |\n  set -ex\n  case \"$BUILD\" in\n    stack)\n      stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps\n      ;;\n    cabal)\n      cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES\n\n      ORIGDIR=$(pwd)\n      for dir in $PACKAGES\n      do\n        cd $dir\n        cabal check || [ \"$CABALVER\" == \"1.16\" ]\n        cabal sdist\n        PKGVER=$(cabal info . | awk '{print $2;exit}')\n        SRC_TGZ=$PKGVER.tar.gz\n        cd dist\n        tar zxfv \"$SRC_TGZ\"\n        cd \"$PKGVER\"\n        cabal configure --enable-tests --ghc-options -O0\n        cabal build\n        if [ \"$CABALVER\" = \"1.16\" ] || [ \"$CABALVER\" = \"1.18\" ]; then\n          cabal test\n        else\n          cabal test --show-details=streaming --log=/dev/stdout\n        fi\n        cd $ORIGDIR\n      done\n      ;;\n  esac\n  set +ex\ninstall:\n- echo \"$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo\n  '?')]\"\n- if [ -f configure.ac ]; then autoreconf -i; fi\n- |\n  set -ex\n  case \"$BUILD\" in\n    stack)\n      # Add in extra-deps for older snapshots, as necessary\n      #\n      # This is disabled by default, as relying on the solver like this can\n      # make builds unreliable. Instead, if you have this situation, it's\n      # recommended that you maintain multiple stack-lts-X.yaml files.\n\n      #stack --no-terminal --install-ghc $ARGS test --bench --dry-run || ( \\\n      #  stack --no-terminal $ARGS build cabal-install && \\\n      #  stack --no-terminal $ARGS solver --update-config)\n\n      # Build the dependencies\n      stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies\n      ;;\n    cabal)\n      cabal --version\n      travis_retry cabal update\n\n      # Get the list of packages from the stack.yaml file. Note that\n      # this will also implicitly run hpack as necessary to generate\n      # the .cabal files needed by cabal-install.\n      PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@')\n\n      cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES\n      ;;\n  esac\n  set +ex\njobs:\n  include:\n  - env: BUILD=cabal GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7\n    addons:\n      apt:\n        sources:\n        - hvr-ghc\n        packages:\n        - cabal-install-1.24\n        - ghc-8.0.2\n        - happy-1.19.5\n        - alex-3.1.7\n    compiler: ': #GHC 8.0.2'\n  - env: BUILD=cabal GHCVER=8.2.2 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7\n    addons:\n      apt:\n        sources:\n        - hvr-ghc\n        packages:\n        - cabal-install-2.0\n        - ghc-8.2.2\n        - happy-1.19.5\n        - alex-3.1.7\n    compiler: ': #GHC 8.2.2'\n  - env: BUILD=cabal GHCVER=8.4.4 CABALVER=2.2 HAPPYVER=1.19.5 ALEXVER=3.1.7\n    addons:\n      apt:\n        sources:\n        - hvr-ghc\n        packages:\n        - cabal-install-2.2\n        - ghc-8.4.4\n        - happy-1.19.5\n        - alex-3.1.7\n    compiler: ': #GHC 8.4.4'\n  - env: BUILD=cabal GHCVER=8.6.5 CABALVER=2.4 HAPPYVER=1.19.5 ALEXVER=3.1.7\n    addons:\n      apt:\n        sources:\n        - hvr-ghc\n        packages:\n        - cabal-install-2.4\n        - ghc-8.6.5\n        - happy-1.19.5\n        - alex-3.1.7\n    compiler: ': #GHC 8.6.5'\n  - env: BUILD=cabal GHCVER=head  CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7\n    addons:\n      apt:\n        sources:\n        - hvr-ghc\n        packages:\n        - cabal-install-head\n        - ghc-head\n        - happy-1.19.5\n        - alex-3.1.7\n    compiler: ': #GHC HEAD'\n  - env: BUILD=stack ARGS=\"\"\n    addons:\n      apt:\n        packages:\n        - libgmp-dev\n    compiler: ': #stack default'\n  - env: BUILD=stack ARGS=\"--resolver lts-9\"\n    addons:\n      apt:\n        packages:\n        - libgmp-dev\n    compiler: ': #stack 8.0.2'\n  - env: BUILD=stack ARGS=\"--resolver lts-11\"\n    addons:\n      apt:\n        packages:\n        - libgmp-dev\n    compiler: ': #stack 8.2.2'\n  - env: BUILD=stack ARGS=\"--resolver lts-12\"\n    addons:\n      apt:\n        packages:\n        - libgmp-dev\n    compiler: ': #stack 8.4.4'\n  - env: BUILD=stack ARGS=\"--resolver lts-14\"\n    addons:\n      apt:\n        packages:\n        - libgmp-dev\n    compiler: ': #stack 8.6.5'\n  - env: BUILD=stack ARGS=\"--resolver nightly\"\n    addons:\n      apt:\n        packages:\n        - libgmp-dev\n    compiler: ': #stack nightly'\n  - env: BUILD=stack ARGS=\"\"\n    os: osx\n    compiler: ': #stack default osx'\n  - env: BUILD=stack ARGS=\"--resolver lts-9\"\n    os: osx\n    compiler: ': #stack 8.0.2 osx'\n  - env: BUILD=stack ARGS=\"--resolver lts-11\"\n    os: osx\n    compiler: ': #stack 8.2.2 osx'\n  - env: BUILD=stack ARGS=\"--resolver lts-12\"\n    os: osx\n    compiler: ': #stack 8.4.4 osx'\n  - env: BUILD=stack ARGS=\"--resolver lts-14\"\n    os: osx\n    compiler: ': #stack 8.6.5 osx'\n  - env: BUILD=stack ARGS=\"--resolver nightly\"\n    os: osx\n    compiler: ': #stack nightly osx'\n  allow_failures:\n  - env: BUILD=cabal GHCVER=head  CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7\n  - env: BUILD=stack ARGS=\"--resolver nightly\"\nos: linux\ncache:\n  directories:\n  - $HOME/.ghc\n  - $HOME/.cabal\n  - $HOME/.stack\n  - $TRAVIS_BUILD_DIR/.stack-work\nbefore_install:\n- unset CC\n- CABALARGS=\"\"\n- if [ \"x$GHCVER\" = \"xhead\" ]; then CABALARGS=--allow-newer; fi\n- 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\n- mkdir -p ~/.local/bin\n- |\n  if [ `uname` = \"Darwin\" ]\n  then\n    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\n  else\n    travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'\n  fi\n\n  # Use the more reliable S3 mirror of Hackage\n  mkdir -p $HOME/.cabal\n  echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config\n  echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config\n- |\n  if [ `uname` = \"Darwin\" ]\n  then\n    brew update\n    brew install gsl\n  fi\nlanguage: generic\n\n"
  },
  {
    "path": "CHANGELOG.md",
    "content": "Changelog\n=========\n\nVersion 0.1.0.4\n---------------\n\n*Unreleased*\n\n<https://github.com/mstksg/hamilton/releases/tag/v0.1.0.4>\n\n*Internal*\n\n*   Rewrote more internal functions using *hmatrix-vector-sized*, which should\n    yield performance benefits.\n\nVersion 0.1.0.3\n---------------\n\n*Mar 20, 2018*\n\n<https://github.com/mstksg/hamilton/releases/tag/v0.1.0.3>\n\n*   Compatibility with *base-4.11.0.0* and GHC 8.4\n*   Compatibility with *vector-sized-1.0.0.0*\n\n*Internal*\n\n*   Internal conversion functions refactored using *hmatrix-vector-sized*,\n    *hessianF*.\n\nVersion 0.1.0.2\n---------------\n\n*Jan 21, 2018*\n\n<https://github.com/mstksg/hamilton/releases/tag/v0.1.0.2>\n\n*   Compatibility with *typelits-witneses-0.3.0.0*\n\nVersion 0.1.0.1\n---------------\n\n*Aug 17, 2017*\n\n<https://github.com/mstksg/hamilton/releases/tag/v0.1.0.1>\n\n*   Removed `Num` instance in the examples file, to account for\n    *vector-sized*'s new `Num` instances.\n*   COMPLETE pragmas for examples file.\n\nVersion 0.1.0.0\n---------------\n\n*Nov 27, 2016*\n\n<https://github.com/mstksg/hamilton/releases/tag/v0.1.0.0>\n\n*   Initial release.\n"
  },
  {
    "path": "LICENSE",
    "content": "Copyright Justin Le (c) 2016\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n\n    * Redistributions of source code must retain the above copyright\n      notice, this list of conditions and the following disclaimer.\n\n    * Redistributions in binary form must reproduce the above\n      copyright notice, this list of conditions and the following\n      disclaimer in the documentation and/or other materials provided\n      with the distribution.\n\n    * Neither the name of Justin Le nor the names of other\n      contributors may be used to endorse or promote products derived\n      from this software without specific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS\n\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT\nLIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR\nA PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT\nOWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,\nSPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT\nLIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,\nDATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY\nTHEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\n(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\nOF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE."
  },
  {
    "path": "README.md",
    "content": "Hamilton\n========\n\n[![Build Status](https://travis-ci.org/mstksg/hamilton.svg?branch=master)](https://travis-ci.org/mstksg/hamilton)\n\nSimulate physics on arbitrary coordinate systems using [automatic\ndifferentiation][ad] and [Hamiltonian mechanics][].  State only an arbitrary\nparameterization of your system and a potential energy function!\n\n[ad]: http://hackage.haskell.org/package/ad\n[Hamiltonian mechanics]: https://en.wikipedia.org/wiki/Hamiltonian_mechanics\n\nFor example, a simulating a [double pendulum system][dps] by simulating the\nprogression of the angles of each bob:\n\n[dps]: https://en.wikipedia.org/wiki/Double_pendulum\n\n[![My name is William Rowan Hamilton](http://i.imgur.com/Vaaa2EC.gif)][gifv]\n\n[gifv]: http://i.imgur.com/Vaaa2EC.gifv\n\nYou only need:\n\n1.  Your generalized coordinates (in this case, `θ1` and `θ2`), and equations\n    to convert them to cartesian coordinates of your objects:\n\n    ~~~haskell\n    x1 = sin θ1\n    y1 = -cos θ1\n    x2 = sin θ1 + sin θ2 / 2      -- second pendulum is half-length\n    y2 = -cos θ1 - cos θ2 / 2\n    ~~~\n\n2.  The masses/inertias of each of those cartesian coordinates (`m1` for `x1`\n    and `y1`, `m2` for `x2` and `y2`)\n\n3.  A potential energy function for your objects:\n\n    ~~~haskell\n    U = (m1 y1 + m2 y2) * g\n    ~~~\n\nAnd that's it! Hamiltonian mechanics steps your generalized coordinates (`θ1`\nand `θ2`) through time, without needing to do any simulation involving\n`x1`/`y1`/`x2`/`y2`!  And you don't need to worry about tension or any other\nstuff like that.  All you need is a description of your coordinate system\nitself, and the potential energy!\n\n~~~haskell\ndoublePendulum :: System 4 2\ndoublePendulum =\n    mkSystem' (vec4 m1 m1 m2 m2)            -- masses\n              (\\(V2 θ1 θ2)     -> V4 (sin θ1)            (-cos θ1)\n                                     (sin θ1 + sin θ2/2) (-cos θ1 - cos θ2/2)\n              )                             -- coordinates\n              (\\(V4 _ y1 _ y2) -> (m1 * y1 + m2 * y2) * g)\n                                            -- potential\n~~~\n\nThanks to [~~Alexander~~ William Rowan Hamilton][WRH], we can express our\nsystem parameterized by arbitrary coordinates and get back equations of motions\nas first-order differential equations.  This library solves those first-order\ndifferential equations for you using automatic differentiation and some matrix\nmanipulation.\n\n[WRH]: https://www.youtube.com/watch?v=SZXHoWwBcDc\n\nSee a [blog post][] I wrote on this, and also the [hackage documentation][] and the\n[example runner user guide][user guide] (and its [source][example runner]).\n\n[blog post]: https://blog.jle.im/entry/introducing-the-hamilton-library.html\n[hackage documentation]: http://hackage.haskell.org/package/hamilton\n[example runner]: https://github.com/mstksg/hamilton/blob/master/app/Examples.hs\n[user guide]: https://github.com/mstksg/hamilton#example-app-runner\n\n### Full Example\n\nLet's turn our double pendulum (with the second pendulum half as long) into an\nactual running program.  Let's say that `g = 5`, `m1 = 1`, and `m2 = 2`.\n\nFirst, the system:\n\n~~~haskell\nimport           Numeric.LinearAlgebra.Static\nimport qualified Data.Vector.Sized as V\n\n\ndoublePendulum :: System 4 2\ndoublePendulum = mkSystem' masses coordinates potential\n  where\n    masses :: R 4\n    masses = vec4 1 1 2 2\n    coordinates\n        :: Floating a\n        => V.Vector 2 a\n        -> V.Vector 4 a\n    coordinates (V2 θ1 θ2) = V4 (sin θ1)            (-cos θ1)\n                                (sin θ1 + sin θ2/2) (-cos θ1 - cos θ2/2)\n    potential\n        :: Num a\n        => V.Vector 4 a\n        -> a\n    potential (V4 _ y1 _ y2) = (y1 + 2 * y2) * 5\n\n\n-- some helper patterns to pattern match on sized vectors\npattern V2 :: a -> a -> V.Vector 2 a\npattern V2 x y <- (V.toList->[x,y])\n  where\n    V2 x y = fromJust (V.fromList [x,y])\n\npattern V4 :: a -> a -> a -> a -> V.Vector 4 a\npattern V4 x y z a <- (V.toList->[x,y,z,a])\n  where\n    V4 x y z a = fromJust (V.fromList [x,y,z,a])\n~~~\n\nNeat!  Easy, right?\n\nOkay, now let's run it.  Let's pick a starting configuration (state of the\nsystem) of `θ1` and `θ2`:\n\n~~~haskell\nconfig0 :: Config 2\nconfig0 = Cfg (vec2 1 0  )  -- initial positions\n              (vec2 0 0.5)  -- initial velocities\n~~~\n\nConfigurations are nice, but Hamiltonian dynamics is all about motion through\nphase space, so let's convert this configuration-space representation of the\nstate into a phase-space representation of the state:\n\n~~~haskell\nphase0 :: Phase 2\nphase0 = toPhase doublePendulum config0\n~~~\n\nAnd now we can ask for the state of our system at any amount of points in time!\n\n~~~haskell\nghci> evolveHam doublePendulum phase0 [0,0.1 .. 1]\n-- result: state of the system at times 0, 0.1, 0.2, 0.3 ... etc.\n~~~\n\nOr, if you want to run the system step-by-step:\n\n\n~~~haskell\nevolution :: [Phase 2]\nevolution = iterate (stepHam 0.1 doublePendulum) phase0\n~~~\n\nAnd you can get the position of the coordinates as:\n\n~~~haskell\npositions :: [R 2]\npositions = phsPositions <$> evolution\n~~~\n\nAnd the position in the underlying cartesian space as:\n\n~~~haskell\npositions' :: [R 4]\npositions' = underlyingPos doublePendulum <$> positions\n~~~\n\nExample App runner\n------------------\n\n*([Source][example runner])*\n\nInstallation:\n\n~~~bash\n$ git clone https://github.com/mstksg/hamilton\n$ cd hamilton\n$ stack install\n~~~\n\nUsage:\n\n~~~bash\n$ hamilton-examples [EXAMPLE] (options)\n$ hamilton-examples --help\n$ hamilton-examples [EXAMPLE] --help\n~~~\n\nThe example runner is a command line application that plots the progression of\nseveral example system through time.\n\n\n| Example      | Description                                                | Coordinates                                                         | Options                                                       |\n|--------------|------------------------------------------------------------|---------------------------------------------------------------------|---------------------------------------------------------------|\n| `doublepend` | Double pendulum, described above                           | `θ1`, `θ2` (angles of bobs)                                         | Masses of each bob                                            |\n| `pend`       | Single pendulum                                            | `θ` (angle of bob)                                                  | Initial angle and velocity of bob                             |\n| `room`       | Object bounding around walled room                         | `x`, `y`                                                            | Initial launch angle of object                                |\n| `twobody`    | Two gravitationally attracted bodies, described below      | `r`, `θ` (distance between bodies, angle of rotation)               | Masses of bodies and initial angular veocity                  |\n| `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 |\n| `bezier`     | Bead sliding at constant velocity along bezier curve       | `t` (Bezier time parameter)                                         | Control points for arbitrary bezier curve                     |\n\nCall with `--help` (or `[EXAMPLE] --help`) for more information.\n\nMore examples\n-------------\n\n### Two-body system under gravity\n\n[![The two-body solution](http://i.imgur.com/TDEHTcb.gif)][gifv2]\n\n[gifv2]: http://i.imgur.com/TDEHTcb.gifv\n\n1.  The generalized coordinates are just:\n\n    *   `r`, the distance between the two bodies\n    *   `θ`, the current angle of rotation\n\n    ~~~haskell\n    x1 =  m2/(m1+m2) * r * sin θ        -- assuming (0,0) is the center of mass\n    y1 =  m2/(m1+m2) * r * cos θ\n    x2 = -m1/(m1+m2) * r * sin θ\n    y2 = -m1/(m1+m2) * r * cos θ\n    ~~~\n\n2.  The masses/inertias are again `m1` for `x1` and `y1`, and `m2` for `x2` and\n    `y2`\n\n3.  The potential energy function is the classic gravitational potential:\n\n    ~~~haskell\n    U = - m1 * m2 / r\n    ~~~\n\nAnd...that's all you need!\n\nHere is the actual code for the two-body system, assuming `m1` is `100` and\n`m2` is `1`:\n\n~~~haskell\ntwoBody :: System 4 2\ntwoBody = mkSystem masses coordinates potential\n  where\n    masses :: R 4\n    masses = vec4 100 100 1 1\n    coordinates\n        :: Floating a\n        => V.Vector 2 a\n        -> V.Vector 4 a\n    coordinates (V2 r θ) = V4 (r1 * cos θ) (r1 * sin θ)\n                              (r2 * cos θ) (r2 * sin θ)\n      where\n        r1 =   r *   1 / 101\n        r2 = - r * 100 / 101\n    potential\n        :: Num a\n        => V.Vector 4 a\n        -> a\n    potential (V2 r _) = - 100 / r\n~~~\n\nPotential improvements\n----------------------\n\n*   **Time-dependent systems**:  Shouldn't be an problem in theory/math; just\n    add a time parameter before all of the functions.  This opens a lot of\n    doors, like deriving inertial forces for free (like the famous Coriolis\n    force and centrifugal force).\n\n    The only thing is that it makes the API pretty inconvenient, because it'd\n    require all of the functions to also take a time parameter.  Of course, the\n    easy way out/ugly solution would be to just offer two versions of the same\n    function (one for time-independent systems and one for time-dependent\n    systems.  But this is un-ideal.\n\n*   Velocity-dependent potentials:  Would give us the ability to model systems\n    with velocity-dependent Lagrangians like a charged particle in an\n    electromagnetic field, and also dissipative systems, like systems with\n    friction (dependent on `signum v`) and linear & quadratic wind resistance.\n\n    This issue is much harder, theoretically.  It involves inverting arbitrary\n    functions `forall a. RealFloat a => V.Vector n a -> V.Vector m a`.  It\n    might be possible with the help of some\n    [bidirectionalization techniques][bff-pearl], but I can't get the [bff][]\n    package to compile, and I'm not sure how to get [bff-mono][] to work with\n    numeric functions.\n\n    If anyone is familiar with bidirectionalization techniques and is willing\n    to help out, please send me a message or open an issue! :)\n\n[bff-pearl]: https://pdfs.semanticscholar.org/5f0d/ef02dbd96e102be9104d2ceb728d2a2a5beb.pdf\n[bff]: http://hackage.haskell.org/package/bff\n[bff-mono]: http://hackage.haskell.org/package/bff-mono\n\n"
  },
  {
    "path": "Setup.hs",
    "content": "import Distribution.Simple\n\nmain = defaultMain\n"
  },
  {
    "path": "app/Examples.hs",
    "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE DataKinds #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE FlexibleInstances #-}\n{-# LANGUAGE GADTs #-}\n{-# LANGUAGE LambdaCase #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE PatternSynonyms #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE ScopedTypeVariables #-}\n{-# LANGUAGE StandaloneDeriving #-}\n{-# LANGUAGE TypeOperators #-}\n{-# LANGUAGE ViewPatterns #-}\n{-# OPTIONS_GHC -fno-warn-orphans #-}\n{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}\n\n-- \\| Hamilton example suite\n--\n-- See: https://github.com/mstksg/hamilton#example-app-runner\n--\n-- Or just run with:\n--\n-- > $ hamilton-examples --help\n-- > $ hamilton-examples [EXAMPLE] --help\n\nimport Control.Concurrent\nimport Control.Monad\nimport Data.Bifunctor\nimport Data.Finite\nimport Data.Foldable\nimport Data.IORef\nimport Data.List\nimport qualified Data.List.NonEmpty as NE\nimport qualified Data.Map.Strict as M\nimport qualified Data.Vector as VV\nimport qualified Data.Vector.Sized as V\nimport qualified Data.Vector.Storable.Sized as VS\nimport GHC.TypeLits\nimport Graphics.Vty hiding ((<|>))\nimport Graphics.Vty.CrossPlatform (mkVty)\nimport Numeric.Hamilton\nimport Numeric.LinearAlgebra.Static hiding (dim, (<>))\nimport Numeric.LinearAlgebra.Static.Vector\nimport Options.Applicative\nimport qualified Prettyprinter as PP\nimport System.Exit\nimport Text.Printf\nimport Text.Read\n\ndata SysExample where\n  SE ::\n    (KnownNat m, KnownNat n) =>\n    { seName :: String\n    , seCoords :: V.Vector n String\n    , seSystem :: System m n\n    , seDraw :: R m -> [V2 Double]\n    , seInit :: Phase n\n    } ->\n    SysExample\n\npendulum :: Double -> Double -> SysExample\npendulum θ0 ω0 = SE \"Single pendulum\" (V1 \"θ\") s f (toPhase s c0)\n  where\n    s :: System 2 1\n    s =\n      mkSystem'\n        (vec2 1 1) -- masses\n        (\\(V1 θ) -> V2 (sin θ) (0.5 - cos θ)) -- coordinates\n        (\\(V2 _ y) -> y) -- potential\n    f :: R 2 -> [V2 Double]\n    f xs = [grVec xs]\n    c0 :: Config 1\n    c0 = Cfg (konst θ0 :: R 1) (konst ω0 :: R 1)\n\ndoublePendulum :: Double -> Double -> SysExample\ndoublePendulum m1 m2 = SE \"Double pendulum\" (V2 \"θ1\" \"θ2\") s f (toPhase s c0)\n  where\n    s :: System 4 2\n    s =\n      mkSystem'\n        (vec4 m1 m1 m2 m2) -- masses\n        ( \\(V2 θ1 θ2) ->\n            V4\n              (sin θ1)\n              (1 - cos θ1)\n              (sin θ1 + sin θ2 / 2)\n              (1 - cos θ1 - cos θ2 / 2)\n        ) -- coordinates\n        (\\(V4 _ y1 _ y2) -> 5 * (realToFrac m1 * y1 + realToFrac m2 * y2))\n    -- potential\n    f :: R 4 -> [V2 Double]\n    f (split -> (xs, ys)) = grVec <$> [xs, ys]\n    c0 :: Config 2\n    c0 = Cfg (vec2 (pi / 2) 0) (vec2 0 0)\n\nroom :: Double -> SysExample\nroom θ = SE \"Room\" (V2 \"x\" \"y\") s f (toPhase s c0)\n  where\n    s :: System 2 2\n    s =\n      mkSystem\n        (vec2 1 1) -- masses\n        id -- coordinates\n        ( \\(V2 x y) ->\n            sum\n              [ 2 * y -- gravity\n              , 1 - logistic (-1) 10 0.1 y -- bottom wall\n              , logistic 1 10 0.1 y -- top wall\n              , 1 - logistic (-2) 10 0.1 x -- left wall\n              , logistic 2 10 0.1 x -- right wall\n              ]\n        ) -- potential\n    f :: R 2 -> [V2 Double]\n    f xs = [grVec xs]\n    c0 :: Config 2\n    c0 = Cfg (vec2 (-1) 0.25) (vec2 (cos θ) (sin θ))\n\ntwoBody :: Double -> Double -> Double -> SysExample\ntwoBody m1 m2 ω0 = SE \"Two-Body\" (V2 \"r\" \"θ\") s f (toPhase s c0)\n  where\n    mT :: Double\n    mT = m1 + m2\n    s :: System 4 2\n    s =\n      mkSystem\n        (vec4 m1 m1 m2 m2) -- masses\n        -- positions are calculated assuming (0,0) is the center\n        -- of mass\n        ( \\(V2 r θ) ->\n            let r1 = r * realToFrac (-(m2 / mT))\n                r2 = r * realToFrac (m1 / mT)\n             in V4\n                  (r1 * cos θ)\n                  (r1 * sin θ)\n                  (r2 * cos θ)\n                  (r2 * sin θ)\n        ) -- coordinates\n        (\\(V2 r _) -> -(realToFrac (m1 * m2) / r)) -- potential\n    f :: R 4 -> [V2 Double]\n    f (split -> (xs, ys)) = grVec <$> [xs, ys]\n    c0 :: Config 2\n    c0 = Cfg (vec2 2 0) (vec2 0 ω0)\n\nspring ::\n  Double -> Double -> Double -> Double -> SysExample\nspring mB mW k x0 = SE \"Spring hanging from block\" (V3 \"r\" \"x\" \"θ\") s f (toPhase s c0)\n  where\n    s :: System 3 3\n    s =\n      mkSystem\n        (vec3 mB mW mW) -- masses\n        (\\(V3 r x θ) -> V3 r (r + (1 + x) * sin θ) ((1 + x) * (-cos θ))) -- coordinates\n        ( \\(V3 r x θ) ->\n            realToFrac k * x ** 2 / 2 -- spring\n              + (1 - logistic (-1.5) 25 0.1 r) -- left rail wall\n              + logistic 1.5 25 0.1 r -- right rail wall\n              + realToFrac mB * ((1 + x) * (-cos θ)) -- gravity\n        )\n    f :: R 3 -> [V2 Double]\n    f (headTail -> (b, w)) = [V2 b 1, V2 0 1 + grVec w]\n    c0 :: Config 3\n    c0 = Cfg (vec3 0 x0 0) (vec3 1 0 (-0.5))\n\nbezier ::\n  forall n.\n  KnownNat (1 + n) =>\n  V.Vector (1 + n) (V2 Double) ->\n  SysExample\nbezier ps = SE \"Bezier\" (V1 \"t\") s f (toPhase s c0)\n  where\n    s :: System 2 1\n    s =\n      mkSystem\n        (vec2 1 1) -- masses\n        (\\(V1 t) -> bezierCurve (fmap realToFrac <$> ps) t) -- coordinates\n        ( \\(V1 t) ->\n            (1 - logistic 0 5 0.05 t) -- left wall\n              + logistic 1 5 0.05 t -- right wall\n        )\n    f :: R 2 -> [V2 Double]\n    f xs = [grVec xs]\n    c0 :: Config 1\n    c0 = Cfg (0.5 :: R 1) (0.25 :: R 1)\n\nnewtype ExampleOpts = EO {eoChoice :: SysExampleChoice}\n\ndata SysExampleChoice\n  = SECDoublePend Double Double\n  | SECPend Double Double\n  | SECRoom Double\n  | SECTwoBody Double Double Double\n  | SECSpring Double Double Double Double\n  | SECBezier (NE.NonEmpty (V2 Double))\n\nparseEO :: Parser ExampleOpts\nparseEO = EO <$> (parseSEC <|> pure (SECDoublePend 1 1))\n\nparseSEC :: Parser SysExampleChoice\nparseSEC =\n  subparser . mconcat $\n    [ command \"doublepend\" $\n        info\n          (helper <*> parseDoublePend)\n          (progDesc \"Double pendulum (default)\")\n    , command \"pend\" $\n        info\n          (helper <*> parsePend)\n          (progDesc \"Single pendulum\")\n    , command \"room\" $\n        info\n          (helper <*> parseRoom)\n          (progDesc \"Ball in room, bouncing off of walls\")\n    , command \"twobody\" $\n        info\n          (helper <*> parseTwoBody)\n          (progDesc \"Two-body graviational simulation.  Note that bodies will only orbit if H < 0.\")\n    , command \"spring\" $\n        info\n          (helper <*> parseSpring)\n          ( progDesc\n              \"A spring hanging from a block on a rail, holding up a mass.  Block is constrained to bounce between -1.5 and 1.5.\"\n          )\n    , command \"bezier\" $\n        info\n          (helper <*> parseBezier)\n          (progDesc \"Particle moving along a parameterized bezier curve\")\n    , metavar \"EXAMPLE\"\n    ]\n  where\n    parsePend =\n      SECPend\n        <$> option\n          auto\n          ( long \"angle\"\n              <> short 'a'\n              <> metavar \"ANGLE\"\n              <> help \"Intitial rightward angle (in degrees) of bob\"\n              <> value 0\n              <> showDefault\n          )\n        <*> option\n          auto\n          ( long \"vel\"\n              <> short 'v'\n              <> metavar \"VELOCITY\"\n              <> help \"Initial rightward angular velocity of bob\"\n              <> value 1\n              <> showDefault\n          )\n    parseDoublePend =\n      SECDoublePend\n        <$> option\n          auto\n          ( long \"m1\"\n              <> metavar \"MASS\"\n              <> help \"Mass of first bob\"\n              <> value 1\n              <> showDefault\n          )\n        <*> option\n          auto\n          ( long \"m2\"\n              <> metavar \"MASS\"\n              <> help \"Mass of second bob\"\n              <> value 1\n              <> showDefault\n          )\n    parseRoom =\n      SECRoom\n        <$> option\n          auto\n          ( long \"angle\"\n              <> short 'a'\n              <> metavar \"ANGLE\"\n              <> help \"Initial upward launch angle (in degrees) of object\"\n              <> value 45\n              <> showDefault\n          )\n    parseTwoBody =\n      SECTwoBody\n        <$> option\n          auto\n          ( long \"m1\"\n              <> metavar \"MASS\"\n              <> help \"Mass of first body\"\n              <> value 5\n              <> showDefault\n          )\n        <*> option\n          auto\n          ( long \"m2\"\n              <> metavar \"MASS\"\n              <> help \"Mass of second body\"\n              <> value 0.5\n              <> showDefault\n          )\n        <*> option\n          auto\n          ( long \"vel\"\n              <> short 'v'\n              <> metavar \"VELOCITY\"\n              <> help \"Initial angular velocity of system\"\n              <> value 0.5\n              <> showDefault\n          )\n    parseSpring =\n      SECSpring\n        <$> option\n          auto\n          ( long \"block\"\n              <> short 'b'\n              <> metavar \"MASS\"\n              <> help \"Mass of block on rail\"\n              <> value 2\n              <> showDefault\n          )\n        <*> option\n          auto\n          ( long \"weight\"\n              <> short 'w'\n              <> metavar \"MASS\"\n              <> help \"Mass of weight hanging from spring\"\n              <> value 1\n              <> showDefault\n          )\n        <*> option\n          auto\n          ( short 'k'\n              <> metavar \"NUM\"\n              <> help \"Spring constant / stiffness of spring\"\n              <> value 10\n              <> showDefault\n          )\n        <*> option\n          auto\n          ( short 'x'\n              <> metavar \"DIST\"\n              <> help \"Initial displacement of spring\"\n              <> value 0.1\n              <> showDefault\n          )\n    parseBezier =\n      SECBezier\n        <$> option\n          f\n          ( long \"points\"\n              <> short 'p'\n              <> metavar \"POINTS\"\n              <> help \"List of control points (at least one), as tuples\"\n              <> value (V2 (-1) (-1) NE.:| [V2 (-2) 1, V2 0 1, V2 1 (-1), V2 2 1])\n              <> showDefaultWith (show . map (\\(V2 x y) -> (x, y)) . toList)\n          )\n      where\n        f = eitherReader $ \\s -> do\n          ps <-\n            maybe (Left \"Bad parse\") Right $\n              readMaybe s\n          maybe (Left \"At least one control point required\") Right $\n            NE.nonEmpty (uncurry V2 <$> ps)\n\ndata SimOpts = SO\n  { soZoom :: Double\n  , soRate :: Double\n  , soHist :: Int\n  }\n  deriving (Show)\n\ndata SimEvt\n  = SEQuit\n  | SEZoom Double\n  | SERate Double\n  | SEHist Int\n\nmain :: IO ()\nmain = do\n  EO{..} <-\n    execParser $\n      info\n        (helper <*> parseEO)\n        ( fullDesc\n            <> header \"hamilton-examples - hamilton library example suite\"\n            <> progDescDoc (Just descr)\n        )\n\n  vty <- mkVty defaultConfig\n\n  opts <- newIORef $ SO 0.5 1 25\n\n  t <- forkIO . loop vty opts $ case eoChoice of\n    SECDoublePend m1 m2 -> doublePendulum m1 m2\n    SECPend d0 ω0 -> pendulum (d0 / 180 * pi) ω0\n    SECRoom d0 -> room (d0 / 180 * pi)\n    SECTwoBody m1 m2 ω0 -> twoBody m1 m2 ω0\n    SECSpring mB mW k x0 -> spring mB mW k x0\n    SECBezier (p NE.:| ps) ->\n      V.withSized\n        (VV.fromList ps)\n        (bezier . V.cons p)\n\n  forever $ do\n    e <- nextEvent vty\n    forM_ (processEvt e) $ \\case\n      SEQuit -> do\n        killThread t\n        shutdown vty\n        exitSuccess\n      SEZoom s ->\n        modifyIORef opts $ \\o -> o{soZoom = soZoom o * s}\n      SERate r ->\n        modifyIORef opts $ \\o -> o{soRate = soRate o * r}\n      SEHist h ->\n        modifyIORef opts $ \\o -> o{soHist = soHist o + h}\n  where\n    fps :: Double\n    fps = 12\n    screenRatio :: Double\n    screenRatio = 2.1\n    ptAttrs :: [(Char, Color)]\n    ptAttrs = ptChars `zip` ptColors\n      where\n        ptColors = cycle [white, yellow, blue, red, green]\n        ptChars = cycle \"o*+~\"\n    loop :: Vty -> IORef SimOpts -> SysExample -> IO ()\n    loop vty oRef SE{..} = go M.empty seInit\n      where\n        qVec = intercalate \",\" . V.toList $ seCoords\n        go hists p = do\n          SO{..} <- readIORef oRef\n          let p' = stepHam (soRate / fps) seSystem p -- progress the simulation\n              xb = (-recip soZoom, recip soZoom)\n              infobox =\n                vertCat . map (string defAttr) $\n                  [ printf \"[ %s ]\" seName\n                  , printf \" <%s>   : <%s>\" qVec\n                      . intercalate \", \"\n                      . map (printf \"%.4f\")\n                      . VS.toList\n                      . rVec\n                      . phsPositions\n                      $ p\n                  , printf \"d<%s>/dt: <%s>\" qVec\n                      . intercalate \", \"\n                      . map (printf \"%.4f\")\n                      . VS.toList\n                      . rVec\n                      . velocities seSystem\n                      $ p\n                  , printf \"KE: %.4f\" . keP seSystem $ p\n                  , printf \"PE: %.4f\" . pe seSystem . phsPositions $ p\n                  , printf \"H : %.4f\" . hamiltonian seSystem $ p\n                  , \" \"\n                  , printf \"rate: x%.2f <>\" soRate\n                  , printf \"hist: % 5d []\" soHist\n                  , printf \"zoom: x%.2f -+\" soZoom\n                  ]\n              pts =\n                (`zip` ptAttrs) . seDraw . underlyingPos seSystem . phsPositions $\n                  p\n              hists' = foldl' (\\h (r, a) -> M.insertWith (addHist soHist) a [r] h) hists pts\n          dr <- displayBounds $ outputIface vty\n          update vty . picForLayers . (infobox :) . plot dr (PX xb (RR 0.5 screenRatio)) $\n            ((second . second) (defAttr `withForeColor`) <$> pts)\n              ++ ( map (\\((_, c), r) -> (r, ('.', defAttr `withForeColor` c)))\n                    . concatMap sequence\n                    . M.toList\n                    $ hists'\n                 )\n          threadDelay (round (1000000 / fps))\n          go hists' p'\n    addHist hl new old = take hl (new ++ old)\n    descr :: PP.Doc x\n    descr =\n      PP.vcat\n        [ \"Run examples from the hamilton library example suite.\"\n        , \"Use with [EXAMPLE] --help for more per-example options.\"\n        , \"\"\n        , \"To adjust rate/history/zoom, use keys <>/[]/-+, respectively.\"\n        , \"\"\n        , \"See: https://github.com/mstksg/hamilton#example-app-runner\"\n        ]\n\nprocessEvt ::\n  Event -> Maybe SimEvt\nprocessEvt = \\case\n  EvKey KEsc [] -> Just SEQuit\n  EvKey (KChar 'c') [MCtrl] -> Just SEQuit\n  EvKey (KChar 'q') [] -> Just SEQuit\n  EvKey (KChar '+') [] -> Just $ SEZoom (sqrt 2)\n  EvKey (KChar '-') [] -> Just $ SEZoom (sqrt 0.5)\n  EvKey (KChar '>') [] -> Just $ SERate (sqrt 2)\n  EvKey (KChar '<') [] -> Just $ SERate (sqrt (1 / 2))\n  EvKey (KChar ']') [] -> Just $ SEHist 5\n  EvKey (KChar '[') [] -> Just $ SEHist (-5)\n  _ -> Nothing\n\ndata RangeRatio = RR\n  { rrZero :: Double\n  -- ^ Where on the screen (0 to 1) to place the other axis\n  , rrRatio :: Double\n  -- ^ Ratio of height of a terminal character to width\n  }\n  deriving (Show)\n\ndata PlotRange\n  = PXY (Double, Double) (Double, Double)\n  | PX (Double, Double) RangeRatio\n  | PY RangeRatio (Double, Double)\n\nplot ::\n  -- | display bounds\n  (Int, Int) ->\n  PlotRange ->\n  -- | points to plot\n  [(V2 Double, (Char, Attr))] ->\n  [Image]\nplot (wd, ht) pr =\n  map (crop wd ht)\n    . (++ bgs)\n    . map (\\(p, (c, a)) -> place EQ EQ p $ char a c)\n  where\n    wd' = fromIntegral wd\n    ht' = fromIntegral ht\n    ((xmin, xmax), (ymin, ymax)) = mkRange (wd', ht') pr\n    origin = place EQ EQ (V2 0 0) $ char defAttr '+'\n    xaxis = place EQ EQ (V2 0 0) $ charFill defAttr '-' wd 1\n    yaxis = place EQ EQ (V2 0 0) $ charFill defAttr '|' 1 ht\n    xrange = xmax - xmin\n    yrange = ymax - ymin\n    bg = backgroundFill wd ht\n    scale (V2 pX pY) = V2 x y\n      where\n        x = round $ (pX - xmin) * (wd' / xrange)\n        y = round $ (pY - ymin) * (ht' / yrange)\n    place aX aY p i = case scale p of\n      V2 pX pY ->\n        translate\n          (fAlign aX (imageWidth i))\n          (fAlign aY (imageHeight i))\n          . translate pX pY\n          $ i\n    labels =\n      [ place LT EQ (V2 xmin 0) . string defAttr $ printf \"%.2f\" xmin\n      , place GT EQ (V2 xmax 0) . string defAttr $ printf \"%.2f\" xmax\n      , place EQ LT (V2 0 ymin) . string defAttr $ printf \"%.2f\" ymin\n      , place EQ GT (V2 0 ymax) . string defAttr $ printf \"%.2f\" ymax\n      ]\n    bgs = labels ++ [origin, xaxis, yaxis, bg]\n    fAlign = \\case\n      LT -> const 0\n      EQ -> negate . (`div` 2)\n      GT -> negate\n\nmkRange ::\n  (Double, Double) ->\n  PlotRange ->\n  ((Double, Double), (Double, Double))\nmkRange (wd, ht) = \\case\n  PXY xb yb -> (xb, yb)\n  PX xb RR{..} ->\n    let yr = uncurry (-) xb * ht / wd * rrRatio\n        y0 = (rrZero - 1) * yr\n     in (xb, (y0, y0 + yr))\n  PY RR{..} yb ->\n    let xr = uncurry (-) yb * wd / ht / rrRatio\n        x0 = rrZero - 1 * xr\n     in ((x0, x0 + xr), yb)\n\npattern V1 :: a -> V.Vector 1 a\npattern V1 x <- (V.head -> x)\n  where\n    V1 x = V.singleton x\n#if __GLASGOW_HASKELL__ >= 802\n{-# COMPLETE V1 #-}\n#endif\n\ntype V2 = V.Vector 2\npattern V2 :: a -> a -> V2 a\npattern V2 x y <- (V.toList -> [x, y])\n  where\n    V2 x y = V.fromTuple (x, y)\n#if __GLASGOW_HASKELL__ >= 802\n{-# COMPLETE V2 #-}\n#endif\n\npattern V3 :: a -> a -> a -> V.Vector 3 a\npattern V3 x y z <- (V.toList -> [x, y, z])\n  where\n    V3 x y z = V.fromTuple (x, y, z)\n#if __GLASGOW_HASKELL__ >= 802\n{-# COMPLETE V3 #-}\n#endif\n\npattern V4 :: a -> a -> a -> a -> V.Vector 4 a\npattern V4 x y z a <- (V.toList -> [x, y, z, a])\n  where\n    V4 x y z a = V.fromTuple (x, y, z, a)\n#if __GLASGOW_HASKELL__ >= 802\n{-# COMPLETE V4 #-}\n#endif\n\nlogistic ::\n  Floating a => a -> a -> a -> a -> a\nlogistic pos ht width = \\x -> ht / (1 + exp (-(beta * (x - pos))))\n  where\n    beta = log (0.9 / (1 - 0.9)) / width\n\nbezierCurve ::\n  forall n f a.\n  (KnownNat (1 + n), Applicative f, Num a) =>\n  V.Vector (1 + n) (f a) ->\n  a ->\n  f a\nbezierCurve ps t =\n  foldl' (liftA2 (+)) (pure 0)\n    . V.imap\n      ( \\i ->\n          let i' = fromIntegral i\n           in fmap (* (fromIntegral (n' `choose` i') * (1 - t) ^ (n' - i') * t ^ i))\n      )\n    $ ps\n  where\n    n' :: Int\n    n' = fromIntegral (maxBound :: Finite (1 + n))\n    choose :: Int -> Int -> Int\n    n `choose` k = factorial n `div` (factorial (n - k) * factorial k)\n    factorial :: Int -> Int\n    factorial m = product [1 .. m]\n\nderiving instance Ord Color\n"
  },
  {
    "path": "flake.nix",
    "content": "{\n  description = \"Basic Haskell Project Flake\";\n  inputs = {\n    haskellProjectFlake.url = \"github:mstksg/haskell-project-flake\";\n    nixpkgs.follows = \"haskellProjectFlake/nixpkgs\";\n  };\n  outputs =\n    { self\n    , nixpkgs\n    , flake-utils\n    , haskellProjectFlake\n    }:\n    flake-utils.lib.eachDefaultSystem (system:\n    let\n      name = \"hamilton\";\n      pkgs = import nixpkgs {\n        inherit system;\n        overlays = [ haskellProjectFlake.overlays.\"${system}\".default ];\n      };\n      project-flake = pkgs.haskell-project-flake\n        {\n          inherit name;\n          src = ./.;\n          excludeCompilerMajors = [ \"ghc911\" ];\n          defaultCompiler = \"ghc982\";\n        };\n    in\n    {\n      packages = project-flake.packages;\n      apps = project-flake.apps;\n      checks = project-flake.checks;\n      devShells = project-flake.devShells;\n      legacyPackages.\"${name}\" = project-flake;\n    }\n    );\n}\n\n"
  },
  {
    "path": "fourmolu.yaml",
    "content": "column-limit: 100\ncomma-style: leading\nfixities: []\nfunction-arrows: trailing\nhaddock-style: single-line\nhaddock-style-module: null\nimport-export-style: diff-friendly\nin-style: right-align\nindent-wheres: true\nindentation: 2\nlet-style: inline\nnewlines-between-decls: 1\nrecord-break-space: true\nreexports: []\nrespectful: true\nsingle-constraint-parens: never\nunicode: detect\n"
  },
  {
    "path": "hamilton.cabal",
    "content": "cabal-version:      1.12\n\n-- This file has been generated from package.yaml by hpack version 0.36.1.\n--\n-- see: https://github.com/sol/hpack\n\nname:               hamilton\nversion:            0.1.0.4\nsynopsis:\n  Physics on generalized coordinate systems using Hamiltonian Mechanics and AD\n\ndescription:\n  See README.md (or read online at <https://github.com/mstksg/hamilton#readme>)\n\ncategory:           Physics\nhomepage:           https://github.com/mstksg/hamilton#readme\nbug-reports:        https://github.com/mstksg/hamilton/issues\nauthor:             Justin Le\nmaintainer:         justin@jle.im\ncopyright:          (c) Justin Le 2024\nlicense:            BSD3\nlicense-file:       LICENSE\nbuild-type:         Simple\ntested-with:        GHC >=8.10\nextra-source-files:\n  CHANGELOG.md\n  README.md\n\nsource-repository head\n  type:     git\n  location: https://github.com/mstksg/hamilton\n\nlibrary\n  exposed-modules:  Numeric.Hamilton\n  other-modules:    Paths_hamilton\n  hs-source-dirs:   src\n  ghc-options:      -Wall -O2\n  build-depends:\n      ad\n    , base                       >=4.9   && <5\n    , ghc-typelits-natnormalise\n    , hmatrix                    >=0.18\n    , hmatrix-gsl                >=0.18\n    , hmatrix-vector-sized       >=0.1.3\n    , typelits-witnesses         >=0.2.3\n    , vector-sized               >=1.0\n\n  default-language: Haskell2010\n\nexecutable hamilton-examples\n  main-is:          Examples.hs\n  other-modules:    Paths_hamilton\n  hs-source-dirs:   app\n  ghc-options:      -Wall -O2 -threaded -rtsopts -with-rtsopts=-N\n  build-depends:\n      base                   >=4.9   && <5\n    , containers\n    , finite-typelits\n    , ghc-typelits-knownnat\n    , hamilton\n    , hmatrix                >=0.18\n    , hmatrix-vector-sized   >=0.1.3\n    , optparse-applicative   >=0.13\n    , prettyprinter\n    , vector\n    , vector-sized           >=1.0\n    , vty\n    , vty-crossplatform\n\n  default-language: Haskell2010\n"
  },
  {
    "path": "src/Numeric/Hamilton.hs",
    "content": "{-# LANGUAGE DataKinds #-}\n{-# LANGUAGE DeriveGeneric #-}\n{-# LANGUAGE GADTs #-}\n{-# LANGUAGE KindSignatures #-}\n{-# LANGUAGE RankNTypes #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE ScopedTypeVariables #-}\n{-# LANGUAGE StandaloneDeriving #-}\n{-# LANGUAGE TypeApplications #-}\n{-# LANGUAGE TypeOperators #-}\n{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}\n\n-- |\n-- Module      : Numeric.Hamilton\n-- Description : Hamiltonian dynamics for physical systems on generalized\n--               coordinates using automatic differentiation\n-- Copyright   : (c) Justin Le 2024\n-- License     : BSD-3\n-- Maintainer  : justin@jle.im\n-- Stability   : unstable\n-- Portability : portable\n--\n-- Simulate physical systems on generalized/arbitrary coordinates using\n-- Hamiltonian mechanics and automatic differentiation!\n--\n-- See the <https://github.com/mstksg/hamilton#readme> for more\n-- information on usage!\nmodule Numeric.Hamilton (\n  -- * Systems and states\n\n  -- ** Systems\n  System,\n  mkSystem,\n  mkSystem',\n  underlyingPos,\n\n  -- ** States\n  Config (..),\n  Phase (..),\n  toPhase,\n  fromPhase,\n\n  -- * State functions\n  momenta,\n  velocities,\n  keC,\n  keP,\n  pe,\n  lagrangian,\n  hamiltonian,\n  hamEqs,\n\n  -- * Simulating hamiltonian dynamics\n\n  -- ** Over phase space\n  stepHam,\n  evolveHam,\n  evolveHam',\n\n  -- ** Over configuration space\n\n  -- | Convenience wrappers over the normal phase-space\n  -- steppers/simulators that allow you to provide input and expect\n  -- output in configuration space instead of in phase space.  Note that\n  -- the simulation itself still runs in phase space, so these all\n  -- require conversions to and from phase space under the hood.\n  stepHamC,\n  evolveHamC,\n  evolveHamC',\n) where\n\nimport Control.Monad\nimport Data.Bifunctor\nimport Data.Foldable\nimport Data.Kind\nimport Data.Maybe\nimport Data.Proxy\nimport Data.Type.Equality\nimport qualified Data.Vector.Generic.Sized as VG\nimport qualified Data.Vector.Sized as V\nimport GHC.Generics (Generic)\nimport GHC.TypeLits\nimport GHC.TypeLits.Compare\nimport Numeric.AD\nimport Numeric.GSL.ODE\nimport qualified Numeric.LinearAlgebra as LA\nimport Numeric.LinearAlgebra.Static as H\nimport Numeric.LinearAlgebra.Static.Vector\n\n-- | Represents the full state of a system of @n@ generalized coordinates\n-- in configuration space (informally, \"positions and velocities\")\n--\n-- A configuration space representaiton is more directly \"physically\n-- meaningful\" and intuitive/understandable to humans than a phase space\n-- representation.  However, it's much less mathematically ideal to work\n-- with because of the lack of some neat underlying symmetries.\n--\n-- You can convert a @'Config' n@ into a @'Phase' n@ (convert from\n-- configuration space to phase space) for a given system with 'toPhase'.\n-- This allows you to state your system in configuration space and then\n-- convert it to phase space before handing it off to the hamiltonian\n-- machinery.\ndata Config :: Nat -> Type where\n  Cfg ::\n    { cfgPositions :: !(R n)\n    -- ^ The current values (\"positions\") of each of the @n@\n    -- generalized coordinates\n    , cfgVelocities :: !(R n)\n    -- ^ The current rate of changes (\"velocities\") of each of the\n    -- @n@ generalized coordinates\n    } ->\n    Config n\n  deriving (Generic)\n\nderiving instance KnownNat n => Show (Config n)\n\n-- | Represents the full state of a system of @n@ generalized coordinates\n-- in phase space (informally, \"positions and momentums\").\n--\n-- Phase space representations are much nicer to work with mathematically\n-- because of some neat underlying symmetries.  For one, positions and\n-- momentums are \"interchangeable\" in a system; if you swap every\n-- coordinate's positions with their momentums, and also swap them in the\n-- equations of motions, you get the same system back.  This isn't the case\n-- with configuration space representations.\n--\n-- A hamiltonian simulation basically describes the trajectory of each\n-- coordinate through phase space, so this is the /state/ of the\n-- simulation.  However, configuration space representations are much more\n-- understandable to humans, so it might be useful to give an initial state\n-- in configuration space using 'Config', and then convert it to a 'Phase'\n-- with 'toPhase'.\ndata Phase :: Nat -> Type where\n  Phs ::\n    { phsPositions :: !(R n)\n    -- ^ The current values (\"positions\") of each of the @n@\n    -- generalized coordinates.\n    , phsMomenta :: !(R n)\n    -- ^ The current conjugate momenta (\"momentums\") to each of\n    -- the @n@ generalized coordinates\n    } ->\n    Phase n\n  deriving (Generic)\n\nderiving instance KnownNat n => Show (Phase n)\n\n-- | Represents a physical system in which physics happens.  A @'System'\n-- m n@ is a system whose state described using @n@ generalized coordinates\n-- (an \"@n@-dimensional\" system), where the underlying cartesian coordinate\n-- space is @m@-dimensional.\n--\n-- For the most part, you are supposed to be able to ignore @m@.  @m@ is\n-- only provided because it's useful when plotting/drawing the system with\n-- a given state back in rectangular coordinates. (The only function that\n-- use the @m@ at the moment is 'underlyingPos')\n--\n-- A @'System' m n@'s state is described using a @'Config' n@ (which\n-- describes the system in configuration space) or a @'Phase' n@ (which\n-- describes the system in phase space).\ndata System :: Nat -> Nat -> Type where\n  Sys ::\n    { _sysInertia :: R m\n    , _sysCoords :: R n -> R m\n    , _sysJacobian :: R n -> L m n\n    , _sysHessian :: R n -> V.Vector n (L m n)\n    , _sysPotential :: R n -> Double\n    , _sysPotentialGrad :: R n -> R n\n    } ->\n    System m n\n\n-- | Converts the position of generalized coordinates of a system to the\n-- coordinates of the system's underlying cartesian coordinate system.\n-- Useful for plotting/drawing the system in cartesian space.\nunderlyingPos ::\n  System m n ->\n  R n ->\n  R m\nunderlyingPos = _sysCoords\n\n-- | The potential energy of a system, given the position in the\n-- generalized coordinates of the system.\npe ::\n  System m n ->\n  R n ->\n  Double\npe = _sysPotential\n\nvec2l ::\n  (KnownNat m, KnownNat n) =>\n  V.Vector m (V.Vector n Double) ->\n  L m n\nvec2l = rowsL . fmap gvecR\n\n-- | Create a system with @n@ generalized coordinates by describing its\n-- coordinate space (by a function from the generalized coordinates to the\n-- underlying cartesian coordinates), the inertia of each of those\n-- underlying coordinates, and the pontential energy function.\n--\n-- The potential energy function is expressed in terms of the genearlized\n-- coordinate space's positions.\nmkSystem ::\n  forall m n.\n  (KnownNat m, KnownNat n) =>\n  -- | The \"inertia\" of each of the @m@ coordinates\n  -- in the underlying cartesian space of the system.  This\n  -- should be mass for linear coordinates and rotational\n  -- inertia for angular coordinates.\n  R m ->\n  -- | Conversion function to convert points in the\n  -- generalized coordinate space to the underlying cartesian\n  -- space of the system.\n  (forall a. RealFloat a => V.Vector n a -> V.Vector m a) ->\n  -- | The potential energy of the system as a function of\n  -- the generalized coordinate space's positions.\n  (forall a. RealFloat a => V.Vector n a -> a) ->\n  System m n\nmkSystem m f u =\n  Sys\n    { _sysInertia = m\n    , _sysCoords = gvecR . f . grVec\n    , _sysJacobian = tr . vec2l . jacobianT f . grVec\n    , _sysHessian = tr2 . fmap vec2l . hessianF f . grVec\n    , _sysPotential = u . grVec\n    , _sysPotentialGrad = gvecR . grad u . grVec\n    }\n  where\n    tr2 ::\n      forall o.\n      (KnownNat n, KnownNat o) =>\n      V.Vector m (L n o) ->\n      V.Vector n (L m o)\n    tr2 = fmap rowsL . traverse lRows\n    {-# INLINE tr2 #-}\n\n-- | Convenience wrapper over 'mkSystem' that allows you to specify the\n-- potential energy function in terms of the underlying cartesian\n-- coordinate space.\nmkSystem' ::\n  forall m n.\n  (KnownNat m, KnownNat n) =>\n  -- | The \"inertia\" of each of the @m@ coordinates\n  -- in the underlying cartesian space of the system.  This\n  -- should be mass for linear coordinates and rotational\n  -- inertia for angular coordinates.\n  R m ->\n  -- | Conversion function to convert points in the\n  -- generalized coordinate space to the underlying cartesian\n  -- space of the system.\n  (forall a. RealFloat a => V.Vector n a -> V.Vector m a) ->\n  -- | The potential energy of the system as a function of\n  -- the underlying cartesian coordinate space's positions.\n  (forall a. RealFloat a => V.Vector m a -> a) ->\n  System m n\nmkSystem' m f u = mkSystem m f (u . f)\n\n-- | Compute the generalized momenta conjugate to each generalized\n-- coordinate of a system by giving the configuration-space state of the\n-- system.\n--\n-- Note that getting the momenta from a @'Phase' n@ involves just using\n-- 'phsMomenta'.\nmomenta ::\n  (KnownNat m, KnownNat n) =>\n  System m n ->\n  Config n ->\n  R n\nmomenta Sys{..} Cfg{..} = tr j #> diag _sysInertia #> j #> cfgVelocities\n  where\n    j = _sysJacobian cfgPositions\n\n-- | Convert a configuration-space representaiton of the state of the\n-- system to a phase-space representation.\n--\n-- Useful because the hamiltonian simulations use 'Phase' as its working\n-- state, but 'Config' is a much more human-understandable and intuitive\n-- representation.  This allows you to state your starting state in\n-- configuration space and convert to phase space for your simulation to\n-- use.\ntoPhase ::\n  (KnownNat m, KnownNat n) =>\n  System m n ->\n  Config n ->\n  Phase n\ntoPhase s = Phs <$> cfgPositions <*> momenta s\n\n-- | The kinetic energy of a system, given the system's state in\n-- configuration space.\nkeC ::\n  (KnownNat m, KnownNat n) =>\n  System m n ->\n  Config n ->\n  Double\nkeC s = do\n  vs <- cfgVelocities\n  ps <- momenta s\n  return $ (vs <.> ps) / 2\n\n-- | The Lagrangian of a system (the difference between the kinetic energy\n-- and the potential energy), given the system's state in configuration\n-- space.\nlagrangian ::\n  (KnownNat m, KnownNat n) =>\n  System m n ->\n  Config n ->\n  Double\nlagrangian s = do\n  t <- keC s\n  u <- pe s . cfgPositions\n  return (t - u)\n\n-- | Compute the rate of change of each generalized coordinate by giving\n-- the state of the system in phase space.\n--\n-- Note that getting the velocities from a @'Config' n@ involves just using\n-- 'cfgVelocities'.\nvelocities ::\n  (KnownNat m, KnownNat n) =>\n  System m n ->\n  Phase n ->\n  R n\nvelocities Sys{..} Phs{..} = inv jmj #> phsMomenta\n  where\n    j = _sysJacobian phsPositions\n    jmj = tr j H.<> diag _sysInertia H.<> j\n\n-- | Invert 'toPhase' and convert a description of a system's state in\n-- phase space to a description of the system's state in configuration\n-- space.\n--\n-- Possibly useful for showing the phase space representation of a system's\n-- state in a more human-readable/human-understandable way.\nfromPhase ::\n  (KnownNat m, KnownNat n) =>\n  System m n ->\n  Phase n ->\n  Config n\nfromPhase s = Cfg <$> phsPositions <*> velocities s\n\n-- | The kinetic energy of a system, given the system's state in\n-- phase space.\nkeP ::\n  (KnownNat m, KnownNat n) =>\n  System m n ->\n  Phase n ->\n  Double\nkeP s = do\n  ps <- phsMomenta\n  vs <- velocities s\n  return $ (vs <.> ps) / 2\n\n-- | The Hamiltonian of a system (the sum of kinetic energy and the\n-- potential energy), given the system's state in phase space.\nhamiltonian ::\n  (KnownNat m, KnownNat n) =>\n  System m n ->\n  Phase n ->\n  Double\nhamiltonian s = do\n  t <- keP s\n  u <- pe s . phsPositions\n  return (t + u)\n\n-- | The \"hamiltonian equations\" for a given system at a given state in\n-- phase space.  Returns the rate of change of the positions and\n-- conjugate momenta, which can be used to progress the simulation through\n-- time.\n--\n-- Computed using the maths derived in\n-- <https://blog.jle.im/entry/hamiltonian-dynamics-in-haskell.html>.\nhamEqs ::\n  (KnownNat m, KnownNat n) =>\n  System m n ->\n  Phase n ->\n  (R n, R n)\nhamEqs Sys{..} Phs{..} = (dHdp, -dHdq)\n  where\n    mm = diag _sysInertia\n    j = _sysJacobian phsPositions\n    trj = tr j\n    jmj = trj H.<> mm H.<> j\n    ijmj = inv jmj\n    dTdq = gvecR\n      . flip fmap (_sysHessian phsPositions)\n      $ \\djdq ->\n        -(phsMomenta <.> ijmj #> trj #> mm #> djdq #> ijmj #> phsMomenta)\n    dHdp = ijmj #> phsMomenta\n    dHdq = dTdq + _sysPotentialGrad phsPositions\n\n-- | Step a system through phase space over over a single timestep.\nstepHam ::\n  forall m n.\n  (KnownNat m, KnownNat n) =>\n  -- | timestep to step through\n  Double ->\n  -- | system to simulate\n  System m n ->\n  -- | initial state, in phase space\n  Phase n ->\n  Phase n\nstepHam r s p =\n  evolveHam @m @n @2 s p (V.fromTuple (0, r))\n    `V.unsafeIndex` 1\n\n-- | Evolve a system using a hamiltonian stepper, with the given initial\n-- phase space state.\n--\n-- Desired solution times provided as a list instead of a sized 'V.Vector'.\n-- The output list should be the same length as the input list.\nevolveHam' ::\n  forall m n.\n  (KnownNat m, KnownNat n) =>\n  -- | system to simulate\n  System m n ->\n  -- | initial state, in phase space\n  Phase n ->\n  -- | desired solution times\n  [Double] ->\n  [Phase n]\nevolveHam' _ _ [] = []\nevolveHam' s p0 ts = V.withSizedList (toList ts') $ \\(v :: V.Vector s Double) ->\n  case Proxy @2 %<=? Proxy @s of\n    LE Refl ->\n      (if l1 then toList . V.tail @(s - 1) else toList) $\n        evolveHam s p0 v\n    NLE{} -> error \"evolveHam': Internal error\"\n  where\n    (l1, ts') = case ts of\n      [x] -> (True, [0, x])\n      _ -> (False, ts)\n\n-- | Evolve a system using a hamiltonian stepper, with the given initial\n-- phase space state.\nevolveHam ::\n  forall m n s.\n  (KnownNat m, KnownNat n, KnownNat s, 2 <= s) =>\n  -- | system to simulate\n  System m n ->\n  -- | initial state, in phase space\n  Phase n ->\n  -- | desired solution times\n  V.Vector s Double ->\n  V.Vector s (Phase n)\nevolveHam s p0 ts =\n  fmap toPs . fromJust . V.fromList . LA.toRows $\n    odeSolveV RKf45 hi eps eps (const f) (fromPs p0) ts'\n  where\n    hi = (V.unsafeIndex ts 1 - V.unsafeIndex ts 0) / 100\n    eps = 1.49012e-08\n    f :: LA.Vector Double -> LA.Vector Double\n    f =\n      (\\(p, m) -> LA.vjoin [p, m])\n        . join bimap extract\n        . hamEqs s\n        . toPs\n    ts' = VG.fromSized . VG.convert $ ts\n    n = fromInteger $ natVal (Proxy @n)\n    fromPs :: Phase n -> LA.Vector Double\n    fromPs p = LA.vjoin . map extract $ [phsPositions p, phsMomenta p]\n    toPs :: LA.Vector Double -> Phase n\n    toPs v = case traverse create . LA.takesV [n, n] $ v of\n      Just [pP, pM] -> Phs pP pM\n      _ -> error \"evolveHam: internal error\"\n\n-- | A convenience wrapper for 'evolveHam'' that works on configuration\n-- space states instead of phase space states.\n--\n-- Note that the simulation itself still runs in phase space; this function\n-- just abstracts over converting to and from phase space for the inputs\n-- and outputs.\nevolveHamC' ::\n  forall m n.\n  (KnownNat m, KnownNat n) =>\n  -- | system to simulate\n  System m n ->\n  -- | initial state, in configuration space\n  Config n ->\n  -- | desired solution times\n  [Double] ->\n  [Config n]\nevolveHamC' s c0 = fmap (fromPhase s) . evolveHam' s (toPhase s c0)\n\n-- | A convenience wrapper for 'evolveHam' that works on configuration\n-- space states instead of phase space states.\n--\n-- Note that the simulation itself still runs in phase space; this function\n-- just abstracts over converting to and from phase space for the inputs\n-- and outputs.\nevolveHamC ::\n  forall m n s.\n  (KnownNat m, KnownNat n, KnownNat s, 2 <= s) =>\n  -- | system to simulate\n  System m n ->\n  -- | initial state, in configuration space\n  Config n ->\n  -- | desired solution times\n  V.Vector s Double ->\n  V.Vector s (Config n)\nevolveHamC s c0 = fmap (fromPhase s) . evolveHam s (toPhase s c0)\n\n-- | Step a system through configuration space over over a single timestep.\n--\n-- Note that the simulation itself still runs in phase space; this function\n-- just abstracts over converting to and from phase space for the input\n-- and output.\nstepHamC ::\n  forall m n.\n  (KnownNat m, KnownNat n) =>\n  -- | timestep to step through\n  Double ->\n  -- | system to simulate\n  System m n ->\n  -- | initial state, in phase space\n  Config n ->\n  Config n\nstepHamC r s = fromPhase s . stepHam r s . toPhase s\n"
  },
  {
    "path": "test/Spec.hs",
    "content": "main :: IO ()\nmain = putStrLn \"Test suite not yet implemented\"\n"
  }
]