├── .travis.yml ├── LICENSE ├── README.md ├── Setup.hs ├── bench └── benchmarks.hs ├── changelog.md ├── clifford.cabal ├── examples └── Pendulum.hs ├── papers ├── Liszka and Orkisz - 1980 - The finite difference method at arbitrary irregular grids and its application in applied mechanics.pdf └── S0025-5718-1988-0935077-0.pdf ├── src ├── Numeric │ └── Clifford │ │ ├── Blade.lhs │ │ ├── ClassicalMechanics.lhs │ │ ├── ExpressionTree.lhs │ │ ├── Internal.hs │ │ ├── LinearOperators.lhs │ │ ├── Manifold.lhs │ │ ├── Multivector.lhs │ │ ├── NumericIntegration.lhs │ │ ├── NumericIntegration │ │ └── DefaultIntegrators.hs │ │ └── Systems │ │ ├── Components.lhs │ │ ├── Control.lhs │ │ └── Discrete │ │ └── Control.lhs ├── biblio.bib └── exponentialDecay.hs └── test ├── Numeric └── Clifford │ ├── BladeSpec.lhs │ └── MultivectorSpec.lhs └── Spec.lhs /.travis.yml: -------------------------------------------------------------------------------- 1 | # NB: don't set `language: haskell` here 2 | 3 | # See also https://github.com/hvr/multi-ghc-travis for more information 4 | 5 | # The following lines enable several GHC versions and/or HP versions 6 | # to be tested; often it's enough to test only against the last 7 | # release of a major GHC version. Setting HPVER implictly sets 8 | # GHCVER. Omit lines with versions you don't need/want testing for. 9 | 10 | 11 | 12 | env: 13 | - GHCVER=7.6.3 14 | 15 | 16 | 17 | # Note: the distinction between `before_install` and `install` is not 18 | # important. 19 | before_install: 20 | - case "$HPVER" in 21 | "") ;; 22 | 23 | "2013.2.0.0") 24 | export GHCVER=7.6.3 ; 25 | echo "constraints:async==2.0.1.4,attoparsec==0.10.4.0,case-insensitive==1.0.0.1,cgi==3001.1.7.5,fgl==5.4.2.4,GLUT==2.4.0.0,GLURaw==1.3.0.0,haskell-src==1.0.1.5,hashable==1.1.2.5,html==1.0.1.2,HTTP==4000.2.8,HUnit==1.2.5.2,mtl==2.1.2,network==2.4.1.2,OpenGL==2.8.0.0,OpenGLRaw==1.3.0.0,parallel==3.2.0.3,parsec==3.1.3,QuickCheck==2.6,random==1.0.1.1,regex-base==0.93.2,regex-compat==0.95.1,regex-posix==0.95.2,split==0.2.2,stm==2.4.2,syb==0.4.0,text==0.11.3.1,transformers==0.3.0.0,unordered-containers==0.2.3.0,vector==0.10.0.1,xhtml==3000.2.1,zlib==0.5.4.1" > cabal.config ;; 26 | 27 | "2012.4.0.0") 28 | export GHCVER=7.6.2 ; 29 | echo "constraints:async==2.0.1.3,cgi==3001.1.7.4,fgl==5.4.2.4,GLUT==2.1.2.1,haskell-src==1.0.1.5,html==1.0.1.2,HTTP==4000.2.5,HUnit==1.2.5.1,mtl==2.1.2,network==2.3.1.0,OpenGL==2.2.3.1,parallel==3.2.0.3,parsec==3.1.3,QuickCheck==2.5.1.1,random==1.0.1.1,regex-base==0.93.2,regex-compat==0.95.1,regex-posix==0.95.2,split==0.2.1.1,stm==2.4,syb==0.3.7,text==0.11.2.3,transformers==0.3.0.0,vector==0.10.0.1,xhtml==3000.2.1,zlib==0.5.4.0" > cabal.config ;; 30 | 31 | "2012.2.0.0") 32 | export GHCVER=7.4.1 ; 33 | echo "constraints:cgi==3001.1.7.4,fgl==5.4.2.4,GLUT==2.1.2.1,haskell-src==1.0.1.5,html==1.0.1.2,HTTP==4000.2.3,HUnit==1.2.4.2,mtl==2.1.1,network==2.3.0.13,OpenGL==2.2.3.1,parallel==3.2.0.2,parsec==3.1.2,QuickCheck==2.4.2,random==1.0.1.1,regex-base==0.93.2,regex-compat==0.95.1,regex-posix==0.95.1,stm==2.3,syb==0.3.6.1,text==0.11.2.0,transformers==0.3.0.0,xhtml==3000.2.1,zlib==0.5.3.3" > cabal.config ;; 34 | 35 | "2011.4.0.0") 36 | export GHCVER=7.0.4 ; 37 | echo "constraints:cgi==3001.1.7.4,fgl==5.4.2.4,GLUT==2.1.2.1,haskell-src==1.0.1.4,html==1.0.1.2,HUnit==1.2.4.2,network==2.3.0.5,OpenGL==2.2.3.0,parallel==3.1.0.1,parsec==3.1.1,QuickCheck==2.4.1.1,regex-base==0.93.2,regex-compat==0.95.1,regex-posix==0.95.1,stm==2.2.0.1,syb==0.3.3,xhtml==3000.2.0.4,zlib==0.5.3.1,HTTP==4000.1.2,deepseq==1.1.0.2" > cabal.config ;; 38 | 39 | *) 40 | export GHCVER=unknown ; 41 | echo "unknown/invalid Haskell Platform requested" ; 42 | exit 1 ;; 43 | 44 | esac 45 | 46 | - sudo add-apt-repository -y ppa:hvr/ghc 47 | - wget -q -O - http://llvm.org/apt/llvm-snapshot.gpg.key | sudo apt-key add -qq - 48 | - sudo add-apt-repository 'deb http://llvm.org/apt/precise/ llvm-toolchain-precise-3.4 main' 49 | - sudo add-apt-repository 'deb https://launchpad.net/~ubuntu-toolchain-r/+archive/ppa precise backported' 50 | - sudo add-apt-repository 'deb http://ppa.launchpad.net/ubuntu-toolchain-r/test/ubuntu precise main' 51 | - sudo apt-get update 52 | - sudo apt-get install cabal-install-1.18 ghc-$GHCVER llvm-3.4-tools libllvm-3.4 llvm-3.4-examples clang-3.4 llvm-3.4-runtime llvm-3.4 llvm-3.4-dev libclang-common-3.4-dev libclang-3.4-dev 53 | - export PATH=/opt/ghc/$GHCVER/bin:$PATH 54 | - export LD_LIBRARY_PATH=/usr/lib/llvm-3.4/lib/:$LD_LIBRARY_PATH 55 | 56 | install: 57 | - cabal-1.18 update 58 | - cabal-1.18 install happy alex 59 | - cabal-1.18 install --only-dependencies --enable-tests --enable-benchmarks 60 | 61 | # Here starts the actual work to be performed for the package under 62 | # test; any command which exits with a non-zero exit code causes the 63 | # build to fail. 64 | script: 65 | # -v2 provides useful information for debugging 66 | - cabal-1.18 configure --enable-tests --enable-benchmarks -v2 67 | 68 | # this builds all libraries and executables 69 | # (including tests/benchmarks) 70 | - cabal-1.18 build 71 | 72 | - cabal-1.18 test 73 | - cabal-1.18 check 74 | 75 | # tests that a source-distribution can be generated 76 | - cabal-1.18 sdist 77 | 78 | # check that the generated source-distribution can be built & installed 79 | - export SRC_TGZ=$(cabal-1.18 info . | awk '{print $2 ".tar.gz";exit}') ; 80 | cd dist/; 81 | if [ -f "$SRC_TGZ" ]; then 82 | cabal-1.18 install "$SRC_TGZ"; 83 | else 84 | echo "expected '$SRC_TGZ' not found"; 85 | exit 1; 86 | fi 87 | 88 | # EOF 89 | 90 | notifications: 91 | email: false -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Sophie Taylor 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 Sophie Taylor 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. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | haskell-clifford 2 | ================ 3 | 4 | Clifford algebra for Haskell! :D 5 | 6 | This is initially going to just be algebraic stuff, but I'll probably add things such as numerical differentiation/integration eventually. 7 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /bench/benchmarks.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE NoMonomorphismRestriction #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE DataKinds #-} 6 | --{-# OPTIONS_GHC -fllvm -fexcess-precision -optlo-O3 -optlc-O=3 -O3 #-} 7 | 8 | import Numeric.Clifford.Multivector 9 | import Numeric.Clifford.NumericIntegration.DefaultIntegrators 10 | import Criterion.Main 11 | import Algebra.Transcendental 12 | import Algebra.Algebraic 13 | import Data.List.Stream 14 | import NumericPrelude hiding (iterate, last, map, take, log, length, replicate) 15 | import Prelude hiding (iterate, last, map, negate, take,log, (*), 16 | (+), (-), (/), length, replicate) 17 | import Numeric.Compensated 18 | import MathObj.Wrapper.Haskell98 19 | import Control.DeepSeq 20 | 21 | --comp a = Cons (compensated a 0) 22 | comp = id 23 | scalar2 = scalar (comp 2.0) :: STVector 24 | ij2 = (comp 2.0) `e` [1,2] :: STVector 25 | ik3 = (comp 3.0) `e` [1,3] :: STVector 26 | ijk4 = (comp 4.0) `e` [1,2,3] :: STVector 27 | ijl5 = (comp 5.0) `e` [1,2,4] :: STVector 28 | a = ij2 + ik3 + ijk4 + ijl5 + (scalar 1.5) 29 | enormousThing = a*a*a*a*a*a*a + scalar2 30 | expDecay _ x = map negate $ map ((*) (1.3 `e` [] :: STVector)) x 31 | thelambda init = lobattoIIIAFourthOrder (comp 0.01) expDecay init 32 | 33 | 34 | main = defaultMain [ 35 | bgroup "log" [ bench "scalar 2.0" $ nf log scalar2 36 | , bench "2ij" $ nf log ij2 37 | , bench "3ik" $ nf log ik3 38 | , bench "4ijk" $ nf log ijk4 39 | , bench "5ijl" $ nf log ijl5 40 | , bench "sum" $ nf log a 41 | , bench "enormous thing" $ nf log enormousThing 42 | ], 43 | bgroup "lobatto IIIA 4th order RK solver" 44 | [ 45 | bench "200 iterations exponential decay" $ nf (\x -> last $ take 200 (iterate thelambda x)) (0.0,replicate 4 $ scalar 1.0) 46 | ] 47 | ] 48 | -------------------------------------------------------------------------------- /changelog.md: -------------------------------------------------------------------------------- 1 | -*-change-log-*- 2 | 0.1.0.14 Added pendulum example 3 | 0.1.0.13 Adding ability to create linear operators from matrices; made linear operators a category and monoid 4 | 0.1.0.12 Adding type signatures to top level stuff 5 | 0.1.0.11 More inlining and specialisation 6 | 0.1.0.10 Fixed compile error whoops 7 | 0.1.0.9 Inlined/specialised a bunch of function, hueg speed increase 8 | 0.1.0.8 Implemented algebraic/transcendental typeclasses 9 | 0.1.0.7 Adding basic linear operators; made multivector a field 10 | 0.1.0.6 Memoising the blade index comparision function for a 20% speed increase 11 | 0.1.0.5 Adding hspec tests, fixed blade comparison to order blades in terms of grade first 12 | 13 | 0.1.0.4 Made multivectors have a (p,q) metric signature at the type level 14 | -------------------------------------------------------------------------------- /clifford.cabal: -------------------------------------------------------------------------------- 1 | -- Initial clifford.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | -- The name of the package. 5 | name: clifford 6 | 7 | -- The package version. See the Haskell package versioning policy (PVP) 8 | -- for standards guiding when and how versions should be incremented. 9 | -- http://www.haskell.org/haskellwiki/Package_versioning_policy 10 | -- PVP summary: +-+------- breaking API changes 11 | -- | | +----- non-breaking API additions 12 | -- | | | +--- code changes with no API change 13 | version: 0.1.0.15 14 | 15 | -- A short (one-line) description of the package. 16 | synopsis: A Clifford algebra library 17 | 18 | -- A longer description of the package. 19 | -- description: 20 | 21 | -- URL for the project homepage or repository. 22 | homepage: http://github.com/spacekitteh/haskell-clifford 23 | 24 | 25 | -- The license under which the package is released. 26 | license: BSD3 27 | 28 | -- The file containing the license text. 29 | license-file: LICENSE 30 | 31 | -- The package author(s). 32 | author: Sophie Taylor 33 | 34 | -- An email address to which users can send suggestions, bug reports, and 35 | -- patches. 36 | maintainer: sophie@traumapony.org 37 | 38 | -- A copyright notice. 39 | -- copyright: 40 | 41 | category: Math, Numerical 42 | 43 | build-type: Simple 44 | 45 | -- Extra files to be distributed with the package, such as examples or a 46 | -- README. 47 | extra-source-files: README.md changelog.md test/Numeric/Clifford/BladeSpec.lhs test/Numeric/Clifford/MultivectorSpec.lhs 48 | --test/Numeric/Clifford/LinearOperatorsSpec.lhs 49 | -- Constraint on the version of Cabal needed to build this package. 50 | cabal-version: >=1.10 51 | 52 | 53 | library 54 | -- Modules exported by the library. 55 | exposed-modules: Numeric.Clifford.Blade, Numeric.Clifford.Multivector, Numeric.Clifford.NumericIntegration, Numeric.Clifford.NumericIntegration.DefaultIntegrators, Numeric.Clifford.ClassicalMechanics, Numeric.Clifford.LinearOperators, Numeric.Clifford.Internal, Numeric.Clifford.Manifold, Numeric.Clifford.Systems.Components, Numeric.Clifford.ExpressionTree, Numeric.Clifford.Systems.Control, Numeric.Clifford.Systems.Discrete.Control 56 | 57 | -- Modules included in this library but not exported. 58 | -- other-modules: 59 | 60 | -- LANGUAGE extensions used by modules in this package. 61 | other-extensions: NoImplicitPrelude, ScopedTypeVariables, GADTs, DataKinds,KindSignatures,UnicodeSyntax,FlexibleContexts, RankNTypes,TemplateHaskell,NoMonomorphismRestriction,MultiParamTypeClasses,FlexibleInstances, TypeOperators, UnicodeSyntax, ConstraintKinds 62 | -- Other library packages from which modules are imported. 63 | build-depends: base >=4.6 && <4.9, numeric-prelude, permutation, 64 | data-ordlist, converge, lens, 65 | deepseq, vector, stream-fusion, criterion, derive, QuickCheck, nats, tagged, cereal,hspec, MemoTrie, semigroupoids , monoid-extras , reflection, compensated, vector-space, vector-space-points, math-functions, base-unicode-symbols, netwire, recursion-schemes, containers, compdata, parallel 66 | 67 | ghc-options: -fllvm -fexcess-precision -optlc-O=3 -O3 -ferror-spans -j2 -threaded -rtsopts -feager-blackholing 68 | -- Directories containing source files. 69 | hs-source-dirs: src 70 | 71 | -- Base language which the package is written in. 72 | default-language: Haskell2010 73 | 74 | 75 | executable pendulum 76 | build-depends: base, clifford, numeric-prelude,stream-fusion, Chart, Chart-cairo, colour, lens, data-default-class, deepseq, compensated, ekg, bytestring 77 | other-extensions: NoImplicitPrelude, FlexibleInstances 78 | main-is: Pendulum.hs 79 | hs-source-dirs: examples 80 | default-language: Haskell2010 81 | ghc-options: -fllvm -fexcess-precision -optlc-O=3 -O3 -rtsopts 82 | 83 | test-suite spec 84 | type: exitcode-stdio-1.0 85 | default-extensions: DataKinds, ScopedTypeVariables 86 | default-language: Haskell2010 87 | ghc-options: -Wall 88 | hs-source-dirs: test 89 | main-is: Spec.lhs 90 | build-depends: base, clifford, hspec, numeric-prelude, QuickCheck, nats 91 | 92 | 93 | benchmark basic-ops 94 | type: exitcode-stdio-1.0 95 | hs-source-dirs: bench 96 | main-is: benchmarks.hs 97 | build-depends: base, clifford, criterion, numeric-prelude, stream-fusion, compensated, deepseq 98 | -- -optlo-O3 99 | ghc-options: -fllvm -fexcess-precision -optlc-O=3 -O3 -threaded -rtsopts -feager-blackholing 100 | default-language: Haskell2010 101 | -------------------------------------------------------------------------------- /examples/Pendulum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude, NoMonomorphismRestriction, DataKinds, FlexibleInstances #-} 2 | import NumericPrelude (Double, fst, snd, ($), (.), seq, id, show) 3 | import Prelude (getLine, putStrLn) 4 | import Algebra.Transcendental 5 | import Data.List.Stream 6 | import Numeric.Clifford.Multivector 7 | import Algebra.Ring 8 | import Algebra.Additive 9 | import Algebra.Field 10 | import Numeric.Clifford.NumericIntegration.DefaultIntegrators 11 | import Numeric.Clifford.Blade 12 | import Control.Monad 13 | import Control.Lens 14 | import Graphics.Rendering.Chart 15 | import Data.Colour 16 | import Data.Colour.Names 17 | import Data.Default.Class 18 | import Graphics.Rendering.Chart.Backend.Cairo 19 | import Numeric.Compensated 20 | import Control.DeepSeq 21 | import MathObj.Wrapper.Haskell98 22 | import Debug.Trace 23 | import Data.String 24 | import System.Remote.Monitoring 25 | 26 | comp a = Cons (fadd a 0.0 compensated) 27 | --comp = id 28 | 29 | m = scalar 1 :: E3VectorComp 30 | l = scalar 2 :: E3VectorComp 31 | g = scalar 9.801 :: E3VectorComp 32 | ml = m*l 33 | mgl = -g*ml 34 | mll = ml*l 35 | pendulum t [p,theta] = [ mgl* sin theta, p / mll] 36 | 37 | integrator = gaussLegendreFourthOrderComp (comp 0.01) pendulum 38 | hamiltonian [ p', theta'] = extract $ magnitude $ (p*p/ (2*mll)) + mgl* cos theta where 39 | p = scalar $ comp p' 40 | theta = scalar $ comp theta' 41 | 42 | 43 | initialConditions = (0,[zero::E3VectorComp, scalar $ comp (0.3)]) 44 | 45 | history = take 20001 $ iterate integrator initialConditions 46 | 47 | extract = uncompensated . decons 48 | --extract = id 49 | plottableFormat :: [(Double,Double,Double)] 50 | plottableFormat = map ((\ (t, ([BladeSum [Blade a []],BladeSum [Blade b []]])) -> (extract t,extract a,extract b) ) ) history 51 | 52 | chart = toRenderable layout 53 | where 54 | momentum = plot_lines_values .~ [ ( map (\(t,p,_) -> (t,p)) plottableFormat )] 55 | $ plot_lines_style . line_color .~ opaque blue 56 | $ plot_lines_title .~ "momentum" 57 | $ def 58 | 59 | angle = plot_lines_style . line_color .~ (opaque red) 60 | $ plot_lines_values .~ [ ( map (\(t,_,theta) -> (t,theta)) plottableFormat )] 61 | $ plot_lines_title .~ "angle" 62 | $ def 63 | energy = plot_lines_values .~ [ ( map (\(t,p,theta) -> (t,hamiltonian [p,theta])) plottableFormat )] 64 | $ plot_lines_style . line_color .~ opaque pink 65 | $ plot_lines_title .~ "energy" 66 | $ def 67 | layout = layout_title .~ "Pendulum" 68 | $ layout_plots .~ [toPlot momentum, 69 | toPlot angle, 70 | toPlot energy] 71 | $ def 72 | 73 | main = do 74 | -- forkServer ( fromString "localhost") 8000 75 | renderableToFile def chart "pendulum.png" 76 | -------------------------------------------------------------------------------- /papers/Liszka and Orkisz - 1980 - The finite difference method at arbitrary irregular grids and its application in applied mechanics.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/spacekitteh/haskell-clifford/e0500cd816df1803b96dbeaee61decbded24dcb2/papers/Liszka and Orkisz - 1980 - The finite difference method at arbitrary irregular grids and its application in applied mechanics.pdf -------------------------------------------------------------------------------- /papers/S0025-5718-1988-0935077-0.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/spacekitteh/haskell-clifford/e0500cd816df1803b96dbeaee61decbded24dcb2/papers/S0025-5718-1988-0935077-0.pdf -------------------------------------------------------------------------------- /src/Numeric/Clifford/Blade.lhs: -------------------------------------------------------------------------------- 1 | \documentclass{article} 2 | %include polycode.fmt 3 | \usepackage{fontspec} 4 | \usepackage{amsmath} 5 | \usepackage{unicode-math} 6 | \usepackage{lualatex-math} 7 | \setmainfont{latinmodern-math.otf} 8 | \setmathfont{latinmodern-math.otf} 9 | \usepackage{verbatim} 10 | \author{Sophie Taylor} 11 | \title{haskell-clifford: A Haskell Clifford algebra dynamics library} 12 | \begin{document} 13 | 14 | So yeah. This is a Clifford number representation. I will fill out the documentation more fully and stuff once the design has stabilised. 15 | 16 | I am basing the design of this on Issac Trotts' geometric algebra library.\cite{hga} 17 | 18 | Let us begin. We are going to use the Numeric Prelude because it is (shockingly) nicer for numeric stuff. 19 | 20 | \begin{code} 21 | {-# LANGUAGE NoImplicitPrelude, FlexibleContexts, RankNTypes, ScopedTypeVariables, DeriveDataTypeable #-} 22 | {-# LANGUAGE NoMonomorphismRestriction, UnicodeSyntax, GADTs #-} 23 | {-# LANGUAGE FlexibleInstances, UnicodeSyntax, GADTs, KindSignatures, DataKinds #-} 24 | {-# LANGUAGE TemplateHaskell, StandaloneDeriving, TypeOperators #-} 25 | {-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-} 26 | \end{code} 27 | Clifford algebras are a module over a ring. They also support all the usual transcendental functions. 28 | \begin{code} 29 | module Numeric.Clifford.Blade where 30 | 31 | import NumericPrelude hiding (iterate, head, map, tail, reverse, scanl, zipWith, drop, (++), filter, null, length, foldr, foldl1, zip, foldl, concat, (!!), concatMap,any, repeat, replicate, elem, replicate, foldr1, abs) 32 | import Algebra.Laws hiding (zero) 33 | import Algebra.Absolute 34 | import Algebra.Additive 35 | import Control.DeepSeq 36 | import Algebra.Ring 37 | import Data.Serialize 38 | import Data.Word 39 | import Data.List.Stream 40 | import Data.Permute (sort, isEven) 41 | import Numeric.Natural 42 | import qualified NumericPrelude.Numeric as NPN hiding (abs) 43 | import Test.QuickCheck 44 | import Control.Lens hiding (indices) 45 | import Data.DeriveTH 46 | import GHC.TypeLits hiding (isEven, isOdd) 47 | import Data.Proxy 48 | import GHC.Real (fromIntegral, toInteger) 49 | import Algebra.Field 50 | import Data.MemoTrie 51 | import Numeric.Clifford.Internal 52 | import Numeric.Compensated 53 | import Prelude.Unicode 54 | \end{code} 55 | 56 | 57 | The first problem: How to represent basis blades. One way to do it is via generalised Pauli matrices. Another way is to use lists, which we will do because this is Haskell. >:0 58 | 59 | \texttt{bScale} is the amplitude of the blade. \texttt{bIndices} are the indices for the basis. 60 | \begin{code} 61 | 62 | 63 | data Blade (p ∷ Nat) (q ∷ Nat) f where 64 | Blade ∷ forall (p∷Nat) (q∷Nat) f . (KnownNat p, KnownNat q, Algebra.Field.C f) ⇒ {_scale ∷ f, _indices ∷ [Natural]} → Blade p q f 65 | 66 | type STBlade = Blade 3 1 Double 67 | type E3Blade = Blade 3 0 Double 68 | --scale ∷ Lens (Blade p q f) (Blade p q g) f g 69 | scale = lens _scale (\b@(Blade _ ind) v → Blade v ind) 70 | indices ∷ Lens' (Blade p q f) [Natural] 71 | indices = lens _indices (\blade v → blade {_indices = v}) 72 | dimension ∷ forall (p∷Nat) (q∷Nat) f. (KnownNat p, KnownNat q) ⇒ Blade p q f → (Natural,Natural) 73 | dimension _ = (toNatural ((GHC.Real.fromIntegral $ natVal (Proxy∷Proxy p))∷Word),toNatural((GHC.Real.fromIntegral $ natVal (Proxy ∷ Proxy q))∷Word)) 74 | 75 | {-# INLINE bScale #-} 76 | bScale ∷ Blade p q f → f 77 | bScale b@(Blade _ _) = b^.scale 78 | {-# INLINE bIndices #-} 79 | bIndices ∷ Blade p q f → [Natural] 80 | bIndices b = b^.indices 81 | instance (Control.DeepSeq.NFData f) ⇒ Control.DeepSeq.NFData (Blade p q f) 82 | instance(Show f) ⇒ Show (Blade p q f) where 83 | --TODO: Do this with HaTeX 84 | show (Blade scale indices) = pref ++ if null indices then "" else basis where 85 | pref = show scale 86 | basis = foldr (++) "" textIndices 87 | textIndices = map vecced indices 88 | vecced index = "\\vec{e_{" ++ show index ++ "}}" 89 | 90 | 91 | instance (Algebra.Additive.C f, Eq f) ⇒ Eq (Blade p q f) where 92 | a == b = aScale ≡ bScale ∧ aIndices ≡ bIndices where 93 | (Blade aScale aIndices) = bladeNormalForm a 94 | (Blade bScale bIndices) = bladeNormalForm b 95 | 96 | \end{code} 97 | 98 | For example, a scalar could be constructed like so: \texttt{Blade s []} 99 | \begin{code} 100 | scalarBlade ∷ (Algebra.Field.C f, KnownNat p, KnownNat q) ⇒ f → Blade p q f 101 | scalarBlade d = Blade d [] 102 | 103 | zeroBlade ∷ (Algebra.Field.C f, KnownNat p, KnownNat q ) ⇒ Blade p q f 104 | zeroBlade = scalarBlade zero 105 | 106 | bladeNonZero ∷ (Algebra.Additive.C f, Eq f) ⇒ Blade p q f → Bool 107 | bladeNonZero (Blade s _) = s ≢ Algebra.Additive.zero 108 | 109 | bladeNegate ∷ (Algebra.Additive.C f) ⇒ Blade p q f → Blade p q f 110 | bladeNegate b@(Blade _ _) = b&scale%~negate 111 | 112 | {-# INLINE bladeScaleLeft #-} 113 | {-# SPECIALISE bladeScaleLeft∷Double→STBlade → STBlade #-} 114 | {-# SPECIALISE bladeScaleLeft∷Double→E3Blade → E3Blade #-} 115 | bladeScaleLeft ∷ f → Blade p q f → Blade p q f 116 | bladeScaleLeft s (Blade f ind) = Blade (s `mul` f) ind 117 | bladeScaleRight ∷ f → Blade p q f → Blade p q f 118 | {-# INLINE bladeScaleRight #-} 119 | {-# SPECIALISE bladeScaleRight∷Double→STBlade → STBlade #-} 120 | {-# SPECIALISE bladeScaleRight∷Double→E3Blade → E3Blade #-} 121 | bladeScaleRight s (Blade f ind) = Blade (f `mul` s) ind 122 | \end{code} 123 | 124 | However, the plain data constructor should never be used, for it doesn't order them by default. It also needs to represent the vectors in an ordered form for efficiency and niceness. Further, due to skew-symmetry, if the vectors are in an odd permutation compared to the normal form, then the scale is negative. Additionally, since $\vec{e}_k^2 = 1$, pairs of them should be removed. 125 | 126 | \begin{align} 127 | \vec{e}_1∧...∧\vec{e}_k∧...∧\vec{e}_k∧... = 0\\ 128 | \vec{e}_2∧\vec{e}_1 = -\vec{e}_1∧\vec{e}_2\\ 129 | \vec{e}_k^2 = 1 130 | \end{align} 131 | 132 | \begin{code} 133 | 134 | {-#INLINE bladeNormalForm#-} 135 | {-#SPECIALISE INLINE bladeNormalForm∷E3Blade → E3Blade #-} 136 | {-#SPECIALISE INLINE bladeNormalForm ∷ STBlade → STBlade #-} 137 | bladeNormalForm ∷ ∀ (p∷Nat) (q∷Nat) f. Blade p q f → Blade p q f 138 | bladeNormalForm (Blade scale indices) = result 139 | where 140 | result = if (any (\i → (GHC.Real.toInteger i) ≥ d) indices) then zeroBlade else Blade scale' newIndices 141 | p' = (natVal (Proxy ∷ Proxy p)) ∷ Integer 142 | q' = (natVal (Proxy ∷ Proxy q)) ∷ Integer 143 | d = p' + q' 144 | scale' = if doNotNegate then scale else negate scale 145 | (newIndices, doNotNegate) = sortIndices (indices,q') 146 | 147 | sortIndices ∷ ([Natural],Integer) → ([Natural],Bool) 148 | sortIndices = memo sortIndices' where 149 | sortIndices' ∷ ([Natural],Integer) → ([Natural],Bool) 150 | sortIndices' (indices,q') = (uniqueSorted, doNotNegate) where 151 | (sorted, perm) = Data.Permute.sort numOfIndices indices 152 | numOfIndices = length indices 153 | doNotNegate = (isEven perm) ≢ (negated) 154 | (uniqueSorted,negated) = removeDupPairs [] sorted False where 155 | removeDupPairs ∷ [Natural] → [Natural] → Bool → ([Natural],Bool) 156 | removeDupPairs accum [] negated = (accum,negated) 157 | removeDupPairs accum [x] negated = (accum++[x],negated) 158 | removeDupPairs accum (x:y:rest) negated | x ≡ y = 159 | if GHC.Real.toInteger x < q' 160 | then removeDupPairs accum rest (not negated) 161 | else removeDupPairs accum rest negated 162 | | otherwise = removeDupPairs (accum++[x]) (y:rest) negated 163 | \end{code} 164 | 165 | What is the grade of a blade? Just the number of indices. 166 | 167 | \begin{code} 168 | grade ∷ Blade p q f → Integer 169 | grade = GHC.Real.toInteger . length . bIndices 170 | 171 | bladeIsOfGrade ∷ Blade p q f → Integer → Bool 172 | blade `bladeIsOfGrade` k = grade blade ≡ k 173 | 174 | bladeGetGrade ∷ Integer → Blade p q f → Blade p q f 175 | bladeGetGrade k blade@(Blade _ _) = 176 | if blade `bladeIsOfGrade` k then blade else zeroBlade 177 | \end{code} 178 | 179 | 180 | 181 | First up for operations: Blade multiplication. This is no more than assembling orthogonal vectors into k-vectors. 182 | 183 | \begin{code} 184 | {-#INLINE bladeMul #-} 185 | {-#SPECIALISE INLINE bladeMul ∷ STBlade → STBlade → STBlade #-} 186 | {-#SPECIALISE INLINE bladeMul ∷ E3Blade → E3Blade → E3Blade #-} 187 | bladeMul ∷ Blade p q f → Blade p q f→ Blade p q f 188 | bladeMul x@(Blade _ _) y@(Blade _ _)= bladeNormalForm $ Blade ((bScale x) `mul` (bScale y)) (bIndices x ++ bIndices y) 189 | 190 | {-# RULES 191 | "mulCompensable" mul = mulDouble 192 | #-} 193 | mul ∷ Algebra.Ring.C f ⇒ f → f → f 194 | mul x y = x*y 195 | 196 | {-#SPECIALISE mulCompensable ∷ Double → Double → Double #-} 197 | {-#SPECIALISE INLINE mulCompensable ∷ Float → Float → Float #-} 198 | mulDouble ∷ Double → Double → Double 199 | mulDouble = mulCompensable 200 | mulCompensable ∷ (Algebra.Ring.C f, Compensable f) ⇒ f → f → f 201 | mulCompensable x y = uncompensated (times x y compensated) 202 | 203 | multiplyBladeList ∷ (KnownNat p, KnownNat q, Algebra.Field.C f) ⇒ [Blade p q f] → Blade p q f 204 | multiplyBladeList [] = error "Empty blade list!" 205 | multiplyBladeList (a:[]) = a 206 | multiplyBladeList a = bladeNormalForm (Blade scale indices) where 207 | indices = concatMap bIndices a 208 | scale = (foldl1' (*) (map bScale a)) 209 | {-# RULES 210 | "mulBladeListComp" multiplyBladeList = multiplyBladeListDouble 211 | #-} 212 | multiplyBladeListDouble ∷ (KnownNat p, KnownNat q) ⇒ [Blade p q Double] → Blade p q Double 213 | multiplyBladeListDouble = multiplyBladeListCompensated 214 | multiplyBladeListCompensated ∷ (KnownNat p, KnownNat q, Algebra.Field.C f, Compensable f) ⇒ [Blade p q f] → Blade p q f 215 | multiplyBladeListCompensated [] = error "Empty blade list!" 216 | multiplyBladeListCompensated (a:[]) = a 217 | multiplyBladeListCompensated a = bladeNormalForm (Blade scale indices) where 218 | indices = concatMap bIndices a 219 | scale = (foldr (*^) (compensated one zero) (map bScale a)) & uncompensated 220 | 221 | 222 | \end{code} 223 | 224 | Next up: The outer (wedge) product, denoted by $∧$ :3 225 | 226 | \begin{code} 227 | bWedge ∷ Blade p q f → Blade p q f → Blade p q f 228 | bWedge x y = bladeNormalForm $ bladeGetGrade k xy 229 | where 230 | k = grade x + grade y 231 | xy = bladeMul x y 232 | 233 | \end{code} 234 | 235 | Now let's do the inner (dot) product, denoted by $⋅$ :D 236 | 237 | 238 | \begin{code} 239 | bDot ∷Blade p q f → Blade p q f → Blade p q f 240 | bDot x y = bladeNormalForm $ bladeGetGrade k xy 241 | where 242 | k = abs (grade x - grade y) 243 | xy = bladeMul x y 244 | 245 | propBladeDotAssociative ∷ (Algebra.Additive.C f, Eq f) ⇒ Blade p q f → Blade p q f → Blade p q f → Bool 246 | propBladeDotAssociative = Algebra.Laws.associative bDot 247 | 248 | \end{code} 249 | 250 | These are the three fundamental operations on basis blades. 251 | 252 | Now for linear combinations of (possibly different basis) blades. To start with, let's order basis blades: 253 | 254 | \begin{code} 255 | instance (Algebra.Additive.C f, Ord f) ⇒ Ord (Blade p q f) where 256 | compare a b | bIndices a ≡ bIndices b = compare (bScale a) (bScale b) 257 | | otherwise = compareIndices (bIndices a) (bIndices b) 258 | 259 | compareIndices ∷ [Natural] → [Natural] → Ordering 260 | compareIndices = memo compareIndices' where 261 | compareIndices' a b = case compare (length a) (length b) of 262 | LT → LT 263 | GT → GT 264 | EQ → compare a b 265 | 266 | 267 | instance (KnownNat p, KnownNat q, Algebra.Field.C f, Arbitrary f) ⇒ Arbitrary (Blade p q f) where 268 | arbitrary = do 269 | let p'' = (natVal (Proxy ∷ Proxy p)) ∷ Integer 270 | let q'' = (natVal (Proxy ∷ Proxy q)) 271 | let d = p'' + q'' 272 | let maxLength = (2^d - 1) ∷ Integer 273 | scale ← arbitrary 274 | listSize ← choose (0, maxLength) 275 | indices ← vectorOf (NPN.fromIntegral listSize) (resize (NPN.fromIntegral d-1) arbitrary ) 276 | return (Blade scale indices) 277 | 278 | \end{code} 279 | \bibliographystyle{IEEEtran} 280 | \bibliography{biblio.bib} 281 | \end{document} 282 | -------------------------------------------------------------------------------- /src/Numeric/Clifford/ClassicalMechanics.lhs: -------------------------------------------------------------------------------- 1 | \documentclass{article} 2 | %include polycode.fmt 3 | \usepackage{fontspec} 4 | \usepackage{amsmath} 5 | \usepackage{unicode-math} 6 | \usepackage{lualatex-math} 7 | \setmainfont{latinmodern-math.otf} 8 | \setmathfont{latinmodern-math.otf} 9 | \usepackage{verbatim} 10 | \author{Sophie Taylor} 11 | \title{haskell-clifford: A Haskell Clifford algebra dynamics library} 12 | \begin{document} 13 | 14 | This is the classical mechanics portion of the library. 15 | 16 | \begin{code} 17 | {-# LANGUAGE NoImplicitPrelude, FlexibleContexts, RankNTypes, ScopedTypeVariables, DeriveDataTypeable #-} 18 | {-# LANGUAGE NoMonomorphismRestriction, UnicodeSyntax, GADTs, KindSignatures, DataKinds #-} 19 | {-# LANGUAGE FlexibleInstances, TypeOperators #-} 20 | {-# LANGUAGE TemplateHaskell #-} 21 | {-# LANGUAGE MultiParamTypeClasses #-} 22 | {-# OPTIONS_HADDOCK show-extensions #-} 23 | \end{code} 24 | %if False 25 | \begin{code} 26 | \end{code} 27 | %endif 28 | 29 | \begin{code} 30 | module Numeric.Clifford.ClassicalMechanics where 31 | import Numeric.Clifford.Multivector as MV 32 | import Numeric.Clifford.Blade 33 | import GHC.TypeLits 34 | import Data.Proxy 35 | import NumericPrelude hiding (iterate, head, map, tail, reverse, scanl, zipWith, drop, (++), filter, null, length, foldr, foldl1, zip, foldl, concat, (!!), concatMap,any, repeat, replicate, elem, replicate, all, (.) ) 36 | import Algebra.Absolute 37 | import Algebra.Algebraic 38 | import Algebra.Additive 39 | import Algebra.Ring 40 | import Algebra.ToInteger 41 | import Algebra.Module 42 | import Algebra.Field 43 | import Data.List.Stream 44 | import Numeric.Natural 45 | import qualified Data.Vector as V 46 | import NumericPrelude.Numeric (sum) 47 | import qualified NumericPrelude.Numeric as NPN 48 | import Test.QuickCheck 49 | import Math.Sequence.Converge (convergeBy) 50 | import Number.Ratio hiding (scale) 51 | import Algebra.ToRational 52 | import Control.Lens hiding (indices) 53 | import Control.Exception (assert) 54 | import Data.Maybe 55 | import Data.DeriveTH 56 | import Data.Word 57 | import Numeric.Clifford.Internal 58 | import Numeric.Clifford.LinearOperators 59 | import Control.Applicative 60 | import Data.Monoid 61 | import Data.Dynamic 62 | import Data.Data 63 | import Control.Category 64 | 65 | class Energy t a where 66 | 67 | class Hamiltonian x p t a where 68 | 69 | type Hamil x p t = (PhaseSpace x p a, Energy t b) ⇒ a → b 70 | class PhaseSpace x p a where 71 | 72 | class StateSpace x v a where 73 | 74 | class ConfigurationSpace q qdot a where 75 | 76 | class PhaseSpacePath t x p a where 77 | 78 | instance (PhaseSpace x p a) ⇒ PhaseSpacePath t x p (t → a) where 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | nonEqualFrames = "Non-equal reference frames! Insert code here to translate between them! :) Should really make reference frames as types and then have type families to convert between them :v :v :v" 90 | 91 | 92 | 93 | \end{code} 94 | 95 | Now to make a physical object. 96 | \begin{code} 97 | data ReferenceFrame (p::Nat) (q::Nat) t = RelativeFrame { frameName :: String 98 | , euclideanMove :: EuclideanMove p q t 99 | , velocityRelToParentFrame :: Multivector p q t 100 | , angularVelocityRelToParentFrame :: Multivector p q t 101 | , parent :: ReferenceFrame p q t 102 | } 103 | | GlobalAbsoluteFrame deriving (Eq, Show) 104 | 105 | 106 | getRigidDisplacementRelToInertial :: (Algebra.Field.C t, Ord t, KnownNat p, KnownNat q) => ReferenceFrame p q t -> EuclideanMove p q t 107 | getRigidDisplacementRelToInertial GlobalAbsoluteFrame = mempty 108 | --getRigidDisplacementRelToInertial (RelativeFrame _ displacement mother) = displacement <> (getRigidDisplacementRelToInertial mother) 109 | 110 | getFrameTransformation :: forall (p::Nat) (q::Nat) t . (Algebra.Field.C t, Ord t, KnownNat p, KnownNat q) => ReferenceFrame p q t -> ReferenceFrame p q t -> EuclideanMove p q t 111 | getFrameTransformation r' r = undefined 112 | 113 | {-data InertialFrame (p::Nat) (q::Nat) f t = InertialFrame {objects :: t, changeFrame :: t -> EuclideanMove p q f -> t, frame :: ReferenceFrame p q f} 114 | 115 | 116 | instance Functor (InertialFrame p q f) where 117 | fmap func (InertialFrame objs changeFrame frame) = InertialFrame (func objs) (changeFrame . func) frame 118 | 119 | instance (KnownNat p, KnownNat q) => Applicative (InertialFrame p q f) where 120 | pure a = InertialFrame a GlobalAbsoluteFrame where 121 | (<*>) (InertialFrame func trans1 frame1) (InertialFrame objs trans2 frame2) = if (name frame1)==(name frame2) 122 | then InertialFrame (func objs) frame1 123 | else InertialFrame (trans2 (func objs) (getFrameTransformation frame2 frame1)) trans2 frame1 124 | 125 | 126 | instance (KnownNat p, KnownNat q, Algebra.Field.C f, Ord f) => Monad (InertialFrame p q f) where 127 | return = pure 128 | (>>=) (InertialFrame objA changeFrameA frameA) func = undefined where 129 | (InertialFrame objB changeFrameB frameB) = func objA 130 | 131 | -} 132 | 133 | a `cross` b = (negate psuedoScalar) * (a `wedge` b) 134 | 135 | 136 | 137 | data PhysicalVector (p::Nat) (q::Nat) t = PhysicalVector {radius :: Multivector p q t, referenceFrame :: ReferenceFrame p q t} 138 | 139 | 140 | 141 | 142 | 143 | {-data RigidBody (p::Nat) (q::Nat) f where 144 | RigidBody:: (Algebra.Field.C f, Algebra.Module.C f (Multivector p q f)) => {bodyName::String, frame::ReferenceFrame p q f, mass :: f, inertia :: Multivector p q f, position :: Multivector p q f, attitude :: Multivector p q f, velocity :: Multivector p q f, angularVelocity :: Multivector p q f 145 | } -> RigidBody p q f 146 | -} 147 | --makeLenses ''RigidBody doesn't actually work 148 | {- Things to do: 149 | 4. create a 1-form type 150 | 5. figure a way to take exterior product of 1 forms at a type level so i can just go like: omega = df1 ^ df2 ^ df ; omega a b c 151 | -} 152 | 153 | 154 | 155 | 156 | 157 | data Variable f a = Variable{symbol ∷ String, access ∷ Lens' f a } 158 | 159 | 160 | newtype Position p q f = Position {unPosition ∷ Multivector p q f} 161 | newtype Velocity p q f = Velocity {unVelocity ∷ Multivector p q f} 162 | newtype Force p q f = Force {unForce ∷ Multivector p q f} 163 | newtype Mass p q f = Mass {unMass :: Multivector p q f} 164 | newtype Time f = Time {unTime ∷ f} 165 | newtype Momentum p q f = Momentum {unMomentum ∷ Multivector p q f} 166 | newtype Charge p q f = Charge {unCharge ∷ Multivector p q f} 167 | newtype Spinor p q f = Spinor {unSpinor ∷ Multivector p q f} 168 | newtype Inertia p q f = Inertia {unInertia :: Multivector p q f} 169 | newtype AngularVelocity p q f = AngularVelocity {unAngularVelocity :: Multivector p q f} 170 | newtype AngularMomentum p q f = AngularMomentum {unAngularMomentum :: Multivector p q f} 171 | class Entity a where 172 | name ∷ Lens' a String 173 | 174 | 175 | class Entity a ⇒ Body (p∷Nat) (q∷Nat) f a where 176 | frame :: Lens' a (ReferenceFrame p q f) 177 | position :: Lens' a (Position p q f) 178 | velocity :: Lens' a (Velocity p q f) 179 | momentum :: Lens' a (Momentum p q f) 180 | 181 | class (Algebra.Field.C f, Ord f, KnownNat p, KnownNat q, Body p q f a) => MassiveBody p q f a where 182 | mass :: Lens' a (Mass p q f) 183 | 184 | 185 | 186 | 187 | data PointMass p q f = PointMass { _PointMassName ∷ String, _PointMassFrame ∷ ReferenceFrame p q f, _PointMassPosition ∷ Position p q f, _PointMassVelocity ∷ Velocity p q f, _PointMassMass ∷ Mass p q f, _PointMassMomentum ∷ Momentum p q f} 188 | 189 | instance Entity (PointMass p q f) where 190 | name = lens _PointMassName (\p n → p {_PointMassName = n}) 191 | 192 | instance Body p q f (PointMass p q f) where 193 | frame = lens _PointMassFrame (\p f → p {_PointMassFrame = f}) 194 | position = lens _PointMassPosition (\p pos → p {_PointMassPosition = pos}) 195 | velocity = lens _PointMassVelocity (\p v → p {_PointMassVelocity = v}) 196 | momentum = lens _PointMassMomentum (\p mom → p {_PointMassMomentum = mom}) 197 | 198 | 199 | 200 | instance (Algebra.Field.C f, Ord f, KnownNat p, KnownNat q) ⇒ MassiveBody p q f (PointMass p q f) where 201 | mass = lens _PointMassMass (\p m → p {_PointMassMass = m}) 202 | 203 | 204 | class (Algebra.Field.C f, KnownNat p, KnownNat q, Ord f, MassiveBody p q f a) ⇒ ChargedBody p q f a where 205 | electricCharge ∷ Lens' a (Charge p q f) 206 | magneticCharge ∷ Lens' a (Charge p q f) 207 | 208 | class (MassiveBody p q f a) ⇒ RigidBody p q f a where 209 | attitude ∷ Lens' a (Spinor p q f) 210 | angularVelocity ∷ Lens' a (AngularVelocity p q f) 211 | angularMomentum ∷ Lens' a (AngularMomentum p q f) 212 | inertia ∷ Lens' a (Inertia p q f) 213 | 214 | class (Algebra.Field.C f, Ord f, MassiveBody p q f a) ⇒ AerodynamicBody p q f a where 215 | liftCoefficient ∷ a → Velocity p q f → Multivector p q f 216 | dragCoefficient ∷ a → Velocity p q f → Multivector p q f 217 | shearCoefficient ∷ a → Velocity p q f → Multivector p q f 218 | shearCoefficient a = const zero 219 | 220 | 221 | class (Entity a) ⇒ Region p q f a where 222 | isInside :: forall b . Body p q f b => a -> b -> Bool 223 | 224 | -- | Time -> Item -> Force 225 | type ForceFunction p q f a = Time f → a → Force p q f 226 | 227 | class Region p q f a ⇒ ForceField p q f a where 228 | actOn :: ForceFunction p q f a 229 | 230 | 231 | 232 | 233 | -- perhaps an array of getters on objects? 234 | 235 | 236 | 237 | data Inhabitant = ABody {b∷Dynamic} 238 | | ARegion {r∷Dynamic} deriving ( Show, Typeable) 239 | 240 | 241 | class (Functor funct) ⇒ World (p∷Nat) (q∷Nat) fieldType funct a where 242 | asFunctor ∷ a → funct Inhabitant 243 | time ∷ Lens' a (Time fieldType) 244 | 245 | data EuclideanWorld fieldType 246 | 247 | instance World 3 0 fieldType [] (EuclideanWorld fieldType) where 248 | asFunctor w = [] 249 | 250 | 251 | 252 | 253 | \end{code} 254 | \bibliographystyle{IEEEtran} 255 | \bibliography{biblio.bib} 256 | \end{document} 257 | -------------------------------------------------------------------------------- /src/Numeric/Clifford/ExpressionTree.lhs: -------------------------------------------------------------------------------- 1 | \documentclass{article} 2 | %include polycode.fmt 3 | \usepackage{fontspec} 4 | \usepackage{amsmath} 5 | \usepackage{unicode-math} 6 | \usepackage{lualatex-math} 7 | \setmainfont{latinmodern-math.otf} 8 | \setmathfont{latinmodern-math.otf} 9 | \usepackage{verbatim} 10 | \author{Sophie Taylor} 11 | \title{haskell-clifford: A Haskell Clifford algebra dynamics library} 12 | \begin{document} 13 | 14 | Expression tree! 15 | 16 | \begin{code} 17 | {-# LANGUAGE NoImplicitPrelude, FlexibleContexts, RankNTypes, ScopedTypeVariables, DeriveDataTypeable #-} 18 | {-# LANGUAGE NoMonomorphismRestriction, UnicodeSyntax, GADTs, InstanceSigs, AllowAmbiguousTypes#-} 19 | {-# LANGUAGE FlexibleInstances, StandaloneDeriving, KindSignatures, DataKinds, PolyKinds #-} 20 | {-# LANGUAGE TemplateHaskell, TypeOperators, DeriveFunctor, DeriveTraversable #-} 21 | {-# LANGUAGE MultiParamTypeClasses, UndecidableInstances, DeriveFoldable, PatternSynonyms #-} 22 | {-# OPTIONS_HADDOCK show-extensions #-} 23 | \end{code} 24 | 25 | 26 | \begin{code} 27 | module Numeric.Clifford.ExpressionTree where 28 | import NumericPrelude 29 | import Number.Ratio 30 | import Algebra.Ring 31 | import Algebra.Additive 32 | import Algebra.Field 33 | import Algebra.Algebraic 34 | import GHC.TypeLits 35 | import Data.Typeable 36 | import Data.Data 37 | import Data.Foldable 38 | import Data.Traversable 39 | import Data.Monoid.Unicode 40 | --import Control.Applicative 41 | import Data.Eq.Unicode 42 | import Data.Bool.Unicode 43 | import Data.Maybe 44 | import Data.Functor.Foldable 45 | import Data.Type.Equality 46 | import qualified Data.Map 47 | import Data.List.Stream 48 | import Data.Bool.Unicode 49 | 50 | data Symbolic = MakeSymbol {_unicodeName ∷ String, _texName ∷ String} deriving ( Eq, Typeable, Data, Ord ) 51 | 52 | instance Show (Symbolic) where 53 | show = _unicodeName 54 | 55 | 56 | eval ∷ Algebra.Ring.C a ⇒ Env a → TExpr anno → a 57 | eval env = cata (evalAlg env) 58 | 59 | type Env a = Data.Map.Map Symbolic a 60 | evalAlg ∷ Algebra.Ring.C a ⇒ Env a → ExprF anno a → a 61 | evalAlg env = eval' where 62 | eval' (Const var) = fromJust $ Data.Map.lookup var env 63 | eval' (Sum xs) = Data.List.Stream.foldr1 (+) xs 64 | eval' (Product a b) = a * b 65 | eval' (UnaryOperator op val) = evalUnary op val 66 | eval' (Add a b) = a + b 67 | eval' (Subtract a b) = a - b 68 | 69 | evalUnary ∷ Algebra.Additive.C a ⇒ UnaryOperator → a → a 70 | evalUnary Negate val = negate val 71 | 72 | pattern FAdd a b= Fix (Add a b) 73 | 74 | simplify ∷ TExpr anno → TExpr anno 75 | simplify = cata alg where 76 | alg (Add a b) = simplifyAdd a b 77 | alg (Subtract a b) = simplifySubtract a b 78 | alg a = Fix a 79 | 80 | simplifyAdd (Fix (Sum xs)) s = Fix (Sum (s:xs)) 81 | simplifyAdd s (Fix (Sum xs)) = Fix (Sum (s:xs)) 82 | simplifyAdd a (FAdd b c) = Fix (Sum [a,b,c]) 83 | simplifyAdd (FAdd a b) c = Fix (Sum [a,b,c]) 84 | simplifyAdd a b = Fix (Add a b) 85 | 86 | simplifySubtract a b | a ≡ b = Fix Zero 87 | | otherwise = Fix (Subtract a b) 88 | 89 | data ExprF a self where 90 | Ratio ∷ Rational → ExprF a self 91 | Const :: Symbolic → ExprF a self 92 | Zero ∷ ExprF a self 93 | Add :: self → self → ExprF a self 94 | Subtract ∷ self → self→ ExprF a self 95 | Sum :: [self] → ExprF a self 96 | Product :: self → self → ExprF a self 97 | Division ∷ self → self → ExprF a self 98 | Tuple ∷ [self] → ExprF a self 99 | Polynomial ∷ self → [PowerSeriesCoefficient a self] → ExprF a self 100 | Apply ∷ Operator → [self] → ExprF a self 101 | Power :: self → self → ExprF a self 102 | Psuedoscalar ∷ ExprF a self 103 | Exp ∷ self → ExprF a self 104 | Cos ∷ self → ExprF a self 105 | UnaryOperator ∷ UnaryOperator → self → ExprF a self 106 | BinaryOperator ∷ BinaryOperator → self → self → ExprF a self 107 | 108 | makeSymbol unicode tex = Fix (Const (MakeSymbol unicode tex)) 109 | instance Algebra.Additive.C (TExpr a) where 110 | a + b = Fix $ Add a b 111 | zero = Fix Zero 112 | negate a = Fix $ UnaryOperator Negate a 113 | a - b = Fix $ Subtract a b 114 | 115 | instance Algebra.Ring.C (TExpr a ) where 116 | a * b = Fix (Product a b) 117 | fromInteger i = Fix $ Numeric.Clifford.ExpressionTree.Ratio (fromInteger i) 118 | a ^ b = Fix $ a `Power` (fromInteger b) 119 | 120 | instance Algebra.Field.C (TExpr a ) where 121 | a / b = Fix (Division a b) 122 | 123 | data UnaryOperator = Negate deriving (Eq, Show, Data, Typeable) 124 | 125 | data BinaryOperator = Dot 126 | | Wedge 127 | | Cross deriving (Eq,Show, Data, Typeable) 128 | 129 | 130 | deriving instance Typeable (Number.Ratio.T) 131 | deriving instance Data (Rational) 132 | deriving instance Show self ⇒ Show (ExprF a self) 133 | deriving instance Eq self ⇒ Eq (ExprF a self) 134 | deriving instance Functor (ExprF a) 135 | deriving instance (Data self, Typeable a) ⇒ Data (ExprF a self) 136 | deriving instance Typeable (ExprF) 137 | deriving instance Data.Foldable.Foldable (ExprF a) 138 | deriving instance Traversable (ExprF a) 139 | 140 | type TExpr a = Fix (ExprF a) 141 | 142 | deriving instance ( Data a, Typeable a) ⇒ Data (TExpr a) 143 | 144 | type Expr = TExpr () 145 | 146 | data PowerSeriesCoefficient a t = PowerSeriesCoefficient {_coefficient ∷ t, _power ∷ t} deriving (Eq, Show, Typeable,Functor, Traversable, Data.Foldable.Foldable) 147 | deriving instance ( Data t,Typeable a )⇒ Data (PowerSeriesCoefficient a t) 148 | 149 | 150 | 151 | data Operator = Integral Symbolic | Derivative Symbolic | Differential deriving (Eq, Show, Data, Typeable) 152 | 153 | 154 | 155 | --data Function where 156 | --Function ∷ {_boundVariables ∷ [Symbolic], _expr ∷ Expr } → Function 157 | 158 | --deriving instance Show (Function ) 159 | --deriving instance Eq (Function ) 160 | 161 | 162 | 163 | \end{code} -------------------------------------------------------------------------------- /src/Numeric/Clifford/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fllvm -fexcess-precision -optlo-O3 -O3 -optlc-O=3 -Wall #-} 2 | {-# LANGUAGE TypeOperators, TypeFamilies,CPP, ConstraintKinds, RankNTypes, DataKinds, FlexibleInstances, StandaloneDeriving #-} 3 | module Numeric.Clifford.Internal (myTrace, trie, untrie, enumerate, dimension, DefaultField, AllowableCliffordType, comp, showOutput) where 4 | import Numeric.Natural 5 | import Prelude hiding (head,tail, null, (++)) 6 | import Data.MemoTrie 7 | import Data.List.Stream 8 | import Control.Arrow 9 | import Data.Bits 10 | import Test.QuickCheck 11 | import Data.Word 12 | import GHC.TypeLits 13 | import Algebra.Field 14 | import qualified Debug.Trace as DebugTrace 15 | import Numeric.Compensated 16 | import MathObj.Wrapper.Haskell98 17 | import Algebra.Additive (zero) 18 | import Control.DeepSeq 19 | 20 | instance (Control.DeepSeq.NFData f) => Control.DeepSeq.NFData (MathObj.Wrapper.Haskell98.T (Compensated f)) 21 | comp a = Cons (compensated a zero) 22 | 23 | 24 | 25 | #ifdef DEBUG 26 | myTrace = DebugTrace.trace 27 | #else 28 | myTrace _ x = x 29 | #endif 30 | 31 | showOutput name x = myTrace ("output of " ++ name ++" is " ++ show x) x 32 | 33 | 34 | type AllowableCliffordType p q f = forall (p::Nat) (q::Nat) f. (Ord f, Algebra.Field.C f, KnownNat p, KnownNat q) 35 | type DefaultField = Double 36 | 37 | instance HasTrie Natural where 38 | newtype Natural :->: a = NaturalTrie ((Bool,[Bool]) :->: a) 39 | trie f = NaturalTrie (trie (f . unbitsZ)) 40 | untrie (NaturalTrie t) = untrie t . bitsZ 41 | enumerate (NaturalTrie t) = enum' unbitsZ t 42 | 43 | dimension :: Natural -> Natural -> Natural 44 | dimension p q = pred $ p + q 45 | 46 | instance Arbitrary Natural where 47 | arbitrary = sized $ \n -> 48 | let n' = abs n in 49 | fmap (toNatural . (\x -> (fromIntegral x)::Word)) (choose (0, n')) 50 | shrink = shrinkIntegral 51 | 52 | 53 | 54 | unbitsZ :: (Prelude.Num n, Bits n) => (Bool,[Bool]) -> n 55 | unbitsZ (headder,bs) = (unbits (headder:bs)) 56 | 57 | bitsZ :: (Prelude.Num n, Ord n, Bits n) => n -> (Bool,[Bool]) 58 | bitsZ i = (h, t ) where 59 | theBits = bits i 60 | (h,t) = if null theBits 61 | then (False,[]) 62 | else (head theBits, tail theBits) 63 | bits :: (Prelude.Num t, Bits t) => t -> [Bool] 64 | bits 0 = [] 65 | bits x = testBit x 0 : bits (shiftR x 1) 66 | unbits :: (Prelude.Num t, Bits t) => [Bool] -> t 67 | unbits [] = 0 68 | unbits (x:xs) = unbit x .|. shiftL (unbits xs) 1 69 | unbit :: Prelude.Num t => Bool -> t 70 | unbit False = 0 71 | unbit True = 1 72 | enum' :: (HasTrie a) => (a -> a') -> (a :->: b) -> [(a', b)] 73 | enum' f = (fmap.first) f . enumerate 74 | -------------------------------------------------------------------------------- /src/Numeric/Clifford/LinearOperators.lhs: -------------------------------------------------------------------------------- 1 | \begin{code} 2 | {-# LANGUAGE NoImplicitPrelude, RankNTypes, KindSignatures, DataKinds, GADTs, FlexibleInstances, UndecidableInstances, InstanceSigs, MultiParamTypeClasses, PolyKinds, ConstraintKinds, UnicodeSyntax, StandaloneDeriving #-} 3 | {-# OPTIONS_HADDOCK show-extensions #-} 4 | module Numeric.Clifford.LinearOperators where 5 | import qualified NumericPrelude as NP ((.), id) 6 | import NumericPrelude hiding ((.), id, (!!), zipWith, map, length, zipWith3, and) 7 | import Numeric.Clifford.Multivector 8 | import Algebra.Algebraic 9 | import Algebra.Field 10 | import Algebra.Ring 11 | import Algebra.Transcendental 12 | import GHC.TypeLits 13 | import Data.Monoid 14 | import Control.Applicative 15 | import Control.Category 16 | import Control.Arrow 17 | import Control.Monad 18 | import Data.List.Stream 19 | import qualified Control.Lens 20 | import Control.Lens.Operators 21 | import Data.Semigroupoid 22 | import Numeric.Natural 23 | import Data.Word 24 | import Algebra.Additive 25 | import Numeric.Clifford.Internal 26 | import qualified Numeric.Clifford.Blade 27 | \end{code} 28 | What is a linear operator? Just a Vector -> Vector! 29 | 30 | \begin{code} 31 | 32 | -- linear operators appear to satisfy monad laws. possible design: use accumulate operator elements, simplify them down to a single operator, and then apply that to a multivector 33 | data LinearOperator' p q f g where 34 | LinearOperator' :: {_operator' :: Multivector p q f -> Multivector p q g} -> LinearOperator' p q f g 35 | LinearOperator :: {_operator :: Multivector p q f -> Multivector p q f} -> LinearOperator' p q f f 36 | 37 | getFuncFromOperator :: LinearOperator' p q f g → (Multivector p q f → Multivector p q g) 38 | getFuncFromOperator (LinearOperator' op) = op 39 | getFuncFromOperator (LinearOperator op) = op 40 | 41 | type LinearOperator p q f = LinearOperator' p q f f 42 | type LinearOperatorCreator p q f = (Algebra.Algebraic.C f, Ord f, KnownNat p, KnownNat q) => Multivector p q f -> LinearOperator p q f 43 | 44 | instance (Show g, f ~ g) => Show (LinearOperator' p q f g) where 45 | show = show . getMatrixElementsFromOperator 46 | 47 | instance (Algebra.Field.C f, Algebra.Field.C g, Ord f, Ord g, KnownNat p, KnownNat q) => Eq (LinearOperator' p q f g) where 48 | a == b = and (map (\ e → (f1 e) == (f2 e)) basisVectors) where 49 | f1 = getFuncFromOperator a 50 | f2 = getFuncFromOperator b 51 | 52 | instance Category (LinearOperator' p q) where 53 | id = LinearOperator' NP.id 54 | (.) (LinearOperator' a) (LinearOperator' b) = LinearOperator' (a NP.. b) 55 | 56 | 57 | instance (Algebra.Field.C f, Ord f,Algebra.Field.C g, Ord g, KnownNat p, KnownNat q, f~g) => Monoid (LinearOperator' p q f g) where 58 | mempty = id 59 | mappend = (.) 60 | 61 | data EuclideanMove p q f where 62 | EuclideanMove :: ∀ (p::Nat) (q::Nat) f. (Algebra.Field.C f, Ord f, KnownNat p, KnownNat q) => { _rotation :: Multivector p q f, _translation :: Multivector p q f} -> EuclideanMove p q f 63 | 64 | deriving instance Eq(EuclideanMove p q f) 65 | deriving instance (Show f) => Show (EuclideanMove p q f) 66 | 67 | applyEuclideanMove (EuclideanMove r a) x = (rotate r x) + a 68 | 69 | 70 | 71 | 72 | instance (Algebra.Field.C f, Ord f, KnownNat p, KnownNat q) => Monoid (EuclideanMove p q f) where 73 | mempty = EuclideanMove one zero 74 | mappend (EuclideanMove s b) (EuclideanMove r a) = EuclideanMove rot trans where 75 | rot = r*s 76 | trans = (rotate s a) + b 77 | 78 | {-instance ∀ a b (p::Nat) (q::Nat).(Algebra.Field.C a, KnownNat p, KnownNat q, Ord a, Algebra.Field.C b, Ord b) => Category (AffineOperator' p q) where 79 | id:: (Algebra.Field.C c) => AffineOperator' p q c c 80 | id = AffineOperator id zero 81 | (.) = undefined -} 82 | 83 | {- 84 | --GHC 7.8: The Control.Category module now has the PolyKinds extension enabled, meaning that instances of Category no longer need be of kind * -> * -> *. 85 | class Operator (p::Nat) (q::Nat) f g where 86 | apply :: Operator p q f g -> Multivector p q f -> Multivector p q g 87 | 88 | instance forall (p::Nat) (q::Nat) . Category (Operator p q) where 89 | id = NP.id 90 | (.) a b = a (NP..) b 91 | -} 92 | 93 | {- 94 | [[f11, f12, f13], 95 | [f21, f22, f21], 96 | [f31, f32, f33]] 97 | -} 98 | 99 | getMatrixElementsFromOperator :: LinearOperator' p q f' f'-> [[f']] 100 | getMatrixElementsFromOperator operator = error "Numeric.Clifford.LinearOperator.getMatrixElementsFromOperator not implemented yet!" where 101 | f = getFuncFromOperator operator 102 | 103 | 104 | 105 | createFunctionalFromElements :: ∀ (p::Nat) (q::Nat) f . (Algebra.Field.C f, Ord f, KnownNat p, KnownNat q) => [[f]] ->(Multivector p q f -> Multivector p q f) 106 | createFunctionalFromElements elements = (\x -> f*x) where 107 | d = (length elements) - 1 108 | f = sumList $ map elementsForK [0..d] 109 | column k = let transposed = transpose elements in transposed !! k 110 | elementsForK k =sumList $ zipWith (scaleRight) basisVectors (column k) 111 | 112 | createLinearOperatorFromElements :: ∀ (p::Nat) (q::Nat) f . (Algebra.Field.C f, Ord f, KnownNat p, KnownNat q) => [[f]] -> LinearOperator p q f 113 | createLinearOperatorFromElements = LinearOperator . createFunctionalFromElements 114 | 115 | 116 | reflect :: (Algebra.Algebraic.C f, Ord f, KnownNat p, KnownNat q) => Multivector p q f -> Multivector p q f -> Multivector p q f 117 | reflect u x = (-u)*x*recip u 118 | 119 | makeReflectionOperator ::LinearOperatorCreator p q f 120 | makeReflectionOperator u = LinearOperator (reflect u) 121 | 122 | rotate spinor x = (reverseMultivector spinor) * x * spinor 123 | rotatePlaneAngle plane angle = rotate (exp (((fst.normalised) plane) * (angle/2))) 124 | 125 | makeRotationOperator :: LinearOperatorCreator p q f 126 | makeRotationOperator u = LinearOperator (rotate u) 127 | makeRotationOperatorFromPlaneAngle plane angle = LinearOperator (rotatePlaneAngle plane angle) 128 | 129 | 130 | project u x = inverse u * (u `dot` x) 131 | makeProjectionOperator :: LinearOperatorCreator p q f 132 | makeProjectionOperator u = LinearOperator (project u) 133 | 134 | \end{code} -------------------------------------------------------------------------------- /src/Numeric/Clifford/Manifold.lhs: -------------------------------------------------------------------------------- 1 | \begin{code} 2 | {-# LANGUAGE NoImplicitPrelude, FlexibleContexts, RankNTypes, ScopedTypeVariables, DeriveDataTypeable #-} 3 | {-# LANGUAGE NoMonomorphismRestriction, UnicodeSyntax, GADTs, DataKinds, KindSignatures, BangPatterns #-} 4 | {-# LANGUAGE FlexibleInstances, UndecidableInstances, InstanceSigs, ImplicitParams #-} 5 | {-# LANGUAGE TemplateHaskell, TypeFamilies, PolyKinds, TypeOperators, FunctionalDependencies #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | module Numeric.Clifford.Manifold where 8 | import NumericPrelude hiding ((++), map, (.)) 9 | import Data.List.Stream 10 | import GHC.TypeLits 11 | import Algebra.Additive 12 | import Algebra.Field 13 | import Algebra.Module 14 | import Numeric.Clifford.Multivector hiding (Symbol) 15 | import Data.AdditiveGroup 16 | import Data.AffineSpace 17 | import Data.VectorSpace 18 | import Prelude.Unicode 19 | import Control.Category 20 | import Control.Arrow 21 | import GHC.TypeLits 22 | import Data.Proxy 23 | import Algebra.Algebraic 24 | import Data.Traversable 25 | import Algebra.VectorSpace 26 | 27 | data Eigenvalues = Eigenvalues {positives ∷ Integer, negatives ∷ Integer, zeros ∷ Integer} deriving (Eq, Show, Ord) 28 | class Metric v f a | a → v f where 29 | measure ∷(?metricChoice ∷ MetricName a, Algebra.Algebraic.C f) ⇒ v 30 | type Tangent a 31 | type Dimension a ∷ Nat 32 | type UsesMetric a ∷ Symbol 33 | atlas ∷ (?manifoldChoice ∷ ManifoldName a) ⇒ f (Chart obj a) 34 | eigenvalues ∷ (?manifoldChoice ∷ ManifoldName a) ⇒ Eigenvalues 35 | tangent ∷ Patch a → Tangent a 36 | cotangent ∷ Patch a → (Tangent a→ Field a) 37 | instance Manifold' [] (Multivector 3 0 Double) "E3" where 38 | type Patch "E3" = Multivector 3 0 Double 39 | type Tangent "E3" = Multivector 3 0 Double 40 | type Field "E3"= Double 41 | type Dimension "E3"= 3 42 | type UsesMetric "E3"= "Euclidean" 43 | eigenvalues = Eigenvalues 3 0 0 44 | 45 | 46 | -- | Represents an arbitrary Cartesian product of Clifford spaces 47 | newtype Manifold p q f = Manifold {unManifold ∷ [Multivector p q f]} deriving (Eq) 48 | 49 | newtype ManifoldTangent p q f = ManifoldTangent {unManifoldTangent ∷ (Manifold p q f, [Multivector p q f])} 50 | newtype ManifoldCoTangent p q f = ManifoldCoTangent {unManifoldCoTangent ∷ ManifoldTangent p q f → f } 51 | 52 | instance (Algebra.Field.C f, Ord f, KnownNat p, KnownNat q) ⇒ AdditiveGroup (ManifoldTangent p q f) where 53 | zeroV = ManifoldTangent ((Manifold undefined), zero) 54 | (^+^) (ManifoldTangent (x,a)) (ManifoldTangent (y,b)) = if x≡y 55 | then ManifoldTangent (x,a+b) 56 | else undefined 57 | negateV (ManifoldTangent (x,t)) = ManifoldTangent (x,negate t) 58 | 59 | instance (Algebra.Field.C f, Ord f, KnownNat p, KnownNat q) ⇒ AffineSpace (Manifold p q f) where 60 | type Diff (Manifold p q f) = ManifoldTangent p q f 61 | (.-.) (Manifold a) (Manifold b) = ManifoldTangent (Manifold b, a-b) 62 | (.+^) (Manifold m) (ManifoldTangent (Manifold x,t)) = if m ≡ x 63 | then Manifold (m+t) 64 | else undefined 65 | 66 | instance (Algebra.Field.C f, Ord f, KnownNat p, KnownNat q, (Algebra.Module.C f (Multivector p q f))) ⇒VectorSpace (ManifoldTangent p q f) where 67 | type Scalar (ManifoldTangent p q f) = f 68 | (*^) scalar (ManifoldTangent (x,t)) = ManifoldTangent (x, scalar *> t) 69 | 70 | type DerivativeFunction p q f = Manifold p q f → ManifoldTangent p q f 71 | 72 | 73 | \end{code} 74 | -------------------------------------------------------------------------------- /src/Numeric/Clifford/Multivector.lhs: -------------------------------------------------------------------------------- 1 | \documentclass{article} 2 | %include polycode.fmt 3 | \usepackage{fontspec} 4 | \usepackage{amsmath} 5 | \usepackage{unicode-math} 6 | \usepackage{lualatex-math} 7 | \setmainfont{latinmodern-math.otf} 8 | \setmathfont{latinmodern-math.otf} 9 | \usepackage{verbatim} 10 | \author{Sophie Taylor} 11 | \title{haskell-clifford: A Haskell Clifford algebra dynamics library} 12 | \begin{document} 13 | 14 | So yeah. This is a Clifford number representation. I will fill out the documentation more fully and stuff once the design has stabilised. 15 | 16 | I am basing the design of this on Issac Trotts' geometric algebra library.\cite{hga} 17 | 18 | Let us begin. We are going to use the Numeric Prelude because it is (shockingly) nicer for numeric stuff. 19 | 20 | \begin{code} 21 | {-# LANGUAGE NoImplicitPrelude, FlexibleContexts, RankNTypes, ScopedTypeVariables, DeriveDataTypeable #-} 22 | {-# LANGUAGE NoMonomorphismRestriction, UnicodeSyntax, GADTs#-} 23 | {-# LANGUAGE FlexibleInstances, StandaloneDeriving, KindSignatures, DataKinds #-} 24 | {-# LANGUAGE TemplateHaskell, TypeOperators, DeriveFunctor, DeriveFoldable, DeriveTraversable#-} 25 | {-# LANGUAGE MultiParamTypeClasses, UndecidableInstances, BangPatterns #-} 26 | {-# OPTIONS_HADDOCK show-extensions #-} 27 | \end{code} 28 | 29 | Clifford algebras are a module over a ring. They also support all the usual transcendental functions. 30 | \begin{code} 31 | module Numeric.Clifford.Multivector where 32 | import Numeric.Clifford.Blade 33 | import NumericPrelude hiding (iterate, head, map, tail, reverse, scanl, zipWith, drop, (++), filter, null, length, foldr, foldl1, zip, foldl, concat, (!!), concatMap,any, repeat, replicate, elem, replicate, all, sum, foldr1) 34 | import Algebra.Absolute 35 | import Algebra.Algebraic 36 | import Algebra.Additive hiding (sum) 37 | import Algebra.Ring 38 | import Algebra.OccasionallyScalar 39 | import Algebra.ToInteger 40 | import Algebra.Transcendental 41 | import Algebra.ZeroTestable 42 | import Algebra.Module 43 | import Algebra.Field 44 | import Data.Serialize 45 | import MathObj.Polynomial.Core (progression) 46 | import System.IO 47 | import Data.List.Stream 48 | import Data.Permute (sort, isEven) 49 | import Data.List.Ordered 50 | import Data.Ord 51 | import Data.Maybe 52 | import Numeric.Natural 53 | import qualified Data.Vector as V 54 | --import NumericPrelude.Numeric (sum) 55 | import qualified NumericPrelude.Numeric as NPN 56 | import Test.QuickCheck 57 | import Math.Sequence.Converge (convergeBy) 58 | import Control.DeepSeq 59 | import Number.Ratio hiding (scale, recip) 60 | import Algebra.ToRational 61 | import qualified GHC.Num as PNum 62 | import Control.Lens hiding (indices) 63 | import Control.Exception (assert) 64 | import Data.Maybe 65 | import Data.Monoid 66 | import Data.Data 67 | import Data.DeriveTH 68 | import GHC.TypeLits hiding (Symbol) 69 | import Control.Lens.Lens 70 | import Data.Word 71 | import Data.Ord (comparing) 72 | import Control.Applicative ((<$>)) 73 | import Numeric.Clifford.Internal 74 | import Data.Traversable 75 | import Data.Foldable (Foldable) 76 | import Numeric.Compensated 77 | import MathObj.Wrapper.Haskell98 78 | import qualified Numeric.Sum as NumericSum hiding (Summation(Double)) 79 | import Prelude.Unicode 80 | import Algebra.VectorSpace 81 | \end{code} 82 | 83 | 84 | A multivector is nothing but a linear combination of basis blades. 85 | 86 | \begin{code} 87 | data Symbolic 88 | data Symbol = MakeSymbol{_friendlyName ∷ String, _latexSymbol ∷ String} deriving (Show, Eq) 89 | data Multivector (p::Nat) (q::Nat) f where 90 | BladeSum :: ∀ (p::Nat) (q::Nat) f . (Ord f, Algebra.Field.C f,KnownNat p, KnownNat q) ⇒ { _terms :: [Blade p q f]} → Multivector p q f 91 | 92 | 93 | type STVector = Multivector 3 1 Double 94 | type STVectorComp = Multivector 3 1 (MathObj.Wrapper.Haskell98.T (Compensated Double)) 95 | type E3Vector = Multivector 3 0 Double 96 | type E3VectorComp = Multivector 3 0 (MathObj.Wrapper.Haskell98.T (Compensated Double)) 97 | 98 | instance (KnownNat p, KnownNat q, Algebra.Field.C f, Arbitrary f, Ord f) ⇒ Arbitrary (Multivector p q f) where 99 | arbitrary = mvNormalForm <$> BladeSum <$> (vector d) where 100 | p' = (natVal (Proxy :: Proxy p)) :: Integer 101 | q' = (natVal (Proxy :: Proxy q)) 102 | d = fromIntegral (p' + q') 103 | 104 | deriving instance Eq (Multivector p q f) 105 | deriving instance Ord (Multivector p q f) 106 | deriving instance (Show f) ⇒ Show (Multivector p q f) 107 | 108 | 109 | signature :: forall (p::Nat) (q::Nat) f. (KnownNat p, KnownNat q) ⇒ Multivector p q f → (Natural,Natural) 110 | signature _ = (toNatural ((fromIntegral $ natVal (Proxy :: Proxy p))::Word),toNatural ((fromIntegral $ natVal (Proxy :: Proxy q))::Word)) 111 | 112 | basisVectors :: forall (p::Nat) (q::Nat) f . (Algebra.Field.C f, Ord f, KnownNat p, KnownNat q) ⇒ [Multivector p q f] 113 | basisVectors = map (sigma) [0..d] where 114 | sigma :: Natural → Multivector p q f 115 | sigma j = (Algebra.Ring.one) `e` [j] 116 | d = let (p', q') = signature (undefined :: Multivector p q f) in pred ( (PNum.+) p' q') 117 | 118 | 119 | 120 | 121 | 122 | terms :: Lens' (Multivector p q f) [Blade p q f] 123 | terms = lens _terms (\bladeSum v → bladeSum {_terms = v}) 124 | 125 | approxDifferenceSquared ∷forall (p::Nat) (q::Nat) f . (Algebra.Field.C f, Ord f, KnownNat p, KnownNat q) ⇒ Multivector p q f → Multivector p q f → f 126 | a `approxDifferenceSquared` b = sum $ map (\x → x*x) $ map (\x →sum $ map _scale x) $ groupLikeTerms $ map bladeNormalForm $ (mvTerms a ++ map bladeNegate (mvTerms b)) where 127 | sum = foldr1 (+) 128 | 129 | 130 | {-# INLINE mvNormalForm #-} 131 | mvNormalForm (BladeSum terms) = BladeSum $ mvNormalForm' terms 132 | 133 | 134 | mvNormalForm' terms = if null resultant then [scalarBlade zero] else resultant where 135 | resultant = filter bladeNonZero $ addLikeTerms' $ Data.List.Ordered.sortBy compare $ map bladeNormalForm terms 136 | 137 | 138 | mvTerms m = _terms m 139 | 140 | 141 | addLikeTerms' = sumLikeTerms . groupLikeTerms 142 | 143 | {-# INLINE groupLikeTerms #-} 144 | groupLikeTerms ::Eq f ⇒ [Blade p q f] → [[Blade p q f]] 145 | groupLikeTerms = groupBy (\a b → a^.indices ≡ b^.indices) 146 | 147 | compareTol :: (Algebra.Algebraic.C f, Algebra.Absolute.C f, Ord f, KnownNat p, KnownNat q) ⇒ Multivector p q f → Multivector p q f → f → Bool 148 | compareTol x y tol = ((NPN.abs $ magnitude (x-y) ) <= tol) 149 | 150 | 151 | {-# RULES "KBN summation" compensatedSum' = compensatedSumDouble' 152 | #-} 153 | {-# NOINLINE compensatedSum' #-} 154 | compensatedSum' :: (Algebra.Additive.C f) ⇒ [f] → f 155 | compensatedSum' xs = kahan zero zero xs where 156 | kahan s _ [] = s 157 | kahan !s !c (x:xs) = 158 | let y = x - c 159 | t = s + y 160 | in kahan t ((t-s)-y) xs 161 | 162 | 163 | {-# INLINE compensatedSumDouble' #-} 164 | compensatedSumDouble' = NumericSum.kbn . (foldl' NumericSum.add NumericSum.zero) 165 | 166 | -- | use this to sum taylor series et al with converge 167 | {-#INLINE compensatedRunningSum#-} 168 | {-#SPECIALISE INLINE compensatedRunningSum :: [STVector] → [STVector] #-} 169 | {-#SPECIALISE INLINE compensatedRunningSum :: [E3Vector] → [E3Vector] #-} 170 | compensatedRunningSum :: (Algebra.Algebraic.C f, Ord f, KnownNat p, KnownNat q, Show f) ⇒ [Multivector p q f] → [Multivector p q f] 171 | compensatedRunningSum xs=shanksTransformation . map fst $ scanl kahanSum (zero,zero) xs where 172 | kahanSum (s,c) b = (t,newc) where 173 | y = b - c 174 | t = s + y 175 | newc = (t - s) - y 176 | 177 | multiplyOutBlades :: (KnownNat p, KnownNat q, Algebra.Ring.C a) ⇒ [Blade p q a] → [Blade p q a] → [Blade p q a] 178 | multiplyOutBlades x y = [bladeMul l r | l <-x, r <- y] 179 | 180 | 181 | multiplyList [] = error "Empty list" 182 | --multiplyList a@(x:[]) = x 183 | multiplyList l = mvNormalForm $ BladeSum listOfBlades where 184 | expandedBlades a = foldl1' multiplyOutBlades a 185 | listOfBlades = expandedBlades $ map mvTerms l 186 | multiplyList1 l = mvNormalForm $ BladeSum listOfBlades where 187 | expandedBlades a = foldl1' multiplyOutBlades a 188 | listOfBlades = expandedBlades $ map mvTerms l 189 | 190 | {-#INLINE sumList #-} 191 | sumList xs = BladeSum $ mvNormalForm' $ concatMap _terms xs 192 | 193 | {-#INLINE sumLikeTerms #-} 194 | {-#SPECIALISE INLINE sumLikeTerms :: [[STBlade]] → [STBlade] #-} 195 | {-#SPECIALISE INLINE sumLikeTerms :: [[E3Blade]] → [E3Blade] #-} 196 | sumLikeTerms :: (Algebra.Field.C f, KnownNat p, KnownNat q) ⇒ [[Blade p q f]] → [Blade p q f] 197 | sumLikeTerms blades = map (\sameIxs → map bScale sameIxs & compensatedSum' & (\result → Blade result ((head sameIxs) & bIndices))) blades 198 | 199 | 200 | instance (Algebra.Field.C f, KnownNat p, KnownNat q, Ord f) ⇒ Data.Monoid.Monoid (Data.Monoid.Sum (Multivector p q f)) where 201 | mempty = Data.Monoid.Sum Algebra.Additive.zero 202 | mappend (Data.Monoid.Sum x) (Data.Monoid.Sum y)= Data.Monoid.Sum (x + y) 203 | mconcat = Data.Monoid.Sum . sumList . map getSum 204 | 205 | instance (Algebra.Field.C f, KnownNat p, KnownNat q, Ord f) ⇒ Data.Monoid.Monoid (Data.Monoid.Product (Multivector p q f)) where 206 | mempty = Data.Monoid.Product one 207 | mappend (Data.Monoid.Product x) (Data.Monoid.Product y) = Data.Monoid.Product (x * y) 208 | mconcat = Data.Monoid.Product . foldl (*) one . map getProduct 209 | 210 | --Constructs a multivector from a scaled blade. 211 | {-#INLINE e#-} 212 | e :: (Algebra.Field.C f, Ord f, KnownNat p, KnownNat q) ⇒ f → [Natural] → Multivector p q f 213 | s `e` indices = mvNormalForm $ BladeSum [Blade s indices] 214 | {-#INLINE scalar#-} 215 | scalar s = BladeSum [scalarBlade s] 216 | 217 | 218 | instance (Control.DeepSeq.NFData f) ⇒ Control.DeepSeq.NFData (Multivector p q f) 219 | 220 | 221 | {-{-# RULES 222 | "turn multiple additions into sumList" forall (a::Multivector (p::Nat) (q::Nat) ( f)) (b::Multivector (p::Nat) (q::Nat) (Algebra.Field.C f)) (c::Multivector (p::Nat) (q::Nat) ( f)) . (+) a ((+) b c) = sumList [a,b,c] 223 | #-}-} 224 | {-#RULES 225 | "sumList[..] + a = sumList [..,a]" forall (a::Multivector (p::Nat) (q::Nat) ( f)) xs. (+) (sumList xs) a = sumList (a:xs) 226 | #-} 227 | {-# RULES 228 | "a+ sumList[..] = sumList [..,a]" forall (a::Multivector p q ( f)) xs. (+) a (sumList xs) = sumList (a:xs) 229 | #-} 230 | instance (Algebra.Field.C f, Ord f, KnownNat p, KnownNat q) ⇒ Algebra.Additive.C (Multivector p q f) where 231 | {-#INLINE (+)#-} 232 | {-#SPECIALISE (+)::STVector → STVector → STVector #-} 233 | {-#SPECIALISE (+)::E3Vector → E3Vector → E3Vector #-} 234 | a + b = mvNormalForm $ BladeSum (mvTerms a ++ mvTerms b) 235 | {-#INLINE (-)#-} 236 | {-#SPECIALISE (-)::STVector → STVector → STVector #-} 237 | {-#SPECIALISE (-)::E3Vector → E3Vector → E3Vector #-} 238 | a - b = mvNormalForm $ BladeSum (mvTerms a ++ map bladeNegate (mvTerms b)) 239 | zero = BladeSum [scalarBlade Algebra.Additive.zero] 240 | 241 | 242 | \end{code} 243 | 244 | Now it is time for the Clifford product. :3 245 | 246 | \begin{code} 247 | {-{-# RULES 248 | "turn multiple multiplications into multiplyList1" forall (a::Multivector (p::Nat) (q::Nat) (Algebra.Field.C f)) b c . (*) ((*) a b) c = multiplyList1 [a,b,c] 249 | #-}-} 250 | {-#RULES 251 | "multiplyList1[..] * a = multiplyList1 [..,a]" forall (a::Multivector (p::Nat) (q::Nat) (f)) xs. (*) (multiplyList1 xs) a = multiplyList1 (concat [xs,[a]]) 252 | #-} 253 | {-# RULES 254 | "a* multiplyList1[..] = multiplyList1 [..,a]" forall (a::Multivector p q ( f)) xs. (*) a (multiplyList1 xs) = multiplyList1 (a:xs) 255 | #-} 256 | instance (Algebra.Field.C f, Ord f, KnownNat p, KnownNat q) ⇒ Algebra.Ring.C (Multivector p q f) where 257 | {-#INLINE (*)#-} 258 | {-#SPECIALISE (*)::STVector →STVector → STVector#-} 259 | {-#SPECIALISE (*)::E3Vector →E3Vector →E3Vector #-} 260 | BladeSum [Blade s []] * b = BladeSum $ map (bladeScaleLeft s) $ mvTerms b 261 | a * BladeSum [Blade s []] = BladeSum $ map (bladeScaleRight s) $ mvTerms a 262 | a * b = mvNormalForm $ BladeSum [bladeMul x y | x <- mvTerms a, y <- mvTerms b] 263 | one = scalar Algebra.Ring.one 264 | fromInteger i = scalar $ Algebra.Ring.fromInteger i 265 | 266 | a ^ 2 = a * a 267 | a ^ 0 = one 268 | --a ^ n --n < 0 = Clifford.recip $ a ^ (negate n) 269 | a ^ n = multiplyList (replicate (NPN.fromInteger n) a) 270 | 271 | 272 | two = fromInteger 2 273 | mul = (Algebra.Ring.*) 274 | 275 | psuedoScalar :: forall (p::Nat) (q::Nat) f. (Ord f, Algebra.Field.C f, KnownNat p, KnownNat q) ⇒ Multivector p q f 276 | psuedoScalar = one `e` [0..(toNatural d)] where 277 | d = fromIntegral (p' + q' - 1 )::Word 278 | p'= natVal (Proxy :: Proxy p) 279 | q' = natVal (Proxy ∷ Proxy q) 280 | 281 | \end{code} 282 | 283 | Clifford numbers have a magnitude and absolute value: 284 | 285 | \begin{code} 286 | 287 | 288 | {-# INLINE magnitude #-} 289 | {-# SPECIALISE INLINE magnitude:: Multivector 3 1 Double → Double #-} 290 | {-# SPECIALISE INLINE magnitude:: Multivector 3 0 Double → Double #-} 291 | magnitude :: (Algebra.Algebraic.C f) ⇒ Multivector p q f → f 292 | magnitude = sqrt . magnitudeSquared 293 | 294 | {-# INLINE magnitudeSquared #-} 295 | {-# SPECIALISE INLINE magnitudeSquared:: Multivector 3 1 Double → Double #-} 296 | {-# SPECIALISE INLINE magnitudeSquared:: Multivector 3 0 Double → Double #-} 297 | magnitudeSquared :: (Algebra.Algebraic.C f) ⇒ Multivector p q f → f 298 | magnitudeSquared = compensatedSum' . map (\b → (bScale b)^ 2) . mvTerms 299 | instance (Algebra.Absolute.C f, Algebra.Algebraic.C f, Ord f, KnownNat p, KnownNat q) ⇒ Algebra.Absolute.C (Multivector p q f) where 300 | abs v = magnitude v `e` [] 301 | signum (BladeSum [Blade scale []]) = scalar $ signum scale 302 | signum (BladeSum []) = scalar Algebra.Additive.zero 303 | 304 | instance (Algebra.Field.C f, Ord f, KnownNat p, KnownNat q) ⇒ Algebra.Module.C f (Multivector p q f) where 305 | {-#INLINE (*>) #-} 306 | {-#SPECIALISE INLINE (*>) :: Double → STVector → STVector #-} 307 | {-#SPECIALISE INLINE (*>) :: Double → E3Vector → E3Vector #-} 308 | (*>) s v = v & mvTerms & map (bladeScaleLeft s) & BladeSum 309 | 310 | 311 | 312 | {-#INLINE ()#-} 315 | (/>) n d = n * Numeric.Clifford.Multivector.inverse d 316 | () n d = n /> d 317 | 318 | {-#INLINE scaleLeft #-} 319 | scaleLeft s v = BladeSum $ map (bladeScaleLeft s) $ mvTerms v 320 | {-#INLINE scaleRight #-} 321 | scaleRight v s = BladeSum $ map (bladeScaleRight s) $ mvTerms v 322 | {-#INLINE divideRight #-} 323 | divideRight v s = scaleRight v (recip s) 324 | 325 | 326 | {-# INLINE converge#-} 327 | converge [] = error "converge: empty list" 328 | converge xs = fromMaybe empty (convergeBy checkPeriodic Just xs) 329 | where 330 | empty = error "converge: error in implmentation" 331 | checkPeriodic (a:b:c:_) 332 | | (myTrace ("Converging at " ++ show a) a) ≡ b = Just a 333 | | a ≡ c = Just a 334 | checkPeriodic _ = Nothing 335 | 336 | 337 | aitkensAcceleration [] = [] 338 | aitkensAcceleration a@(xn:[]) = a 339 | aitkensAcceleration a@(xn:xnp1:[]) = a 340 | aitkensAcceleration a@(xn:xnp1:xnp2:[]) = a 341 | aitkensAcceleration (xn:xnp1:xnp2:xs) | xn ≡ xnp1 = [xnp1] 342 | | xn ≡ xnp2 = [xnp2] 343 | | otherwise = xn - ((dxn ^ 2) /> ddxn) : aitkensAcceleration (xnp1:xnp2:xs) where 344 | dxn = sumList [xnp1,negate xn] 345 | ddxn = sumList [xn, (-2) * xnp1, xnp2] 346 | 347 | {-# INLINABLE shanksTransformation #-} 348 | {-#SPECIALISE shanksTransformation :: [Multivector 3 0 Double] → [Multivector 3 0 Double] #-} 349 | {-#SPECIALISE shanksTransformation :: [Multivector 3 1 Double] → [Multivector 3 1 Double] #-} 350 | shanksTransformation :: (Algebra.Algebraic.C f, Ord f, Show f, KnownNat p, KnownNat q) ⇒ [Multivector p q f] → [Multivector p q f] 351 | shanksTransformation [] = [] 352 | shanksTransformation a@(xnm1:[]) = a 353 | shanksTransformation a@(xnm1:xn:[]) = a 354 | shanksTransformation (xnm1:xn:xnp1:xs) | xnm1 ≡ xn = [xn] 355 | | xnm1 ≡ xnp1 = [xnm1] 356 | | denominator ≡ zero = [xnp1] 357 | | otherwise = out:shanksTransformation (xn:xnp1:xs) where 358 | out = numerator /> denominator 359 | numerator = sumList [xnp1*xnm1, negate (xn^2)] 360 | denominator = sumList [xnp1, (-2)*xn, xnm1] 361 | 362 | {-# INLINABLE takeEvery #-} 363 | takeEvery nth xs = case drop (nth-1) xs of 364 | (y:ys) → y : takeEvery nth ys 365 | [] → [] 366 | 367 | seriesPlusMinus (x:y:rest) = x:negate y: seriesPlusMinus rest 368 | seriesMinusPlus (x:y:rest) = negate x : y : seriesMinusPlus rest 369 | 370 | instance (Algebra.Field.C f, Algebra.Module.C f (Multivector p q f)) ⇒ Algebra.VectorSpace.C f (Multivector p q f) 371 | {-#INLINE expTerms#-} 372 | {-# SPECIALISE INLINE expTerms :: STVector → [STVector]#-} 373 | {-# SPECIALISE INLINE expTerms :: E3Vector → [E3Vector]#-} 374 | expTerms :: (Algebra.Algebraic.C f, KnownNat p, KnownNat q, Ord f) ⇒ Multivector p q f → [Multivector p q f] 375 | expTerms x = map snd $ iterate (\(n,b) → (n + 1, (recip $ fromInteger n ) `scaleLeft` (x*b) )) (1::NPN.Integer,one) 376 | 377 | instance (Algebra.Transcendental.C f, Ord f, KnownNat p, KnownNat q, Show f) ⇒ Algebra.Transcendental.C (Multivector p q f) where 378 | pi = scalar pi 379 | {-#INLINABLE exp#-} 380 | {-# SPECIALISE INLINE exp :: STVector → STVector #-} 381 | {-# SPECIALISE INLINE exp :: E3Vector → E3Vector #-} 382 | exp (BladeSum [ Blade s []]) = myTrace ("scalar exponential of " ++ show s) scalar $ exp s 383 | exp x = myTrace ("Computing exponential of " ++ show x) convergeTerms x where --(expMag ^ expScaled) where 384 | expMag = exp mag 385 | expScaled = converge $ shanksTransformation.shanksTransformation . compensatedRunningSum $ expTerms scaled 386 | convergeTerms terms = converge $ shanksTransformation.shanksTransformation.compensatedRunningSum $ expTerms terms 387 | (scaled,mag) = normalised x 388 | 389 | {-#INLINE log#-} 390 | {-# SPECIALISE INLINE log :: STVector → STVector #-} 391 | {-# SPECIALISE INLINE log :: E3Vector → E3Vector #-} 392 | log (BladeSum [Blade s []]) = scalar $ NPN.log s 393 | log a = scalar (log mag) + log' scaled where 394 | (scaled,mag) = normalised a 395 | log' a = converge $ halleysMethod f f' f'' (one `e` [1,2]) where 396 | {-#INLINABLE f#-} 397 | f x = a - exp x 398 | {-#INLINABLE f'#-} 399 | f' x = negate $ exp x 400 | {-#INLINABLE f''#-} 401 | f'' = f' 402 | sin (BladeSum [Blade s []]) = scalar $ sin s 403 | sin x = converge $ shanksTransformation $ compensatedRunningSum $ sinTerms x where 404 | sinTerms x = seriesPlusMinus $ takeEvery 2 $ expTerms x 405 | cos (BladeSum [Blade s []]) = scalar $ cos s 406 | cos x = converge $ shanksTransformation $ compensatedRunningSum (one : cosTerms x) where 407 | cosTerms x = seriesMinusPlus $ takeEvery 2 $ tail $ expTerms x 408 | 409 | atan (BladeSum [Blade s []]) = scalar $ atan s 410 | atan z = (z/onePlusZSquared) * (one + (converge $ shanksTransformation $ compensatedRunningSum $ map lambda [1..])) where 411 | lambda :: Integer → Multivector p q f 412 | lambda n = multiplyList1 $ map innerFraction [1..n] 413 | innerFraction :: Integer → Multivector p q f 414 | innerFraction k = (tk*zSquared)/>((tk+one)*(onePlusZSquared)) where 415 | tk = fromInteger (2*k) 416 | zSquared = z^2 :: Multivector p q f 417 | onePlusZSquared = one+z^2 :: Multivector p q f 418 | 419 | cosh x = converge $ shanksTransformation . compensatedRunningSum $ takeEvery 2 $ expTerms x 420 | sinh x = converge $ shanksTransformation . compensatedRunningSum $ takeEvery 2 $ tail $ expTerms x 421 | 422 | dot :: Multivector p q f → Multivector p q f → Multivector p q f 423 | dot a@(BladeSum _) b@(BladeSum _) = mvNormalForm $ BladeSum [x `bDot` y | x <- mvTerms a, y <- mvTerms b] 424 | wedge::Multivector p q f → Multivector p q f→Multivector p q f 425 | wedge a@(BladeSum _) b@(BladeSum _) = mvNormalForm $ BladeSum [x `bWedge` y | x <- mvTerms a, y <- mvTerms b] 426 | 427 | 428 | {-# INLINE reverseBlade #-} 429 | reverseBlade b = bladeNormalForm $ b & indices %~ reverse 430 | {-# INLINE reverseMultivector #-} 431 | reverseMultivector v = mvNormalForm $ v & terms.traverse%~ reverseBlade 432 | 433 | {-#INLINE inverse#-} 434 | {-#SPECIALISE INLINE inverse :: STVector → STVector #-} 435 | {-# SPECIALISE INLINE inverse :: E3Vector → E3Vector #-} 436 | inverse a@(BladeSum _) = assert (a /= zero) $ (recip scalarComponent) *> (reverseMultivector a) where 437 | scalarComponent = bScale (head $ mvTerms (a * reverseMultivector a)) 438 | 439 | 440 | instance (Algebra.Field.C f, Ord f, KnownNat p, KnownNat q) ⇒ Algebra.Field.C (Multivector p q f) where 441 | recip = inverse 442 | 443 | instance (Algebra.Field.C f, Ord f, KnownNat p, KnownNat q) ⇒ Algebra.OccasionallyScalar.C f (Multivector p q f) where 444 | toScalar = bScale . bladeGetGrade 0 . head . mvTerms 445 | toMaybeScalar (BladeSum [Blade s []]) = Just s 446 | toMaybeScalar (BladeSum []) = Just Algebra.Additive.zero 447 | toMaybeScalar _ = Nothing 448 | fromScalar = scalar 449 | \end{code} 450 | 451 | Also, we may as well implement the standard prelude Num interface. 452 | 453 | \begin{code} 454 | instance (Algebra.Algebraic.C f, KnownNat p, KnownNat q, Ord f) ⇒ PNum.Num (Multivector p q f) where 455 | (+) = (Algebra.Additive.+) 456 | (-) = (Algebra.Additive.-) 457 | (*) = (Algebra.Ring.*) 458 | negate = NPN.negate 459 | abs = scalar . magnitude 460 | fromInteger = Algebra.Ring.fromInteger 461 | signum m = Numeric.Clifford.Multivector.inverse (scalar $ magnitude m) * m 462 | 463 | 464 | \end{code} 465 | 466 | Let's use Newton or Halley iteration to find the principal n-th root :3 467 | 468 | \begin{code} 469 | instance (Algebra.Algebraic.C f, Show f, Ord f, KnownNat p, KnownNat q) ⇒ Algebra.Algebraic.C (Multivector p q f) where 470 | root 0 _ = error "Cannot take 0th root" 471 | root _ (BladeSum []) = error "Empty bladesum" 472 | root _ (BladeSum [Blade zero []]) = error "Cannot compute a root of zero" 473 | root n (BladeSum [Blade s []]) = scalar $ root n s 474 | root n a@(BladeSum _) = converge $ rootIterationsStart n a g where 475 | g = if q' ≤ 1 then one`e`[q',succ q'] else one + one `e` [0,1] 476 | (p',q') = signature a 477 | 478 | rootIterationsStart ::(Ord f, Show f, Algebra.Algebraic.C f)⇒ NPN.Integer → Multivector p q f → Multivector p q f → [Multivector p q f] 479 | rootIterationsStart n a@(BladeSum (Blade s [] :_)) one = rootHalleysIterations n a g where 480 | g = if s >= NPN.zero || q' ≡ 1 then one else (Algebra.Ring.one `e` [0,1]) 481 | (p',q') = signature a 482 | 483 | rootIterationsStart n a@(BladeSum _) g = rootHalleysIterations n a g 484 | 485 | 486 | rootNewtonIterations :: (Algebra.Field.C f, Ord f, KnownNat p, KnownNat q) ⇒ NPN.Integer → Multivector p q f → Multivector p q f → [Multivector p q f] 487 | rootNewtonIterations n a = iterate xkplus1 where 488 | xkplus1 xk = xk + deltaxk xk 489 | deltaxk xk = oneOverN * ((inverse (xk ^ (n - one))* a) - xk) 490 | oneOverN = scalar $ NPN.recip $ fromInteger n 491 | 492 | rootHalleysIterations :: (Show a, Ord a, Algebra.Algebraic.C a, KnownNat p, KnownNat q) ⇒ NPN.Integer → Multivector p q a → Multivector p q a → [Multivector p q a] 493 | rootHalleysIterations n a = halleysMethod f f' f'' where 494 | f x = a - (x^n) 495 | f' x = fromInteger (-n) * (x^(n-1)) 496 | f'' x = fromInteger (-(n*(n-1))) * (x^(n-2)) 497 | 498 | {-#INLINE halleysMethod #-} 499 | {-#SPECIALISE halleysMethod :: (STVector→STVector)→(STVector→STVector)→(STVector→STVector)→STVector→[STVector]#-} 500 | {-#SPECIALISE halleysMethod :: (E3Vector→E3Vector)→(E3Vector→E3Vector)→(E3Vector→E3Vector)→E3Vector→[E3Vector]#-} 501 | halleysMethod :: (Show a, Ord a, Algebra.Algebraic.C a, KnownNat p, KnownNat q) ⇒ (Multivector p q a → Multivector p q a) → (Multivector p q a → Multivector p q a) → (Multivector p q a → Multivector p q a) → Multivector p q a → [Multivector p q a] 502 | halleysMethod f f' f'' = iterate update where 503 | update x = x - (numerator x * inverse (denominator x) ) where 504 | numerator x= multiplyList [2, fx, dfx] 505 | denominator x= multiplyList [2, dfx, dfx] - (fx * ddfx) 506 | fx = f x 507 | dfx = f' x 508 | ddfx = f'' x 509 | 510 | 511 | secantMethod f x0 x1 = update x1 x0 where 512 | update xm1 xm2 | xm1 ≡ xm2 = [xm1] 513 | | otherwise = if x ≡ xm1 then [x] else x : update x xm1 where 514 | x = xm1 - f xm1 * (xm1-xm2) * inverse (f xm1 - f xm2) 515 | 516 | \end{code} 517 | 518 | Now let's try logarithms by fixed point iteration. It's gonna be slow, but whatever! 519 | 520 | \begin{code} 521 | {-#INLINE normalised#-} 522 | {-#SPECIALISE INLINE normalised :: STVector → (STVector, Double) #-} 523 | {-#SPECIALISE INLINE normalised :: E3Vector → (E3Vector, Double) #-} 524 | normalised :: (Ord f, Algebra.Algebraic.C f, KnownNat p, KnownNat q) ⇒ Multivector p q f → (Multivector p q f,f) 525 | normalised a = (a `scaleRight` ( recip $ mag),mag) where 526 | mag = magnitude a 527 | 528 | \end{code} 529 | \bibliographystyle{IEEEtran} 530 | \bibliography{biblio.bib} 531 | \end{document} 532 | -------------------------------------------------------------------------------- /src/Numeric/Clifford/NumericIntegration.lhs: -------------------------------------------------------------------------------- 1 | \documentclass{article} 2 | %include polycode.fmt 3 | \usepackage{fontspec} 4 | \usepackage{amsmath} 5 | \usepackage{unicode-math} 6 | \usepackage{lualatex-math} 7 | \setmainfont{latinmodern-math.otf} 8 | \setmathfont{latinmodern-math.otf} 9 | \usepackage{verbatim} 10 | \author{Sophie Taylor} 11 | \title{haskell-clifford: A Haskell Clifford algebra dynamics library} 12 | \begin{document} 13 | 14 | This is the numeric integration portion of the library. 15 | 16 | \begin{code} 17 | {-# LANGUAGE NoImplicitPrelude, FlexibleContexts, RankNTypes, ScopedTypeVariables, DeriveDataTypeable #-} 18 | {-# LANGUAGE NoMonomorphismRestriction, UnicodeSyntax, GADTs, DataKinds, KindSignatures, BangPatterns #-} 19 | {-# LANGUAGE FlexibleInstances #-} 20 | {-# LANGUAGE TemplateHaskell #-} 21 | {-# LANGUAGE MultiParamTypeClasses #-} 22 | 23 | module Numeric.Clifford.NumericIntegration where 24 | import Numeric.Clifford.Multivector as MV 25 | import NumericPrelude hiding (iterate, head, map, tail, reverse, scanl, zipWith, drop, (++), filter, null, length, foldr, foldl1, zip, foldl, concat, (!!), concatMap,any, repeat, replicate, elem, replicate, sum) 26 | import Algebra.Absolute 27 | import Algebra.Algebraic 28 | import Algebra.Additive hiding (elementAdd, elementSub,sum) 29 | import Algebra.Ring 30 | import Data.Monoid 31 | import Data.VectorSpace 32 | import Control.Parallel.Strategies 33 | import Algebra.ToInteger 34 | import Algebra.Module 35 | import Algebra.Field 36 | import Data.List.Stream hiding (sum) 37 | import Numeric.Natural 38 | import qualified Data.Vector as V 39 | import Control.Category.Unicode 40 | import qualified NumericPrelude.Numeric as NPN hiding (sum) 41 | import Test.QuickCheck 42 | import Math.Sequence.Converge (convergeBy) 43 | import Number.Ratio hiding (scale) 44 | import Algebra.ToRational 45 | import Control.Lens hiding (indices, coerce) 46 | import Control.Exception (assert) 47 | import Data.Maybe 48 | import GHC.TypeLits 49 | import Numeric.Clifford.Internal 50 | import Data.DeriveTH 51 | import Numeric.Compensated hiding ((*^)) 52 | import Data.VectorSpace ((*^)) 53 | import MathObj.Wrapper.Haskell98 54 | import Numeric.Clifford.Manifold 55 | import qualified Debug.Trace 56 | import Data.Coerce 57 | elementAdd = zipWith (+) 58 | elementScale = zipWith (*>) 59 | a `elementSub` b = zipWith (-) a b 60 | a `elementMul` b = zipWith (*) a b 61 | 62 | sum = foldl' (+) zero 63 | 64 | 65 | 66 | --This will stop as soon as one of the elements converges. This is bad. Need to make it skip convergent ones and focus on the remainig. 67 | systemBroydensMethod f x0 x1 = map fst $ update (x1,ident) x0 where 68 | update (xm1,jm1) xm2 | zero `elem` dx = [(xm1,undefined)] 69 | | otherwise = if x == xm1 then [(x,undefined)] else (x,j) : update (x,j) xm1 where 70 | x = xm1 `elementSub` ( (fm1 `elementMul` dx) `elementMul` ody) 71 | j = undefined 72 | fm1 = f xm1 73 | fm2 = f xm2 74 | dx = elementSub xm1 xm2 75 | dy = elementSub fm1 fm2 76 | ody = map inverse dy 77 | ident = undefined 78 | 79 | --TODO: implement Broyden-Fletcher-Goldfarb-Shanno method 80 | 81 | convergeList ::(Show f, Ord f) => [[f]] -> [f] 82 | convergeList = converge 83 | 84 | 85 | {-#INLINE sumListOfLists #-} 86 | 87 | sumListOfLists = map sumList . transpose 88 | 89 | stateConvergeTolLists :: (Ord f, Algebra.Absolute.C f, Algebra.Algebraic.C f, Show f, KnownNat p, KnownNat q) 90 | => f -> [[Multivector p q f]] -> [Multivector p q f] 91 | stateConvergeTolLists t [] = error "converge: empty list" 92 | stateConvergeTolLists t xs = fromMaybe empty (convergeBy check Just xs) 93 | where 94 | empty = error "converge: error in impl" 95 | check (a:b:c:_) 96 | | (myTrace ("Converging at " ++ show a) a) == b = Just b 97 | | a == c = Just c 98 | | (compensatedSum' diffBetweenElements) <= t = showOutput ("state convergence with tolerance "++ show t )$ Just c where 99 | diffBetweenElements = zipWith approxDifferenceSquared b c 100 | check _ = Nothing 101 | guessConvergeTolLists :: ∀ (p::Nat) (q::Nat) f. (Ord f, Algebra.Absolute.C f, Algebra.Algebraic.C f, Show f, KnownNat p, KnownNat q) 102 | => f -> [[[Multivector p q f]]] -> [[Multivector p q f]] 103 | guessConvergeTolLists _ [] = error "converge: empty list" 104 | guessConvergeTolLists t xs = fromMaybe empty (convergeBy check Just xs) 105 | where 106 | empty = error "converge: error in impl" 107 | check :: [[[Multivector p q f]]] -> Maybe [[Multivector p q f]] 108 | check (a:b:c:_) 109 | | (myTrace ("Converging at " ++ show a) a) == b = Just b 110 | | a == c = Just c 111 | | totalDifference <= t = showOutput ("guess convergence with tolerance "++ show t )$ Just c where 112 | totalDifference = sum $ zipWith absDiffBetweenLists b c 113 | absDiffBetweenLists :: [Multivector p q f] -> [Multivector p q f] -> f 114 | absDiffBetweenLists x' y' = sum $ zipWith (approxDifferenceSquared) x' y' 115 | check _ = Nothing 116 | 117 | type ProjectionToManifold p q t stateType = stateType -> [Multivector p q t] 118 | type DeprojectorFromManifold p q t stateType = [Multivector p q t] -> stateType 119 | type RKStepper (p::Nat) (q::Nat) t stateType = 120 | (Ord t, Show t, Algebra.Module.C t (Multivector p q t), Algebra.Field.C t) => 121 | t -> (t -> stateType -> stateType) -> 122 | DeprojectorFromManifold p q t stateType -> 123 | ProjectionToManifold p q t stateType -> 124 | (t,stateType) -> (t,stateType) 125 | data ButcherTableau f = ButcherTableau {_tableauA :: [[f]], _tableauB :: [f], _tableauC ∷ [f]} deriving (Eq, Show) 126 | makeLenses ''ButcherTableau 127 | 128 | type StateConvergerFunction f = ∀ (p::Nat) (q::Nat) f . [[Multivector p q f]] -> [Multivector p q f] 129 | type GuessConvergerFunction f = ∀ (p::Nat) (q::Nat) f . [[[Multivector p q f]]] -> [[Multivector p q f]] 130 | type AdaptiveStepSizeFunction f state = f -> state -> f 131 | 132 | data RKAttribute f state = Explicit 133 | | HamiltonianFunction {totalEnergy :: state -> f} 134 | | AdaptiveStepSize {sigma :: AdaptiveStepSizeFunction f state} 135 | | ConvergenceTolerance {epsilon :: f} 136 | | StateConvergenceFunction {stateConverger :: StateConvergerFunction f } 137 | | GuessConvergenceFunction {guessConverger :: GuessConvergerFunction f } 138 | | RootSolver 139 | | UseAutomaticDifferentiationForRootSolver 140 | | Seperable 141 | | StartingGuessMethod 142 | 143 | 144 | $( derive makeIs ''RKAttribute) 145 | 146 | {-#SPECIALISE genericRKMethod :: ButcherTableau Double -> [RKAttribute Double stateType] -> RKStepper 3 0 Double stateType#-} 147 | {-#SPECIALISE genericRKMethod :: ButcherTableau Double -> [RKAttribute Double [E3Vector]] -> RKStepper 3 0 Double [E3Vector]#-} 148 | {-#SPECIALISE genericRKMethod :: ButcherTableau Double -> [RKAttribute Double stateType] -> RKStepper 3 1 Double stateType#-} 149 | {-#SPECIALISE genericRKMethod :: ButcherTableau Double -> [RKAttribute Double [STVector]] -> RKStepper 3 1 Double [STVector]#-} 150 | {-#SPECIALISE genericRKMethod :: ButcherTableau (MathObj.Wrapper.Haskell98.T (Compensated Double)) -> [RKAttribute (MathObj.Wrapper.Haskell98.T (Compensated Double)) stateType] -> RKStepper 3 0 (MathObj.Wrapper.Haskell98.T (Compensated Double)) stateType#-} 151 | {-#SPECIALISE genericRKMethod :: ButcherTableau (MathObj.Wrapper.Haskell98.T (Compensated Double)) -> [RKAttribute (MathObj.Wrapper.Haskell98.T (Compensated Double)) [E3VectorComp]] -> RKStepper 3 0 (MathObj.Wrapper.Haskell98.T (Compensated Double)) [E3VectorComp]#-} 152 | {-#SPECIALISE genericRKMethod :: ButcherTableau (MathObj.Wrapper.Haskell98.T (Compensated Double)) -> [RKAttribute (MathObj.Wrapper.Haskell98.T (Compensated Double)) stateType] -> RKStepper 3 1 (MathObj.Wrapper.Haskell98.T (Compensated Double)) stateType#-} 153 | {-#SPECIALISE genericRKMethod :: ButcherTableau (MathObj.Wrapper.Haskell98.T (Compensated Double)) -> [RKAttribute (MathObj.Wrapper.Haskell98.T (Compensated Double)) [STVectorComp]] -> RKStepper 3 1 (MathObj.Wrapper.Haskell98.T (Compensated Double)) [STVectorComp]#-} 154 | genericRKMethod :: ∀ (p::Nat) (q::Nat) t stateType . 155 | ( Ord t, Show t, Algebra.Module.C t (Multivector p q t),Algebra.Absolute.C t, Algebra.Algebraic.C t, KnownNat p, KnownNat q, VectorSpace (ManifoldTangent p q t),NFData t) 156 | => ButcherTableau t -> [RKAttribute t stateType] -> RKStepper p q t stateType 157 | genericRKMethod tableau attributes = rkMethodImplicitFixedPoint where 158 | s :: Int 159 | s = length (_tableauC tableau) 160 | c :: Int -> t 161 | c n = l !! (n-1) where 162 | l = _tableauC tableau 163 | a :: Int -> [t] 164 | a n = (l !! (n-1)) where 165 | l = _tableauA tableau 166 | b :: Int -> t 167 | b i = l !! (i - 1) where 168 | l = _tableauB tableau 169 | b' = _tableauB tableau 170 | 171 | --TODO: Use hamiltonian to tell it to only stop converging once it is within an acceptable range of energy!!! Otherwise the tolerances will lead to an exponential decay/growth due to approaching from below/above! 172 | stateConverger :: [[Multivector p q t]] -> [Multivector p q t] 173 | stateConverger = case find (\x -> isConvergenceTolerance x || isStateConvergenceFunction x) attributes of 174 | Just (StateConvergenceFunction conv) -> conv 175 | Just (ConvergenceTolerance tol) -> stateConvergeTolLists (myTrace ("Convergence tolerance set to " ++ show tol)tol) 176 | Nothing -> myTrace "No convergence tolerance specified, defaulting to equality" convergeList 177 | guessConverger :: [[[Multivector p q t]]] -> [[Multivector p q t]] 178 | guessConverger = case find (\x -> isConvergenceTolerance x || isGuessConvergenceFunction x) attributes of 179 | Just (GuessConvergenceFunction conv) -> conv 180 | Just (ConvergenceTolerance tol) -> guessConvergeTolLists (myTrace ("Convergence tolerance set to " ++ show tol)tol) 181 | Nothing -> myTrace "No convergence tolerance specified, defaulting to equality" converge 182 | stepSizeAdapter :: AdaptiveStepSizeFunction t stateType 183 | stepSizeAdapter = case find isAdaptiveStepSize attributes of 184 | Just (AdaptiveStepSize sigma) -> sigma 185 | Nothing -> (\_ _ -> one) 186 | 187 | (hamiltonian, hamiltonianExists) = case find isHamiltonianFunction attributes of 188 | Just (HamiltonianFunction hamil) -> (hamil,True) 189 | Nothing -> (undefined,False) 190 | 191 | rkMethodImplicitFixedPoint :: RKStepper p q t stateType 192 | rkMethodImplicitFixedPoint h f deproject project (time, state) = 193 | (time + adaptiveStepSizeFraction*(c s), newState) where 194 | adaptiveStepSizeFraction = (stepSizeAdapter time state)*h 195 | newState = deproject $ elementAdd state' dy' 196 | state' = project state 197 | lengthOfState = length state' 198 | 199 | dy' = sumListOfLists $ zipWith (\b zi -> map (b *>) zi) b' z 200 | 201 | --set the initial guess as the derivatives evaluated at appropriate times through the timestep 202 | initialGuess = unfoldr (\(i,st) -> if i>s 203 | then 204 | Nothing 205 | else 206 | let st' = snd . unManifoldTangent $ evalDerivatives (time + adaptiveStepSizeFraction * (c i)) (Manifold st) 207 | in Just (st',(i+1,st'))) (1,state') 208 | z = guessConverger $ iterate systemOfZiGuesses initialGuess 209 | systemOfZiGuesses :: [[Multivector p q t]] -> [[Multivector p q t]] 210 | systemOfZiGuesses !zk = [zi_plus1 i | i <- [1..s]] `using` parList rseq where 211 | atYn = map (elementAdd state') zk 212 | zi_plus1 i = map (h' *>) $ sumListOfLists scaledByAi where 213 | h' = adaptiveStepSizeFraction * (c i) 214 | guessTime = time + h' 215 | scaledByAi ∷ [[Multivector p q t]] 216 | scaledByAi = map (snd . (coerce ∷ ManifoldTangent p q t -> (Manifold p q t, [Multivector p q t]))) $ zipWith ( *^) (a i) derivs 217 | derivs ∷ [ManifoldTangent p q t] 218 | derivs = map ((evalDerivatives guessTime) . coerce) atYn 219 | evalDerivatives :: t -> DerivativeFunction p q t 220 | --basically a wrapper for f 221 | evalDerivatives time stateAtTime = ManifoldTangent (stateAtTime, tangent) where 222 | tangent = (project . (f time) . deproject . unManifold) stateAtTime 223 | 224 | 225 | \end{code} 226 | 227 | Look at creating an exponential integrator: https://en.wikipedia.org/wiki/Exponential_integrators 228 | 229 | \bibliographystyle{IEEEtran} 230 | \bibliography{biblio.bib} 231 | \end{document} 232 | -------------------------------------------------------------------------------- /src/Numeric/Clifford/NumericIntegration/DefaultIntegrators.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude, NoMonomorphismRestriction #-} 2 | module Numeric.Clifford.NumericIntegration.DefaultIntegrators where 3 | import Algebra.Absolute 4 | import Algebra.Additive hiding (elementAdd, 5 | elementSub) 6 | import Algebra.Algebraic 7 | import Algebra.Field 8 | import Algebra.Module 9 | import Algebra.Ring 10 | import Algebra.ToInteger 11 | import Algebra.ToRational 12 | import Control.Exception (assert) 13 | import Control.Lens hiding (indices) 14 | import Data.DeriveTH 15 | import Data.List.Stream 16 | import Data.Maybe 17 | import Data.Monoid 18 | import qualified Data.Vector as V 19 | import Debug.Trace 20 | import GHC.TypeLits 21 | import Math.Sequence.Converge (convergeBy) 22 | import Number.Ratio hiding (scale) 23 | import Numeric.Clifford.Multivector as MV 24 | import Numeric.Clifford.NumericIntegration 25 | import Numeric.Natural 26 | import NumericPrelude hiding (any, concat, 27 | concatMap, drop, elem, 28 | filter, foldl, foldl1, 29 | foldr, head, iterate, 30 | length, map, null, repeat, 31 | replicate, replicate, 32 | reverse, scanl, tail, zip, 33 | zipWith, (!!), (++)) 34 | import NumericPrelude.Numeric (sum) 35 | import qualified NumericPrelude.Numeric as NPN 36 | import Test.QuickCheck 37 | import Numeric.Clifford.Internal 38 | 39 | --rk4ClassicalTableau :: ButcherTableau NPN.Double 40 | rk4ClassicalTableau = ButcherTableau [[0,0,0,0],[0.5,0,0,0],[0,0.5,0,0],[0,0,1,0]] [1.0 NPN./6,1.0 NPN./3, 1.0 NPN./3, 1.0 NPN./6] [0, 0.5, 0.5, 1] 41 | implicitEulerTableau = ButcherTableau [[1.0::NPN.Double]] [1] [1] 42 | 43 | 44 | 45 | gaussLegendreFourthOrderTableau = ButcherTableau [[0.25::NPN.Double, 0.25 - ((sqrt 3.0) /6.0)],[0.25 + ((sqrt 3.0) / 6.0) , 0.25]] [0.5, 0.5] [0.5 - ((sqrt 3.0) /6.0), 0.5 + ((sqrt 3.0) / 6.0)] 46 | gaussLegendreFourthOrder h f (t, state) = impl h f id id (t,state) where 47 | impl= genericRKMethod gaussLegendreFourthOrderTableau [ConvergenceTolerance 5.0e-15] 48 | 49 | 50 | gaussLegendreFourthOrderTableauComp = ButcherTableau [[comp (0.25::Double), comp 0.25 - ((sqrt 3.0) /6.0)],[comp 0.25 + ((sqrt 3.0)/ 6.0) , comp 0.25]] [comp 0.5, comp 0.5] [comp 0.5 - ((sqrt 3.0) /6.0),comp 0.5 + ((sqrt 3.0) / 6.0)] 51 | gaussLegendreFourthOrderComp h f (t, state) = impl h f id id (t,state) where 52 | impl= genericRKMethod gaussLegendreFourthOrderTableauComp [ConvergenceTolerance (comp 5.0e-13) ] 53 | 54 | 55 | 56 | rk4ClassicalFromTableau h f (t,state) = impl h f id id (t, state) where 57 | impl = genericRKMethod rk4ClassicalTableau [] 58 | implicitEulerMethod h f (t, state) = impl h f id id (t, state) where 59 | impl = genericRKMethod implicitEulerTableau [ConvergenceTolerance 1.0e-8] 60 | 61 | lobattoIIIASecondOrderTableau = ButcherTableau [[0,0],[0.5::NPN.Double,0.5]] [0.5,0.5] [0,1] 62 | lobattoIIIASecondOrder h f (t, state) = impl h f id id (t, state) where 63 | impl = genericRKMethod lobattoIIIASecondOrderTableau [] 64 | 65 | lobattoIIIAFourthOrderWithTol h f (t, state) = impl h f id id (t, state) where 66 | impl = genericRKMethod lobattoIIIAFourthOrderTableau [ConvergenceTolerance 1.0e-8] 67 | lobattoIIIAFourthOrderTableau = ButcherTableau [[0,0,0],[((5 NPN./24)::NPN.Double),1 NPN./3,-1 NPN./24],[1 NPN./6,2 NPN./3,1 NPN./6]] [1 NPN./6,2 NPN./3,1 NPN./6] [0,0.5,1] 68 | lobattoIIIAFourthOrder h f (t, state) = impl h f id id (t, state) where 69 | impl = genericRKMethod lobattoIIIAFourthOrderTableau [] 70 | 71 | lobattoIIIAFourthOrderTableauComp = ButcherTableau [[comp 0,comp 0,comp 0],[comp ((5 / 24)),comp 1 / 3,comp (-1) /24],[comp 1 /6,comp 2 /3,comp 1 /6]] [comp 1 /6,comp 2 /3,comp 1 /6] [comp 0,comp 0.5,comp 1] 72 | lobattoIIIAFourthOrderComp h f (t, state) = impl h f id id (t, state) where 73 | impl = genericRKMethod lobattoIIIAFourthOrderTableauComp [] 74 | 75 | 76 | 77 | lobattoIIIBFourthOrderTableau = ButcherTableau [[1 NPN./6,(-1) NPN./6,0],[((1 NPN./6)::NPN.Double),1 NPN./3,0],[1 NPN./6,5 NPN./6, 0]] [1 NPN./6,2 NPN./3,1 NPN./6] [0,0.5,1] 78 | lobattoIIIBFourthOrder h f (t, state) = impl h f id id (t, state) where 79 | impl = genericRKMethod lobattoIIIBFourthOrderTableau [] 80 | 81 | rk4Classical :: (Ord a, Algebra.Algebraic.C a, KnownNat p, KnownNat q) => stateType -> a -> (stateType->stateType) -> ([Multivector p q a] -> stateType) -> (stateType -> [Multivector p q a]) -> stateType 82 | rk4Classical state h f project unproject = project newState where 83 | update = map (\(k1', k2', k3', k4') -> sumList [k1',2*k2',2*k3',k4'] `divideRight` Algebra.Ring.fromInteger 6) $ zip4 k1 k2 k3 k4 84 | newState = zipWith (+) state' update 85 | state' = unproject state 86 | evalDerivatives x = unproject $ f $ project x 87 | k1 = map (h*>) $ evalDerivatives state' 88 | k2 = map (h*>) $ evalDerivatives . map (uncurry (+)) $ zip state' (map (`divideRight` two) k1) 89 | k3 = map (h*>) $ evalDerivatives . map (uncurry (+)) $ zip state' (map (`divideRight` two) k2) 90 | k4 = map (h*>) $ evalDerivatives . map (uncurry (+)) $ zip state' k3 91 | 92 | rk4ClassicalList h f state = rk4Classical h f id id state 93 | -------------------------------------------------------------------------------- /src/Numeric/Clifford/Systems/Components.lhs: -------------------------------------------------------------------------------- 1 | \begin{code} 2 | module Numeric.Clifford.Systems.Components where 3 | import Numeric.Clifford.Multivector 4 | import Numeric.Clifford.LinearOperators 5 | 6 | 7 | 8 | 9 | \end{code} -------------------------------------------------------------------------------- /src/Numeric/Clifford/Systems/Control.lhs: -------------------------------------------------------------------------------- 1 | %include{polycode.fmt} 2 | \begin{code} 3 | {-# LANGUAGE NoImplicitPrelude, UnicodeSyntax #-} 4 | module Numeric.Clifford.Systems.Control where 5 | 6 | import NumericPrelude hiding (foldl, map, take, (!!), foldl1, (.), reverse, zipWith) 7 | --import Numeric.Clifford.Multivector 8 | --import Numeric.Clifford.LinearOperators 9 | --import Numeric.Clifford.Manifold 10 | import Control.Wire 11 | import Data.List.Stream 12 | import Prelude.Unicode 13 | import Algebra.Field 14 | import Number.Ratio 15 | import Data.MemoTrie 16 | import Algebra.ToRational 17 | makeDerivative order = makeNthDerivative 1 order 18 | 19 | 20 | makeNthDerivative n order = stencil where 21 | coefficients = reverse $ nthOrderCoefficients n order 22 | stencil = foldl1 (+) . zipWith (*) coefficients 23 | 24 | 25 | nthOrderCoefficients n order = map fromRational' $ map (δ n order ) [0 .. (order+n-1)] where 26 | δ = generateFiniteDifferenceCoefficients (map toRational [0,-1.. - (order+n)]) 0 27 | 28 | \end{code} 29 | Finite difference coefficients generated from the algorithm in \cite {GenerationOfFiniteDifferenceFormulasOnArbitrarilySpacedGrids} 30 | \begin{code} 31 | 32 | 33 | generateFiniteDifferenceCoefficients ∷ [Rational] → Rational → Integer → Integer → Integer → Rational 34 | generateFiniteDifferenceCoefficients stencil x₀= result where 35 | ω ∷ Integer → Rational → Rational 36 | ω n x = foldl (*) one $ map ((-) x) $ take (fromIntegral n+1) stencil 37 | 38 | α ∷ Integer → Rational 39 | α n = stencil !! (fromIntegral n) 40 | 41 | δ ∷ Integer → Integer → Integer → Rational 42 | δ = memo δ' 43 | δ' 0 0 0 = one 44 | δ' m n ν | m < 0 = zero 45 | | ν > n = zero 46 | | m > n = zero 47 | | ν < n ∧ m ≤ n = ((α n - x₀) * δ m (n - 1) ν - m `scale` δ (m - 1) (n - 1) ν) / (α n - α ν) 48 | | ν ≡ n ∧ m ≤ n = (ω (n - 2) (α (n - 1)) / ω (n - 1) (α n)) * (m `scale` δ (m - 1) (n - 1) (n - 1) - (α (n - 1) - x₀) * δ m (n - 1) (n - 1)) 49 | | otherwise = zero 50 | 51 | result =(\ m approxOrder ν → δ m (m + approxOrder - 1 ) ν ) 52 | 53 | \end{code} -------------------------------------------------------------------------------- /src/Numeric/Clifford/Systems/Discrete/Control.lhs: -------------------------------------------------------------------------------- 1 | \begin{code} 2 | module Numeric.Clifford.Systems.Discrete.Control where 3 | 4 | import Numeric.Clifford.Multivector 5 | import Numeric.Clifford.LinearOperators 6 | import Numeric.Clifford.Manifold 7 | import Control.Wire 8 | 9 | makeDerivative = makeNthDerivative 1 10 | 11 | makeNthDerivative = undefined 12 | 13 | \end{code} -------------------------------------------------------------------------------- /src/biblio.bib: -------------------------------------------------------------------------------- 1 | % This file was created with JabRef 2.10. 2 | % Encoding: UTF8 3 | 4 | 5 | @Book{Arnold1989, 6 | Title = {Mathematical methods of classical mechanics}, 7 | Author = {Arnol'd, Vladimir Igorevich}, 8 | Publisher = {Springer}, 9 | Year = {1989}, 10 | Volume = {60}, 11 | Timestamp = {2014.04.20} 12 | } 13 | 14 | @Article{GenerationOfFiniteDifferenceFormulasOnArbitrarilySpacedGrids, 15 | Title = {Generation of finite difference formulas on arbitrarily spaced grids}, 16 | Author = {Fornberg, Bengt}, 17 | Journal = {Mathematics of computation}, 18 | Year = {1988}, 19 | Number = {184}, 20 | Pages = {699--706}, 21 | Volume = {51} 22 | } 23 | 24 | @Book{Hairer2006, 25 | Title = {Geometric numerical integration: structure-preserving algorithms for ordinary differential equations}, 26 | Author = {Hairer, Ernst and Lubich, Christian and Wanner, Gerhard}, 27 | Publisher = {Springer}, 28 | Year = {2006}, 29 | Volume = {31}, 30 | Timestamp = {2014.04.20} 31 | } 32 | 33 | @Book{hestenes1999new, 34 | Title = {New foundations for classical mechanics}, 35 | Author = {Hestenes, David}, 36 | Publisher = {Springer}, 37 | Year = {1999}, 38 | Edition = {2nd}, 39 | 40 | Doi = {10.1007/0-306-47122-1}, 41 | ISBN = {978-0-7923-5514-4}, 42 | Url = {http://link.springer.com/book/10.1007%2F0-306-47122-1} 43 | } 44 | 45 | @Article{Ogita05accuratesum, 46 | Title = {Accurate Sum and Dot Product}, 47 | Author = {Takeshi Ogita and Siegfried M. Rump and Shin'ichi Oishi}, 48 | Journal = {SIAM J. Sci. Comput}, 49 | Year = {2005}, 50 | Pages = {2005}, 51 | Volume = {26} 52 | } 53 | 54 | @Book{Sussman2001, 55 | Title = {Structure and interpretation of classical mechanics}, 56 | Author = {Sussman, Gerald Jay and Wisdom, Jack and Mayer, Meinhard Edwin}, 57 | Publisher = {MIT Press}, 58 | Year = {2001}, 59 | 60 | Timestamp = {2014.04.20} 61 | } 62 | 63 | @Other{hga, 64 | Title = {HGA: Library for Geometric Algebra in Haskell}, 65 | Altauthor = {Issac Trotts}, 66 | Altyear = {2011}, 67 | Url = {https://github.com/ijt/hga} 68 | } 69 | 70 | -------------------------------------------------------------------------------- /src/exponentialDecay.hs: -------------------------------------------------------------------------------- 1 | module Clifford.Demo.ExponentialDecay where 2 | import Clifford 3 | import Debug.Trace 4 | import qualified NumericPrelude.Numeric as NPN 5 | import Algebra.Module 6 | expDecay _ x = map negate $ map ((*) (1.0 `e` [])) x --Debug.Trace.trace ("Input of expdecay is " ++ show x) x 7 | decay = map (\(t, x) -> (t,magnitude $ head x)) $ iterate (\init -> lobattoIIIAFourthOrder init 0.01 expDecay) (0.0::NPN.Double,[scalar (1.0::NPN.Double)]) 8 | decayTol = map (\(t, x) -> (t,magnitude $ head x)) $ iterate (\init -> lobattoIIIAFourthOrderWithTol init 0.01 expDecay) (0.0::NPN.Double,[scalar (1.0::NPN.Double)]) 9 | -------------------------------------------------------------------------------- /test/Numeric/Clifford/BladeSpec.lhs: -------------------------------------------------------------------------------- 1 | \begin{code} 2 | 3 | module Numeric.Clifford.BladeSpec (main, spec) where 4 | 5 | import Test.Hspec 6 | import Test.QuickCheck 7 | import Numeric.Clifford.Blade 8 | import Algebra.Ring 9 | main :: IO () 10 | main = hspec spec 11 | 12 | spec :: Spec 13 | spec = do 14 | let a = Blade 1.0 [0] :: Blade 3 1 Double 15 | let b = Blade 2.0 [1] :: Blade 3 1 Double 16 | let ab = Blade 2.0 [0,1] :: Blade 3 1 Double 17 | let c = Blade 3.0 [1,2] :: Blade 3 1 Double 18 | let d = Blade 4.0 [2] :: Blade 3 1 Double 19 | let e = Blade 2.0 [0] :: Blade 3 1 Double 20 | let f = Blade 3.0 [0] :: Blade 3 1 Double 21 | --todo: Memoise the blade index sorting function. 22 | describe "bladeMul" $ do 23 | it "multiplies an n-blade with an m-blade to give an n+m blade if each index is unique" $ do 24 | (a `bladeMul` b) `shouldBe` ab 25 | it "should handle duplicate blades which square to +1 due to metric signature" $ do 26 | c `bladeMul` d `shouldBe` Blade 12.0 [1] 27 | it "should handle diplicate blades which square to -1 due to metric signature" $ do 28 | e `bladeMul` f `shouldBe` Blade (-6.0) [] 29 | context "leaves blades unchanged when multiplied by a scalar of 1" $ do 30 | it "on the left" $ property $ 31 | \x -> (Blade one []) `bladeMul` x == (x::Blade 3 1 Double) 32 | it "on the right" $ property $ 33 | \x -> x `bladeMul` (Blade one []) == (x::Blade 3 1 Double) 34 | 35 | \end{code} -------------------------------------------------------------------------------- /test/Numeric/Clifford/MultivectorSpec.lhs: -------------------------------------------------------------------------------- 1 | \begin{code} 2 | 3 | module Numeric.Clifford.MultivectorSpec (main, spec) where 4 | import Prelude hiding ((^), (*)) 5 | import Test.Hspec 6 | import Test.QuickCheck 7 | import Numeric.Clifford.Multivector 8 | import Algebra.Ring 9 | import Algebra.Algebraic 10 | --import Numeric.Natural 11 | import Algebra.Additive (zero) 12 | import Control.Exception (evaluate) 13 | main :: IO () 14 | main = hspec spec 15 | 16 | 17 | spec :: Spec 18 | spec = do 19 | let i = 1.0 `e` [1,2] :: STVector 20 | let fuckOffSized = (i + (scalar 3.8) + (1.1 `e` [0])) :: STVector 21 | let comp a b = compareTol a b 0.0000001 22 | describe "addition" $ do 23 | it "is assiocitive" $ property (\a (b::STVector) -> a + b == b + a) 24 | describe "multiplication" $ do 25 | it "should square unit bivectors to -1" $ do 26 | i*i `shouldBe` scalar (-1.0) 27 | describe "root n" $ do 28 | it "cannot compute the 0th root" $ do 29 | evaluate (root 0 i) `shouldThrow` anyErrorCall 30 | it "cannot compute a root of 0" $ do 31 | evaluate (root 1 (zero::STVector)) `shouldThrow` anyErrorCall 32 | it "computes the nth root of a value" $ do 33 | comp ((root 3 fuckOffSized)^3) fuckOffSized `shouldBe` True 34 | 35 | {-it "computes the nth root of a vector. May fail to terminate." $ verbose prop where 36 | prop x k= (magnitude (abs ((rooted ^ n) - x))) <= 0.000001 || x == zero || n == zero where 37 | n :: Integer 38 | n = (fromIntegral (k::Natural)) `mod` 6 39 | rooted :: STVector 40 | rooted = root n x-} 41 | 42 | 43 | \end{code} -------------------------------------------------------------------------------- /test/Spec.lhs: -------------------------------------------------------------------------------- 1 | \begin{code} 2 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 3 | \end{code} --------------------------------------------------------------------------------