linear 1.22 → 1.23
raw patch · 41 files changed
+7641/−7570 lines, 41 filesdep +QuickCheckdep +test-framework-quickcheck2dep ~hashabledep ~randomsetup-changed
Dependencies added: QuickCheck, test-framework-quickcheck2
Dependency ranges changed: hashable, random
Files
- .gitignore +32/−32
- .hlint.yaml +7/−7
- .vim.custom +21/−21
- CHANGELOG.markdown +414/−407
- LICENSE +30/−30
- README.markdown +15/−15
- Setup.lhs +7/−7
- linear.cabal +153/−145
- src/Linear.hs +48/−48
- src/Linear/Affine.hs +307/−307
- src/Linear/Algebra.hs +136/−136
- src/Linear/Binary.hs +27/−27
- src/Linear/Conjugate.hs +86/−86
- src/Linear/Covector.hs +73/−73
- src/Linear/Epsilon.hs +51/−51
- src/Linear/Instances.hs +14/−14
- src/Linear/Matrix.hs +731/−731
- src/Linear/Metric.hs +110/−110
- src/Linear/Plucker.hs +700/−698
- src/Linear/Plucker/Coincides.hs +38/−38
- src/Linear/Projection.hs +260/−260
- src/Linear/Quaternion.hs +707/−707
- src/Linear/Trace.hs +116/−116
- src/Linear/V.hs +600/−600
- src/Linear/V0.hs +371/−371
- src/Linear/V1.hs +410/−410
- src/Linear/V2.hs +501/−501
- src/Linear/V3.hs +516/−514
- src/Linear/V4.hs +659/−657
- src/Linear/Vector.hs +354/−349
- tests/Binary.hs +0/−19
- tests/Plucker.hs +0/−35
- tests/Prop/Quaternion.hs +28/−0
- tests/Prop/V3.hs +8/−0
- tests/Test.hs +25/−0
- tests/Unit/Binary.hs +19/−0
- tests/Unit/Plucker.hs +35/−0
- tests/Unit/V.hs +13/−0
- tests/UnitTests.hs +0/−16
- tests/V.hs +0/−13
- tests/doctests.hs +19/−19
.gitignore view
@@ -1,32 +1,32 @@-dist -dist-newstyle -docs -wiki -TAGS -tags -wip -.DS_Store -.*.swp -.*.swo -*.o -*.hi -*~ -*# -.stack-work/ -cabal-dev -*.chi -*.chs.h -*.dyn_o -*.dyn_hi -.hpc -.hsenv -.cabal-sandbox/ -cabal.sandbox.config -*.prof -*.aux -*.hp -*.eventlog -cabal.project.local -cabal.project.local~ -.HTF/ -.ghc.environment.* +dist+dist-newstyle+docs+wiki+TAGS+tags+wip+.DS_Store+.*.swp+.*.swo+*.o+*.hi+*~+*#+.stack-work/+cabal-dev+*.chi+*.chs.h+*.dyn_o+*.dyn_hi+.hpc+.hsenv+.cabal-sandbox/+cabal.sandbox.config+*.prof+*.aux+*.hp+*.eventlog+cabal.project.local+cabal.project.local~+.HTF/+.ghc.environment.*
.hlint.yaml view
@@ -1,7 +1,7 @@-- arguments: [-XCPP] - -- ignore: {name: Use fmap} -- ignore: {name: Avoid lambda} -- ignore: {name: Redundant lambda} -- ignore: {name: Unused LANGUAGE pragma} -- ignore: {name: Eta reduce, within: [Linear.Plucker, Linear.Quaternion, Linear.V, Linear.V0, Linear.V1, Linear.V2, Linear.V3, Linear.V4]} +- arguments: [-XCPP]++- ignore: {name: Use fmap}+- ignore: {name: Avoid lambda}+- ignore: {name: Redundant lambda}+- ignore: {name: Unused LANGUAGE pragma}+- ignore: {name: Eta reduce, within: [Linear.Plucker, Linear.Quaternion, Linear.V, Linear.V0, Linear.V1, Linear.V2, Linear.V3, Linear.V4]}
.vim.custom view
@@ -1,21 +1,21 @@-" Add the following to your .vimrc to automatically load this on startup -" if filereadable(".vim.custom") -" so .vim.custom -" endif - -function StripTrailingWhitespace() - let myline=line(".") - let mycolumn = col(".") - silent %s/ *$// - call cursor(myline, mycolumn) -endfunction - -syntax on -set tags=TAGS;/ -set listchars=tab:‗‗,trail:‗ -set list - -map <F2> :exec ":!hasktags -x -c --ignore src"<CR><CR> - -au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace() -au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src" +" Add the following to your .vimrc to automatically load this on startup+" if filereadable(".vim.custom")+" so .vim.custom+" endif++function StripTrailingWhitespace()+ let myline=line(".")+ let mycolumn = col(".")+ silent %s/ *$//+ call cursor(myline, mycolumn)+endfunction++syntax on+set tags=TAGS;/+set listchars=tab:‗‗,trail:‗+set list++map <F2> :exec ":!hasktags -x -c --ignore src"<CR><CR>++au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace()+au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src"
CHANGELOG.markdown view
@@ -1,407 +1,414 @@-1.22 [2022.11.30] ------------------ -* The types of `_Point` and `lensP` have been generalized: - - ```diff - -_Point :: Iso' (Point f a) (f a) - +_Point :: Iso (Point f a) (Point g b) (f a) (g b) - - -lensP :: Lens' (Point g a) (g a) - +lensP :: Lens (Point f a) (Point g b) (f a) (g b) - ``` - - There is a chance that existing uses of `_Point` or `lensP` will fail to - typecheck due to their more general types. You can use `_Point.simple` or - `lensP.simple` to restore their old, more restricted types (where `simple` - comes from `Control.Lens` in the `lens` library). - -1.21.10 [2022.06.21] --------------------- -* Allow building with `vector-0.13.*`. - -1.21.9 [2022.05.18] -------------------- -* Allow building with `transformers-0.6.*`. - -1.21.8 [2021.11.15] -------------------- -* Allow building with `hashable-1.4.*`. -* Drop support for pre-8.0 versions of GHC. - -1.21.7 [2021.09.20] -------------------- -* Fix a build error when using `random-1.2.1` or later. - -1.21.6 [2021.07.05] -------------------- -* Fix a build error when configured with `-template-haskell`. - -1.21.5 [2021.02.18] -------------------- -* Allow building with `lens-5.*`. - -1.21.4 [2021.01.29] -------------------- -* Allow building with `vector-0.12.2` or later. -* The build-type has been changed from `Custom` to `Simple`. - To achieve this, the `doctests` test suite has been removed in favor of using - [`cabal-docspec`](https://github.com/phadej/cabal-extras/tree/master/cabal-docspec) - to run the doctests. - -1.21.3 [2020.10.03] -------------------- -* Allow building with GHC 9.0. - -1.21.2 [2020.09.30] -------------------- -* Use `base-orphans-0.8.3` or later. This means that the `Linear.Instances` - module no longer defines any orphan instances of its own, and the module is - now a simple shim on top of `Data.Orphans` from `base-orphans`. - -1.21.1 [2020.06.25] -------------------- -* Allow building with `random-1.2.*`. - -1.21 [2020.02.03] ------------------ -* Add instances for direct sums (`Product`) and tensor products (`Compose`) of - other vector spaces. This makes is much more convenient to do things like treat - a matrix temporarily as a vector through Compose, or to consider things like - Gauss-Jordan elimination, which wants augmented structures. -* Add `frobenius` for computing the Frobenius norm of a matrix. -* Added `Random` instances for `System.Random`. We had an indirect dependency - through `vector` anyways. -* Add "obvious" zipping `Semigroup` and `Monoid` instances to all the - representable vector spaces. -* Add `R1`..`R4` instances to `Quaternion`. `_w` is the scalar component so that - `_x`,`_y`,`_z` can be directional. -* Add more solvers to `Linear.Matrix`, available with `base-4.8` or later. -* Add `unangle` function to `Linear.V2`. - -1.20.9 [2019.05.02] -------------------- -* Derive `Lift` instances for `Plucker`, `Quaternion`, and `V{0,1,2,3,4}`. - -1.20.8 [2018.07.03] -------------------- -* Add instances of the `Field` classes from `lens`. -* Add `Epsilon` instance for `Complex`. -* Use specialized implementations of the `null` and `length` methods in - `Foldable` instances. -* Add `Hashable1` instances for data types in `linear`. Also add a - `Hashable` instance for `V`. -* Fix a bug in which `Quaternion`s were incorrectly exponentiated. - -1.20.7 ------- -* Support `semigroupoids-5.2.1` and `doctest-0.12` - -1.20.6 ------- -* Revamp `Setup.hs` to use `cabal-doctest`. This makes it build - with `Cabal-2.0`, and makes the `doctest`s work with `cabal new-build` and - sandboxes. -* Make `(1 / x)` and `recip x` agree in the `Fractional` instance for `Quaternion` -* Use newtype instances for `Point` vectors in `Linear.Affine` -* Enable `PolyKinds` in `Linear.Trace`. Also enable `PolyKinds` when GHC 7.6 or - later is used (previously, it was GHC 7.8 or later). -* Fix a segfault arising from the `MVector` instance for `V` -* Add `Finite` class for conversion between `V` and fixed-size vector types - -1.20.5 ------- -* GHC 8 compatibility -* Fixed the `perspective` calculation. - -1.20.4 ------- -* Compatibility with `base-orphans` 0.5 - -1.20.3 ------- -* Support `vector` 0.11.0.0. -* Support `cereal` 0.5 -* You can now unboxed vectors of `V n` vectors. - -1.20.2 ------- -* Modified the `doctest` machinery to work with `stack` and builds to non-standard locations. -* Removed the local `.ghci` file. -* Various numerical stability improvements were made to the quaternion and projection functions. - -1.20.1 ------- -* Fixed doctests broken by the previous change. -* Unboxed vector instances for various linear data types now use unpacked integers even on older GHCs. - -1.20 ----- -* `inv22`, `inv33` and `inv44` no longer attempt an epsilon check. They no longer return a `Maybe` result as a consequence. - You should filter for the 0 determinant case yourself. - -1.19.1.3 --------- -* `vector` 0.11.0.0 support - -1.19.1.2 --------- -* Fix GHC 7.4. - -1.19.1.1 --------- -* Proper `reflection` 2 support - -1.19.1 ------- -* `reflection` 2 support - -1.19 ----- -* Change the Ixed instance for `Linear.V` to use `Int` as the index type. This makes `V n` a _lot_ easier to use. - -1.18.3 ------- -* Compile warning-free on GHC 7.10. - - -1.18.2 ------- -* Added `NFData` instance for `Point` - -1.18.1 ------- -* Added an `-f-template-haskell` option to allow disabling `template-haskell` support. This is an unsupported configuration but may be useful for expert users in sandbox configurations. -* Added lenses for extracting corner various sub-matrices e.g. `_m22`, `_m33` - -1.18.0.2 --------- -* Fixed builds on even older GHCs. - -1.18.0.1 --------- -* Fixed the test suite. -* Fixed builds on older GHCs. - -1.18 ----- -* Consolidated `eye2` .. `eye4` into a single `identity` combinator. -* Fixed the `Data` instance `V n a` for GHC 7.10-RC3. - -1.17.1.1 --------- -* `filepath` 1.4 support - -1.17.1 ------- -* Added support for `Data.Functor.Classes` from `transformers` 0.5 via `transformers-compat`. -* Added missing support for `binary`, `bytes` and `cereal` for `Point` - -1.17 ----- -* Better support for `binary`. Added support for `bytes` and `cereal` - -1.16.4 ------- -* `ortho` and `inverseOrtho` now only require a `Fractional` constraint. -* Added missing `Floating` instances. - -1.16.3 ----- -* Improve the performance of `fromQuaternion`, `mkTransformation`, - `mkTransformationMat`, `basisFor`, `scaled` by using implementations - that inline well for functions that were previously reference - implementations. - -1.16.2 ----- -* Added `NFData` instances for the various vector types. -* Added `!!/` operator for matrix division by scalar. - -1.16.1 ----- -* Added `Trace` instance for `V1`. - -1.16 ----- -* Renamed `kronecker` to `scaled`. - -1.15.5 ------- -* Added `Metric` instances for `[]`, `ZipList`, `Maybe` -* Added `det44` and `inv44` to `Linear.Matrix` -* Added `Data` instance for `Point` - -1.15.4 ------- -* Added Typeable and Data instances for V - -1.15.3 ------- -* Added missing `FunctorWithIndex`, `FoldableWithIndex` and `TraversableWithIndex Int (V n)` instances for `V` - -1.15.2 ------- -* Added `frustum`, analogous to the old `glFrustum` call. -* Added `inverseInfinitePerspective`, `inverseOrtho`, `inverseFrustum`. - -1.15.1 ------- -* Added `inversePerspective`. It is much more accurate to compute it directly than to compute an inverse. - -1.15.0.1 --------- -* Fixed build failures caused by `Linear` re-exporting the old name. - -1.15 ----- -* Renamed `Linear.Perspective` to `Linear.Projection`. -* Fixed a build issue with GHC HEAD. - -1.14.0.1 --------- -* Fixed test failures caused by 1.14 - -1.14 ----- -* Moved `Coincides` to `Linear.Plucker.Coincides`. The constructors `Line` and `Ray` oft collided with user code. - -1.13 ----- -* Switched 'ortho' to follow the OpenGL handedness. - -1.12.1 ------- -* Added "swizzle" lenses **e.g.** `_yzx`, which are useful for working with libraries like `gl`. - -1.12 ------- -* Added 'transpose' -* Added missing 'Mxy' matrices up to 4 dimensions -- they were commonly reimplemented by users. - -1.11.3 ------- -* Fixed an issue with `UndecidableInstances` on GHC 7.6.3 - -1.11.2 ------- -* Added `Linear.Perspective`. - -1.11.1 ------- -* Added `_Point`, `relative` and a few instances for `Point`. - -1.11 ----- -* Changed the 'representation' of `V n` from `E (V n)`, which was hard to use, to `Int`, which is a bit too permissive, but is easy to use. - -1.10.1 ------- -* Added `Linear.V2.angle`. - -1.10 ----- -* Added `Hashable` instances. - -1.9.1 ------ -* Added a role annotation to `V n a` to prevent users from using GHC 7.8's `Coercible` machinery to violate invariants. - -1.9.0.1 ------ -* Fixed a broken build - -1.9 ---- -* Added `MonadZip` instances. -* Added `MonadFix` instances. -* Added `Control.Lens.Each.Each` instances - -1.8.1 ------ -* Bugfixed `slerp` - -1.8 ---- -* Added missing `Unbox` instances for working with unboxed vectors of `linear` data types. - -1.7 ---- -* Fixed `axisAngle` -* `unit` now has a rank 1 type. - -1.5 ---- -* `lens` 4 compatibility - -1.4 ---- -* Renamed `incore` to `column` and added an example. - -1.3.1.1 -------- -* Build bugfix - -1.3.1 ---- -* Better implementations of `basis` and `basisFor`. -* Derived Generic instances. - -1.2 ---- -* Improved matrix multiplication to properly support the sparse/sparse case. - -1.1.4 ------ -* Marked modules `Trustworthy` as necessary. - -1.1.2 ------ -* Dependency bump for `reflection` compatibility - -1.1.1 ------ -* Fixed an infinite loop in the default definition of `liftI2`. - -1.1 ---- -* Added `Additive` instances for `[]`, `Maybe` and `Vector`. - -1.0 ---- -* Strict vectors -* Exported `mkTransformationMat` -* Bumped dependency bounds - -0.9.1 [bug fix] ------ -* Exported `Linear.V0`! - -0.9 ---- -* Added sparse vector support. - -0.8 ---- -* Added `Linear.V0` - -0.7 ---- -* Added `Linear.Instances` -* More documentation - -0.6 ---- -* Removed the direct dependency on `lens`. -* Added `Linear.Core` to cover vector spaces as corepresentable functors. - -0.5 -------- -* Added `Ix` instances for `V2`, `V3`, and `V4` - -0.4.2.2 -------- -* Removed the upper bound on `distributive` - -0.2 ---- -* Initial hackage release +1.23 [2024.04.15]+-----------------+* The direction of interpolation of `lerp` has been reversed;+ now `lerp 0 a b == a` and `lerp 1 a b == b`.+ This brings `lerp` in line not only with its implementation+ in other languages and frameworks, but also with `slerp` in this package.++1.22 [2022.11.30]+-----------------+* The types of `_Point` and `lensP` have been generalized:++ ```diff+ -_Point :: Iso' (Point f a) (f a)+ +_Point :: Iso (Point f a) (Point g b) (f a) (g b)++ -lensP :: Lens' (Point g a) (g a)+ +lensP :: Lens (Point f a) (Point g b) (f a) (g b)+ ```++ There is a chance that existing uses of `_Point` or `lensP` will fail to+ typecheck due to their more general types. You can use `_Point.simple` or+ `lensP.simple` to restore their old, more restricted types (where `simple`+ comes from `Control.Lens` in the `lens` library).++1.21.10 [2022.06.21]+--------------------+* Allow building with `vector-0.13.*`.++1.21.9 [2022.05.18]+-------------------+* Allow building with `transformers-0.6.*`.++1.21.8 [2021.11.15]+-------------------+* Allow building with `hashable-1.4.*`.+* Drop support for pre-8.0 versions of GHC.++1.21.7 [2021.09.20]+-------------------+* Fix a build error when using `random-1.2.1` or later.++1.21.6 [2021.07.05]+-------------------+* Fix a build error when configured with `-template-haskell`.++1.21.5 [2021.02.18]+-------------------+* Allow building with `lens-5.*`.++1.21.4 [2021.01.29]+-------------------+* Allow building with `vector-0.12.2` or later.+* The build-type has been changed from `Custom` to `Simple`.+ To achieve this, the `doctests` test suite has been removed in favor of using+ [`cabal-docspec`](https://github.com/phadej/cabal-extras/tree/master/cabal-docspec)+ to run the doctests.++1.21.3 [2020.10.03]+-------------------+* Allow building with GHC 9.0.++1.21.2 [2020.09.30]+-------------------+* Use `base-orphans-0.8.3` or later. This means that the `Linear.Instances`+ module no longer defines any orphan instances of its own, and the module is+ now a simple shim on top of `Data.Orphans` from `base-orphans`.++1.21.1 [2020.06.25]+-------------------+* Allow building with `random-1.2.*`.++1.21 [2020.02.03]+-----------------+* Add instances for direct sums (`Product`) and tensor products (`Compose`) of+ other vector spaces. This makes is much more convenient to do things like treat+ a matrix temporarily as a vector through Compose, or to consider things like+ Gauss-Jordan elimination, which wants augmented structures.+* Add `frobenius` for computing the Frobenius norm of a matrix.+* Added `Random` instances for `System.Random`. We had an indirect dependency+ through `vector` anyways.+* Add "obvious" zipping `Semigroup` and `Monoid` instances to all the+ representable vector spaces.+* Add `R1`..`R4` instances to `Quaternion`. `_w` is the scalar component so that+ `_x`,`_y`,`_z` can be directional.+* Add more solvers to `Linear.Matrix`, available with `base-4.8` or later.+* Add `unangle` function to `Linear.V2`.++1.20.9 [2019.05.02]+-------------------+* Derive `Lift` instances for `Plucker`, `Quaternion`, and `V{0,1,2,3,4}`.++1.20.8 [2018.07.03]+-------------------+* Add instances of the `Field` classes from `lens`.+* Add `Epsilon` instance for `Complex`.+* Use specialized implementations of the `null` and `length` methods in+ `Foldable` instances.+* Add `Hashable1` instances for data types in `linear`. Also add a+ `Hashable` instance for `V`.+* Fix a bug in which `Quaternion`s were incorrectly exponentiated.++1.20.7+------+* Support `semigroupoids-5.2.1` and `doctest-0.12`++1.20.6+------+* Revamp `Setup.hs` to use `cabal-doctest`. This makes it build+ with `Cabal-2.0`, and makes the `doctest`s work with `cabal new-build` and+ sandboxes.+* Make `(1 / x)` and `recip x` agree in the `Fractional` instance for `Quaternion`+* Use newtype instances for `Point` vectors in `Linear.Affine`+* Enable `PolyKinds` in `Linear.Trace`. Also enable `PolyKinds` when GHC 7.6 or+ later is used (previously, it was GHC 7.8 or later).+* Fix a segfault arising from the `MVector` instance for `V`+* Add `Finite` class for conversion between `V` and fixed-size vector types++1.20.5+------+* GHC 8 compatibility+* Fixed the `perspective` calculation.++1.20.4+------+* Compatibility with `base-orphans` 0.5++1.20.3+------+* Support `vector` 0.11.0.0.+* Support `cereal` 0.5+* You can now unboxed vectors of `V n` vectors.++1.20.2+------+* Modified the `doctest` machinery to work with `stack` and builds to non-standard locations.+* Removed the local `.ghci` file.+* Various numerical stability improvements were made to the quaternion and projection functions.++1.20.1+------+* Fixed doctests broken by the previous change.+* Unboxed vector instances for various linear data types now use unpacked integers even on older GHCs.++1.20+----+* `inv22`, `inv33` and `inv44` no longer attempt an epsilon check. They no longer return a `Maybe` result as a consequence.+ You should filter for the 0 determinant case yourself.++1.19.1.3+--------+* `vector` 0.11.0.0 support++1.19.1.2+--------+* Fix GHC 7.4.++1.19.1.1+--------+* Proper `reflection` 2 support++1.19.1+------+* `reflection` 2 support++1.19+----+* Change the Ixed instance for `Linear.V` to use `Int` as the index type. This makes `V n` a _lot_ easier to use.++1.18.3+------+* Compile warning-free on GHC 7.10.+++1.18.2+------+* Added `NFData` instance for `Point`++1.18.1+------+* Added an `-f-template-haskell` option to allow disabling `template-haskell` support. This is an unsupported configuration but may be useful for expert users in sandbox configurations.+* Added lenses for extracting corner various sub-matrices e.g. `_m22`, `_m33`++1.18.0.2+--------+* Fixed builds on even older GHCs.++1.18.0.1+--------+* Fixed the test suite.+* Fixed builds on older GHCs.++1.18+----+* Consolidated `eye2` .. `eye4` into a single `identity` combinator.+* Fixed the `Data` instance `V n a` for GHC 7.10-RC3.++1.17.1.1+--------+* `filepath` 1.4 support++1.17.1+------+* Added support for `Data.Functor.Classes` from `transformers` 0.5 via `transformers-compat`.+* Added missing support for `binary`, `bytes` and `cereal` for `Point`++1.17+----+* Better support for `binary`. Added support for `bytes` and `cereal`++1.16.4+------+* `ortho` and `inverseOrtho` now only require a `Fractional` constraint.+* Added missing `Floating` instances.++1.16.3+----+* Improve the performance of `fromQuaternion`, `mkTransformation`,+ `mkTransformationMat`, `basisFor`, `scaled` by using implementations+ that inline well for functions that were previously reference+ implementations.++1.16.2+----+* Added `NFData` instances for the various vector types.+* Added `!!/` operator for matrix division by scalar.++1.16.1+----+* Added `Trace` instance for `V1`.++1.16+----+* Renamed `kronecker` to `scaled`.++1.15.5+------+* Added `Metric` instances for `[]`, `ZipList`, `Maybe`+* Added `det44` and `inv44` to `Linear.Matrix`+* Added `Data` instance for `Point`++1.15.4+------+* Added Typeable and Data instances for V++1.15.3+------+* Added missing `FunctorWithIndex`, `FoldableWithIndex` and `TraversableWithIndex Int (V n)` instances for `V`++1.15.2+------+* Added `frustum`, analogous to the old `glFrustum` call.+* Added `inverseInfinitePerspective`, `inverseOrtho`, `inverseFrustum`.++1.15.1+------+* Added `inversePerspective`. It is much more accurate to compute it directly than to compute an inverse.++1.15.0.1+--------+* Fixed build failures caused by `Linear` re-exporting the old name.++1.15+----+* Renamed `Linear.Perspective` to `Linear.Projection`.+* Fixed a build issue with GHC HEAD.++1.14.0.1+--------+* Fixed test failures caused by 1.14++1.14+----+* Moved `Coincides` to `Linear.Plucker.Coincides`. The constructors `Line` and `Ray` oft collided with user code.++1.13+----+* Switched 'ortho' to follow the OpenGL handedness.++1.12.1+------+* Added "swizzle" lenses **e.g.** `_yzx`, which are useful for working with libraries like `gl`.++1.12+------+* Added 'transpose'+* Added missing 'Mxy' matrices up to 4 dimensions -- they were commonly reimplemented by users.++1.11.3+------+* Fixed an issue with `UndecidableInstances` on GHC 7.6.3++1.11.2+------+* Added `Linear.Perspective`.++1.11.1+------+* Added `_Point`, `relative` and a few instances for `Point`.++1.11+----+* Changed the 'representation' of `V n` from `E (V n)`, which was hard to use, to `Int`, which is a bit too permissive, but is easy to use.++1.10.1+------+* Added `Linear.V2.angle`.++1.10+----+* Added `Hashable` instances.++1.9.1+-----+* Added a role annotation to `V n a` to prevent users from using GHC 7.8's `Coercible` machinery to violate invariants.++1.9.0.1+-----+* Fixed a broken build++1.9+---+* Added `MonadZip` instances.+* Added `MonadFix` instances.+* Added `Control.Lens.Each.Each` instances++1.8.1+-----+* Bugfixed `slerp`++1.8+---+* Added missing `Unbox` instances for working with unboxed vectors of `linear` data types.++1.7+---+* Fixed `axisAngle`+* `unit` now has a rank 1 type.++1.5+---+* `lens` 4 compatibility++1.4+---+* Renamed `incore` to `column` and added an example.++1.3.1.1+-------+* Build bugfix++1.3.1+---+* Better implementations of `basis` and `basisFor`.+* Derived Generic instances.++1.2+---+* Improved matrix multiplication to properly support the sparse/sparse case.++1.1.4+-----+* Marked modules `Trustworthy` as necessary.++1.1.2+-----+* Dependency bump for `reflection` compatibility++1.1.1+-----+* Fixed an infinite loop in the default definition of `liftI2`.++1.1+---+* Added `Additive` instances for `[]`, `Maybe` and `Vector`.++1.0+---+* Strict vectors+* Exported `mkTransformationMat`+* Bumped dependency bounds++0.9.1 [bug fix]+-----+* Exported `Linear.V0`!++0.9+---+* Added sparse vector support.++0.8+---+* Added `Linear.V0`++0.7+---+* Added `Linear.Instances`+* More documentation++0.6+---+* Removed the direct dependency on `lens`.+* Added `Linear.Core` to cover vector spaces as corepresentable functors.++0.5+-------+* Added `Ix` instances for `V2`, `V3`, and `V4`++0.4.2.2+-------+* Removed the upper bound on `distributive`++0.2+---+* Initial hackage release
LICENSE view
@@ -1,30 +1,30 @@-Copyright 2011-2015 Edward Kmett - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: - -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR -IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR -ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS -OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, -STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN -ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. +Copyright 2011-2015 Edward Kmett++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
README.markdown view
@@ -1,15 +1,15 @@-linear -====== - -[](https://hackage.haskell.org/package/linear) [](https://github.com/ekmett/linear/actions?query=workflow%3AHaskell-CI) - -Highly polymorphic vector space operations on sparse and free vector spaces. - -Contact Information -------------------- - -Contributions and bug reports are welcome! - -Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. - --Edward Kmett +linear+======++[](https://hackage.haskell.org/package/linear) [](https://github.com/ekmett/linear/actions?query=workflow%3AHaskell-CI)++Highly polymorphic vector space operations on sparse and free vector spaces.++Contact Information+-------------------++Contributions and bug reports are welcome!++Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net.++-Edward Kmett
Setup.lhs view
@@ -1,7 +1,7 @@-#!/usr/bin/runhaskell -> module Main (main) where - -> import Distribution.Simple - -> main :: IO () -> main = defaultMain +#!/usr/bin/runhaskell+> module Main (main) where++> import Distribution.Simple++> main :: IO ()+> main = defaultMain
linear.cabal view
@@ -1,145 +1,153 @@-name: linear -category: Math, Algebra -version: 1.22 -license: BSD3 -cabal-version: >= 1.10 -license-file: LICENSE -author: Edward A. Kmett -maintainer: Edward A. Kmett <ekmett@gmail.com> -stability: provisional -homepage: http://github.com/ekmett/linear/ -bug-reports: http://github.com/ekmett/linear/issues -copyright: Copyright (C) 2012-2015 Edward A. Kmett -synopsis: Linear Algebra -description: Types and combinators for linear algebra on free vector spaces -build-type: Simple -tested-with: GHC == 8.0.2 - , GHC == 8.2.2 - , GHC == 8.4.4 - , GHC == 8.6.5 - , GHC == 8.8.4 - , GHC == 8.10.7 - , GHC == 9.0.2 - , GHC == 9.2.2 -extra-source-files: - .gitignore - .hlint.yaml - .vim.custom - CHANGELOG.markdown - README.markdown - -flag template-haskell - description: - You can disable the use of the `template-haskell` package using `-f-template-haskell`. - . - Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. - default: True - manual: True - -flag herbie - description: Enable `herbie`. - default: False - manual: True - -source-repository head - type: git - location: https://github.com/ekmett/linear - -library - build-depends: - adjunctions >= 4 && < 5, - base >= 4.9 && < 5, - base-orphans >= 0.8.3 && < 1, - binary >= 0.5 && < 0.9, - bytes >= 0.15 && < 1, - cereal >= 0.4.1.1 && < 0.6, - containers >= 0.4 && < 0.7, - deepseq >= 1.1 && < 1.5, - distributive >= 0.5.1 && < 1, - ghc-prim, - hashable >= 1.2.7.0 && < 1.5, - indexed-traversable >= 0.1.1 && < 0.2, - lens >= 4.15.2 && < 6, - random >= 1.0 && < 1.3, - reflection >= 2 && < 3, - semigroupoids >= 5.2.1 && < 6, - tagged >= 0.8.6 && < 1, - transformers >= 0.5 && < 0.7, - transformers-compat >= 0.5.0.4 && < 1, - unordered-containers >= 0.2.3 && < 0.3, - vector >= 0.12.1.2 && < 0.14, - void >= 0.6 && < 1 - - if impl(ghc < 8.0) - build-depends: semigroups >= 0.9 && < 1 - - if flag(template-haskell) && impl(ghc) - build-depends: template-haskell >= 2.11.1.0 && < 3.0 - - if flag(herbie) - build-depends: HerbiePlugin >= 0.1 && < 0.2 - ghc-options: -fplugin=Herbie - cpp-options: -DHERBIE - - exposed-modules: - Linear - Linear.Affine - Linear.Algebra - Linear.Binary - Linear.Conjugate - Linear.Covector - Linear.Epsilon - Linear.Instances - Linear.Matrix - Linear.Metric - Linear.Plucker - Linear.Plucker.Coincides - Linear.Projection - Linear.Quaternion - Linear.Trace - Linear.V - Linear.V0 - Linear.V1 - Linear.V2 - Linear.V3 - Linear.V4 - Linear.Vector - - ghc-options: -Wall -Wtabs -O2 -fdicts-cheap -funbox-strict-fields -Wno-trustworthy-safe - hs-source-dirs: src - - default-language: Haskell2010 - - x-docspec-extra-packages: simple-reflect - --- We need this dummy test-suite to add simple-reflect to the install plan --- --- When cabal-install's extra-packages support becomes widely available --- (i.e. after 3.4 release), we can remove this test-suite. -test-suite doctests - type: exitcode-stdio-1.0 - main-is: doctests.hs - hs-source-dirs: tests - default-language: Haskell2010 - - build-depends: base, simple-reflect >= 0.3.1 - -test-suite UnitTests - type: exitcode-stdio-1.0 - main-is: UnitTests.hs - other-modules: Plucker, Binary, V - ghc-options: -Wall -threaded - hs-source-dirs: tests - build-depends: - base, - binary, - bytestring, - deepseq, - test-framework >= 0.8, - test-framework-hunit >= 0.3, - HUnit >= 1.2.5, - linear, - reflection, - vector - default-language: Haskell2010 - +name: linear+category: Math, Algebra+version: 1.23+license: BSD3+cabal-version: >= 1.10+license-file: LICENSE+author: Edward A. Kmett+maintainer: Edward A. Kmett <ekmett@gmail.com>+stability: provisional+homepage: http://github.com/ekmett/linear/+bug-reports: http://github.com/ekmett/linear/issues+copyright: Copyright (C) 2012-2015 Edward A. Kmett+synopsis: Linear Algebra+description: Types and combinators for linear algebra on free vector spaces+build-type: Simple+tested-with: GHC == 8.0.2+ , GHC == 8.2.2+ , GHC == 8.4.4+ , GHC == 8.6.5+ , GHC == 8.8.4+ , GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.8+ , GHC == 9.4.5+ , GHC == 9.6.2+extra-source-files:+ .gitignore+ .hlint.yaml+ .vim.custom+ CHANGELOG.markdown+ README.markdown++flag template-haskell+ description:+ You can disable the use of the `template-haskell` package using `-f-template-haskell`.+ .+ Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users.+ default: True+ manual: True++flag herbie+ description: Enable `herbie`.+ default: False+ manual: True++source-repository head+ type: git+ location: https://github.com/ekmett/linear++library+ build-depends:+ adjunctions >= 4 && < 5,+ base >= 4.9 && < 5,+ base-orphans >= 0.8.3 && < 1,+ binary >= 0.5 && < 0.9,+ bytes >= 0.15 && < 1,+ cereal >= 0.4.1.1 && < 0.6,+ containers >= 0.4 && < 0.8,+ deepseq >= 1.1 && < 1.6,+ distributive >= 0.5.1 && < 1,+ ghc-prim,+ hashable >= 1.2.7.0 && < 1.5,+ indexed-traversable >= 0.1.1 && < 0.2,+ lens >= 4.15.2 && < 6,+ random >= 1.0 && < 1.3,+ reflection >= 2 && < 3,+ semigroupoids >= 5.2.1 && < 7,+ tagged >= 0.8.6 && < 1,+ transformers >= 0.5 && < 0.7,+ transformers-compat >= 0.5.0.4 && < 1,+ unordered-containers >= 0.2.3 && < 0.3,+ vector >= 0.12.1.2 && < 0.14,+ void >= 0.6 && < 1++ if impl(ghc < 8.0)+ build-depends: semigroups >= 0.9 && < 1++ if flag(template-haskell) && impl(ghc)+ build-depends: template-haskell >= 2.11.1.0 && < 3.0++ if flag(herbie)+ build-depends: HerbiePlugin >= 0.1 && < 0.2+ ghc-options: -fplugin=Herbie+ cpp-options: -DHERBIE++ exposed-modules:+ Linear+ Linear.Affine+ Linear.Algebra+ Linear.Binary+ Linear.Conjugate+ Linear.Covector+ Linear.Epsilon+ Linear.Instances+ Linear.Matrix+ Linear.Metric+ Linear.Plucker+ Linear.Plucker.Coincides+ Linear.Projection+ Linear.Quaternion+ Linear.Trace+ Linear.V+ Linear.V0+ Linear.V1+ Linear.V2+ Linear.V3+ Linear.V4+ Linear.Vector++ ghc-options: -Wall -Wtabs -O2 -fdicts-cheap -funbox-strict-fields -Wno-trustworthy-safe+ hs-source-dirs: src++ default-language: Haskell2010++ x-docspec-extra-packages: simple-reflect++-- We need this dummy test-suite to add simple-reflect to the install plan+--+-- When cabal-install's extra-packages support becomes widely available+-- (i.e. after 3.4 release), we can remove this test-suite.+test-suite doctests+ type: exitcode-stdio-1.0+ main-is: doctests.hs+ hs-source-dirs: tests+ default-language: Haskell2010++ build-depends: base, simple-reflect >= 0.3.1++test-suite test+ type: exitcode-stdio-1.0+ main-is: Test.hs+ other-modules: Prop.Quaternion+ Prop.V3+ Unit.Binary+ Unit.Plucker+ Unit.V+ ghc-options: -Wall -threaded+ hs-source-dirs: tests+ build-depends:+ base,+ binary,+ bytestring,+ deepseq,+ test-framework >= 0.8,+ test-framework-hunit >= 0.3,+ test-framework-quickcheck2 >= 0.3,+ HUnit >= 1.2.5,+ linear,+ QuickCheck >= 2.5,+ reflection,+ vector+ default-language: Haskell2010+
src/Linear.hs view
@@ -1,48 +1,48 @@------------------------------------------------------------------------------ --- | --- Copyright : (C) 2012-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : experimental --- Portability : non-portable --- --- This module simply re-exports everything from the various modules --- that make up the linear package. ----------------------------------------------------------------------------- -module Linear - ( module Linear.Algebra - , module Linear.Binary - , module Linear.Conjugate - , module Linear.Covector - , module Linear.Epsilon - , module Linear.Matrix - , module Linear.Metric - , module Linear.Projection - , module Linear.Quaternion - , module Linear.Trace - , module Linear.V0 - , module Linear.V1 - , module Linear.V2 - , module Linear.V3 - , module Linear.V4 - , module Linear.Vector - ) where - -import Linear.Algebra -import Linear.Binary -import Linear.Conjugate -import Linear.Covector -import Linear.Epsilon -import Linear.Instances () -import Linear.Matrix -import Linear.Metric -import Linear.Projection -import Linear.Quaternion -import Linear.Trace -import Linear.V0 -import Linear.V1 -import Linear.V2 -import Linear.V3 -import Linear.V4 -import Linear.Vector +-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2012-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- This module simply re-exports everything from the various modules+-- that make up the linear package.+----------------------------------------------------------------------------+module Linear+ ( module Linear.Algebra+ , module Linear.Binary+ , module Linear.Conjugate+ , module Linear.Covector+ , module Linear.Epsilon+ , module Linear.Matrix+ , module Linear.Metric+ , module Linear.Projection+ , module Linear.Quaternion+ , module Linear.Trace+ , module Linear.V0+ , module Linear.V1+ , module Linear.V2+ , module Linear.V3+ , module Linear.V4+ , module Linear.Vector+ ) where++import Linear.Algebra+import Linear.Binary+import Linear.Conjugate+import Linear.Covector+import Linear.Epsilon+import Linear.Instances ()+import Linear.Matrix+import Linear.Metric+import Linear.Projection+import Linear.Quaternion+import Linear.Trace+import Linear.V0+import Linear.V1+import Linear.V2+import Linear.V3+import Linear.V4+import Linear.Vector
src/Linear/Affine.hs view
@@ -1,307 +1,307 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} - -#ifndef MIN_VERSION_hashable -#define MIN_VERSION_hashable(x,y,z) 1 -#endif - ------------------------------------------------------------------------------ --- | --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : provisional --- Portability : portable --- --- Operations on affine spaces. ------------------------------------------------------------------------------ -module Linear.Affine where - -import Control.Applicative -import Control.DeepSeq -import Control.Monad (liftM) -import Control.Lens -import Data.Binary as Binary -import Data.Bytes.Serial -import Data.Coerce -import Data.Complex (Complex) -import Data.Data -import Data.Distributive -import Data.Foldable as Foldable -import Data.Functor.Bind -import Data.Functor.Classes -import Data.Functor.Product -import Data.Functor.Rep as Rep -import Data.HashMap.Lazy (HashMap) -import Data.Hashable -import Data.Hashable.Lifted -import Data.IntMap (IntMap) -import Data.Ix -import Data.Kind -import Data.Map (Map) -#if !(MIN_VERSION_base(4,11,0)) -import Data.Semigroup (Semigroup) -#endif -import Data.Serialize as Cereal -import Data.Vector (Vector) -import qualified Data.Vector.Generic.Mutable as M -import qualified Data.Vector.Generic as G -import qualified Data.Vector.Unboxed.Base as U -import Foreign.Storable -import GHC.Generics (Generic, Generic1) -import Linear.Epsilon -import Linear.Metric -import Linear.Plucker -import Linear.Quaternion -import Linear.V -import Linear.V0 -import Linear.V1 -import Linear.V2 -import Linear.V3 -import Linear.V4 -import Linear.Vector -import System.Random (Random(..)) - --- | An affine space is roughly a vector space in which we have --- forgotten or at least pretend to have forgotten the origin. --- --- > a .+^ (b .-. a) = b@ --- > (a .+^ u) .+^ v = a .+^ (u ^+^ v)@ --- > (a .-. b) ^+^ v = (a .+^ v) .-. q@ -class Additive (Diff p) => Affine p where - type Diff p :: Type -> Type - - infixl 6 .-. - -- | Get the difference between two points as a vector offset. - (.-.) :: Num a => p a -> p a -> Diff p a - - infixl 6 .+^ - -- | Add a vector offset to a point. - (.+^) :: Num a => p a -> Diff p a -> p a - - infixl 6 .-^ - -- | Subtract a vector offset from a point. - (.-^) :: Num a => p a -> Diff p a -> p a - p .-^ v = p .+^ negated v - {-# INLINE (.-^) #-} - -instance (Affine f, Affine g) => Affine (Product f g) where - type Diff (Product f g) = Product (Diff f) (Diff g) - Pair a b .-. Pair c d = Pair (a .-. c) (b .-. d) - Pair a b .+^ Pair c d = Pair (a .+^ c) (b .+^ d) - Pair a b .-^ Pair c d = Pair (a .+^ c) (b .+^ d) - --- | Compute the quadrance of the difference (the square of the distance) -qdA :: (Affine p, Foldable (Diff p), Num a) => p a -> p a -> a -qdA a b = Foldable.sum (fmap (join (*)) (a .-. b)) -{-# INLINE qdA #-} - --- | Distance between two points in an affine space -distanceA :: (Floating a, Foldable (Diff p), Affine p) => p a -> p a -> a -distanceA a b = sqrt (qdA a b) -{-# INLINE distanceA #-} - -#define ADDITIVEC(CTX,T) instance CTX => Affine T where type Diff T = T ; \ - (.-.) = (^-^) ; {-# INLINE (.-.) #-} ; (.+^) = (^+^) ; {-# INLINE (.+^) #-} ; \ - (.-^) = (^-^) ; {-# INLINE (.-^) #-} -#define ADDITIVE(T) ADDITIVEC((), T) - -ADDITIVE([]) -ADDITIVE(Complex) -ADDITIVE(ZipList) -ADDITIVE(Maybe) -ADDITIVE(IntMap) -ADDITIVE(Identity) -ADDITIVE(Vector) -ADDITIVE(V0) -ADDITIVE(V1) -ADDITIVE(V2) -ADDITIVE(V3) -ADDITIVE(V4) -ADDITIVE(Plucker) -ADDITIVE(Quaternion) -ADDITIVE(((->) b)) -ADDITIVEC(Ord k, (Map k)) -ADDITIVEC((Eq k, Hashable k), (HashMap k)) -ADDITIVEC(Dim n, (V n)) - --- | A handy wrapper to help distinguish points from vectors at the --- type level -newtype Point f a = P (f a) - deriving ( Eq, Ord, Show, Read, Monad, Functor, Applicative, Foldable - , Eq1, Ord1, Show1, Read1 - , Traversable, Apply, Additive, Metric - , Fractional , Num, Ix, Storable, Epsilon - , Semigroup, Monoid - , Random, Hashable - , Generic, Generic1, Data - ) - -instance Finite f => Finite (Point f) where - type Size (Point f) = Size f - toV (P v) = toV v - fromV v = P (fromV v) - -instance NFData (f a) => NFData (Point f a) where - rnf (P x) = rnf x - -instance Serial1 f => Serial1 (Point f) where - serializeWith f (P p) = serializeWith f p - deserializeWith m = P `liftM` deserializeWith m - -instance Serial (f a) => Serial (Point f a) where - serialize (P p) = serialize p - deserialize = P `liftM` deserialize - -instance Binary (f a) => Binary (Point f a) where - put (P p) = Binary.put p - get = P `liftM` Binary.get - -instance Serialize (f a) => Serialize (Point f a) where - put (P p) = Cereal.put p - get = P `liftM` Cereal.get - -instance Hashable1 f => Hashable1 (Point f) where - liftHashWithSalt h s (P f) = liftHashWithSalt h s f - {-# INLINE liftHashWithSalt #-} - -lensP :: Lens (Point f a) (Point g b) (f a) (g b) -lensP afb (P a) = P <$> afb a -{-# INLINE lensP #-} - -_Point :: Iso (Point f a) (Point g b) (f a) (g b) -_Point = iso (\(P a) -> a) P -{-# INLINE _Point #-} - -instance (t ~ Point g b) => Rewrapped (Point f a) t -instance Wrapped (Point f a) where - type Unwrapped (Point f a) = f a - _Wrapped' = _Point - {-# INLINE _Wrapped' #-} - --- These are stolen from Data.Profunctor.Unsafe -(.#) :: Coercible b a => (b -> c) -> (a -> b) -> a -> c -f .# _ = coerce f -{-# INLINE (.#) #-} - -(#.) :: Coercible c b => (b -> c) -> (a -> b) -> a -> c -(#.) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b -{-# INLINE (#.) #-} - -unP :: Point f a -> f a -unP (P x) = x -{-# INLINE unP #-} - --- We can't use GND to derive 'Bind' because 'join' causes --- role troubles. However, GHC 7.8 and above let us use --- explicit coercions for (>>-). -instance Bind f => Bind (Point f) where - (>>-) = ((P .) . (. (unP .))) #. (>>-) .# unP - join (P m) = P $ m >>- \(P m') -> m' - -instance Distributive f => Distributive (Point f) where - distribute = P . collect (\(P p) -> p) - collect = (P .) #. collect .# (unP .) - -instance Representable f => Representable (Point f) where - type Rep (Point f) = Rep f - tabulate = P #. tabulate - {-# INLINE tabulate #-} - index = Rep.index .# unP - {-# INLINE index #-} - -type instance Index (Point f a) = Index (f a) -type instance IxValue (Point f a) = IxValue (f a) - -instance Ixed (f a) => Ixed (Point f a) where - ix l = lensP . ix l - {-# INLINE ix #-} - -instance Traversable f => Each (Point f a) (Point f b) a b where - each = traverse - {-# INLINE each #-} - -instance R1 f => R1 (Point f) where - _x = lensP . _x - {-# INLINE _x #-} - -instance R2 f => R2 (Point f) where - _y = lensP . _y - {-# INLINE _y #-} - _xy = lensP . _xy - {-# INLINE _xy #-} - -instance R3 f => R3 (Point f) where - _z = lensP . _z - {-# INLINE _z #-} - _xyz = lensP . _xyz - {-# INLINE _xyz #-} - -instance R4 f => R4 (Point f) where - _w = lensP . _w - {-# INLINE _w #-} - _xyzw = lensP . _xyzw - {-# INLINE _xyzw #-} - -instance Additive f => Affine (Point f) where - type Diff (Point f) = f - (.-.) = (. unP) #. (^-^) .# unP - {-# INLINE (.-.) #-} - (.+^) = (P .) #. (^+^) .# unP - {-# INLINE (.+^) #-} - (.-^) = (P .) #. (^-^) .# unP - {-# INLINE (.-^) #-} - --- | Vector spaces have origins. -origin :: (Additive f, Num a) => Point f a -origin = P zero - --- | An isomorphism between points and vectors, given a reference --- point. -relative :: (Additive f, Num a) => Point f a -> Iso' (Point f a) (f a) -relative p0 = iso (.-. p0) (p0 .+^) -{-# INLINE relative #-} - -newtype instance U.Vector (Point f a) = V_P (U.Vector (f a)) -newtype instance U.MVector s (Point f a) = MV_P (U.MVector s (f a)) -instance U.Unbox (f a) => U.Unbox (Point f a) - -instance U.Unbox (f a) => M.MVector U.MVector (Point f a) where - {-# INLINE basicLength #-} - {-# INLINE basicUnsafeSlice #-} - {-# INLINE basicOverlaps #-} - {-# INLINE basicUnsafeNew #-} - {-# INLINE basicUnsafeRead #-} - {-# INLINE basicUnsafeWrite #-} - basicLength (MV_P v) = M.basicLength v - basicUnsafeSlice m n (MV_P v) = MV_P (M.basicUnsafeSlice m n v) - basicOverlaps (MV_P v) (MV_P u) = M.basicOverlaps v u - basicUnsafeNew n = MV_P `liftM` M.basicUnsafeNew n - basicUnsafeRead (MV_P v) i = P `liftM` M.basicUnsafeRead v i - basicUnsafeWrite (MV_P v) i (P x) = M.basicUnsafeWrite v i x - basicInitialize (MV_P v) = M.basicInitialize v - {-# INLINE basicInitialize #-} - -instance U.Unbox (f a) => G.Vector U.Vector (Point f a) where - {-# INLINE basicUnsafeFreeze #-} - {-# INLINE basicUnsafeThaw #-} - {-# INLINE basicLength #-} - {-# INLINE basicUnsafeSlice #-} - {-# INLINE basicUnsafeIndexM #-} - basicUnsafeFreeze (MV_P v) = V_P `liftM` G.basicUnsafeFreeze v - basicUnsafeThaw ( V_P v) = MV_P `liftM` G.basicUnsafeThaw v - basicLength ( V_P v) = G.basicLength v - basicUnsafeSlice m n (V_P v) = V_P (G.basicUnsafeSlice m n v) - basicUnsafeIndexM (V_P v) i = P `liftM` G.basicUnsafeIndexM v i +{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}++#ifndef MIN_VERSION_hashable+#define MIN_VERSION_hashable(x,y,z) 1+#endif++-----------------------------------------------------------------------------+-- |+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- Operations on affine spaces.+-----------------------------------------------------------------------------+module Linear.Affine where++import Control.Applicative+import Control.DeepSeq+import Control.Monad (liftM)+import Control.Lens+import Data.Binary as Binary+import Data.Bytes.Serial+import Data.Coerce+import Data.Complex (Complex)+import Data.Data+import Data.Distributive+import Data.Foldable as Foldable+import Data.Functor.Bind+import Data.Functor.Classes+import Data.Functor.Product+import Data.Functor.Rep as Rep+import Data.HashMap.Lazy (HashMap)+import Data.Hashable+import Data.Hashable.Lifted+import Data.IntMap (IntMap)+import Data.Ix+import Data.Kind+import Data.Map (Map)+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup)+#endif+import Data.Serialize as Cereal+import Data.Vector (Vector)+import qualified Data.Vector.Generic.Mutable as M+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Unboxed.Base as U+import Foreign.Storable+import GHC.Generics (Generic, Generic1)+import Linear.Epsilon+import Linear.Metric+import Linear.Plucker+import Linear.Quaternion+import Linear.V+import Linear.V0+import Linear.V1+import Linear.V2+import Linear.V3+import Linear.V4+import Linear.Vector+import System.Random (Random(..))++-- | An affine space is roughly a vector space in which we have+-- forgotten or at least pretend to have forgotten the origin.+--+-- > a .+^ (b .-. a) = b@+-- > (a .+^ u) .+^ v = a .+^ (u ^+^ v)@+-- > (a .-. b) ^+^ v = (a .+^ v) .-. q@+class Additive (Diff p) => Affine p where+ type Diff p :: Type -> Type++ infixl 6 .-.+ -- | Get the difference between two points as a vector offset.+ (.-.) :: Num a => p a -> p a -> Diff p a++ infixl 6 .+^+ -- | Add a vector offset to a point.+ (.+^) :: Num a => p a -> Diff p a -> p a++ infixl 6 .-^+ -- | Subtract a vector offset from a point.+ (.-^) :: Num a => p a -> Diff p a -> p a+ p .-^ v = p .+^ negated v+ {-# INLINE (.-^) #-}++instance (Affine f, Affine g) => Affine (Product f g) where+ type Diff (Product f g) = Product (Diff f) (Diff g)+ Pair a b .-. Pair c d = Pair (a .-. c) (b .-. d)+ Pair a b .+^ Pair c d = Pair (a .+^ c) (b .+^ d)+ Pair a b .-^ Pair c d = Pair (a .+^ c) (b .+^ d)++-- | Compute the quadrance of the difference (the square of the distance)+qdA :: (Affine p, Foldable (Diff p), Num a) => p a -> p a -> a+qdA a b = Foldable.sum (fmap (join (*)) (a .-. b))+{-# INLINE qdA #-}++-- | Distance between two points in an affine space+distanceA :: (Floating a, Foldable (Diff p), Affine p) => p a -> p a -> a+distanceA a b = sqrt (qdA a b)+{-# INLINE distanceA #-}++#define ADDITIVEC(CTX,T) instance CTX => Affine T where type Diff T = T ; \+ (.-.) = (^-^) ; {-# INLINE (.-.) #-} ; (.+^) = (^+^) ; {-# INLINE (.+^) #-} ; \+ (.-^) = (^-^) ; {-# INLINE (.-^) #-}+#define ADDITIVE(T) ADDITIVEC((), T)++ADDITIVE([])+ADDITIVE(Complex)+ADDITIVE(ZipList)+ADDITIVE(Maybe)+ADDITIVE(IntMap)+ADDITIVE(Identity)+ADDITIVE(Vector)+ADDITIVE(V0)+ADDITIVE(V1)+ADDITIVE(V2)+ADDITIVE(V3)+ADDITIVE(V4)+ADDITIVE(Plucker)+ADDITIVE(Quaternion)+ADDITIVE(((->) b))+ADDITIVEC(Ord k, (Map k))+ADDITIVEC((Eq k, Hashable k), (HashMap k))+ADDITIVEC(Dim n, (V n))++-- | A handy wrapper to help distinguish points from vectors at the+-- type level+newtype Point f a = P (f a)+ deriving ( Eq, Ord, Show, Read, Monad, Functor, Applicative, Foldable+ , Eq1, Ord1, Show1, Read1+ , Traversable, Apply, Additive, Metric+ , Fractional , Num, Ix, Storable, Epsilon+ , Semigroup, Monoid+ , Random, Hashable+ , Generic, Generic1, Data+ )++instance Finite f => Finite (Point f) where+ type Size (Point f) = Size f+ toV (P v) = toV v+ fromV v = P (fromV v)++instance NFData (f a) => NFData (Point f a) where+ rnf (P x) = rnf x++instance Serial1 f => Serial1 (Point f) where+ serializeWith f (P p) = serializeWith f p+ deserializeWith m = P `liftM` deserializeWith m++instance Serial (f a) => Serial (Point f a) where+ serialize (P p) = serialize p+ deserialize = P `liftM` deserialize++instance Binary (f a) => Binary (Point f a) where+ put (P p) = Binary.put p+ get = P `liftM` Binary.get++instance Serialize (f a) => Serialize (Point f a) where+ put (P p) = Cereal.put p+ get = P `liftM` Cereal.get++instance Hashable1 f => Hashable1 (Point f) where+ liftHashWithSalt h s (P f) = liftHashWithSalt h s f+ {-# INLINE liftHashWithSalt #-}++lensP :: Lens (Point f a) (Point g b) (f a) (g b)+lensP afb (P a) = P <$> afb a+{-# INLINE lensP #-}++_Point :: Iso (Point f a) (Point g b) (f a) (g b)+_Point = iso (\(P a) -> a) P+{-# INLINE _Point #-}++instance (t ~ Point g b) => Rewrapped (Point f a) t+instance Wrapped (Point f a) where+ type Unwrapped (Point f a) = f a+ _Wrapped' = _Point+ {-# INLINE _Wrapped' #-}++-- These are stolen from Data.Profunctor.Unsafe+(.#) :: Coercible b a => (b -> c) -> (a -> b) -> a -> c+f .# _ = coerce f+{-# INLINE (.#) #-}++(#.) :: Coercible c b => (b -> c) -> (a -> b) -> a -> c+(#.) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b+{-# INLINE (#.) #-}++unP :: Point f a -> f a+unP (P x) = x+{-# INLINE unP #-}++-- We can't use GND to derive 'Bind' because 'join' causes+-- role troubles. However, GHC 7.8 and above let us use+-- explicit coercions for (>>-).+instance Bind f => Bind (Point f) where+ (>>-) = ((P .) . (. (unP .))) #. (>>-) .# unP+ join (P m) = P $ m >>- \(P m') -> m'++instance Distributive f => Distributive (Point f) where+ distribute = P . collect (\(P p) -> p)+ collect = (P .) #. collect .# (unP .)++instance Representable f => Representable (Point f) where+ type Rep (Point f) = Rep f+ tabulate = P #. tabulate+ {-# INLINE tabulate #-}+ index = Rep.index .# unP+ {-# INLINE index #-}++type instance Index (Point f a) = Index (f a)+type instance IxValue (Point f a) = IxValue (f a)++instance Ixed (f a) => Ixed (Point f a) where+ ix l = lensP . ix l+ {-# INLINE ix #-}++instance Traversable f => Each (Point f a) (Point f b) a b where+ each = traverse+ {-# INLINE each #-}++instance R1 f => R1 (Point f) where+ _x = lensP . _x+ {-# INLINE _x #-}++instance R2 f => R2 (Point f) where+ _y = lensP . _y+ {-# INLINE _y #-}+ _xy = lensP . _xy+ {-# INLINE _xy #-}++instance R3 f => R3 (Point f) where+ _z = lensP . _z+ {-# INLINE _z #-}+ _xyz = lensP . _xyz+ {-# INLINE _xyz #-}++instance R4 f => R4 (Point f) where+ _w = lensP . _w+ {-# INLINE _w #-}+ _xyzw = lensP . _xyzw+ {-# INLINE _xyzw #-}++instance Additive f => Affine (Point f) where+ type Diff (Point f) = f+ (.-.) = (. unP) #. (^-^) .# unP+ {-# INLINE (.-.) #-}+ (.+^) = (P .) #. (^+^) .# unP+ {-# INLINE (.+^) #-}+ (.-^) = (P .) #. (^-^) .# unP+ {-# INLINE (.-^) #-}++-- | Vector spaces have origins.+origin :: (Additive f, Num a) => Point f a+origin = P zero++-- | An isomorphism between points and vectors, given a reference+-- point.+relative :: (Additive f, Num a) => Point f a -> Iso' (Point f a) (f a)+relative p0 = iso (.-. p0) (p0 .+^)+{-# INLINE relative #-}++newtype instance U.Vector (Point f a) = V_P (U.Vector (f a))+newtype instance U.MVector s (Point f a) = MV_P (U.MVector s (f a))+instance U.Unbox (f a) => U.Unbox (Point f a)++instance U.Unbox (f a) => M.MVector U.MVector (Point f a) where+ {-# INLINE basicLength #-}+ {-# INLINE basicUnsafeSlice #-}+ {-# INLINE basicOverlaps #-}+ {-# INLINE basicUnsafeNew #-}+ {-# INLINE basicUnsafeRead #-}+ {-# INLINE basicUnsafeWrite #-}+ basicLength (MV_P v) = M.basicLength v+ basicUnsafeSlice m n (MV_P v) = MV_P (M.basicUnsafeSlice m n v)+ basicOverlaps (MV_P v) (MV_P u) = M.basicOverlaps v u+ basicUnsafeNew n = MV_P `liftM` M.basicUnsafeNew n+ basicUnsafeRead (MV_P v) i = P `liftM` M.basicUnsafeRead v i+ basicUnsafeWrite (MV_P v) i (P x) = M.basicUnsafeWrite v i x+ basicInitialize (MV_P v) = M.basicInitialize v+ {-# INLINE basicInitialize #-}++instance U.Unbox (f a) => G.Vector U.Vector (Point f a) where+ {-# INLINE basicUnsafeFreeze #-}+ {-# INLINE basicUnsafeThaw #-}+ {-# INLINE basicLength #-}+ {-# INLINE basicUnsafeSlice #-}+ {-# INLINE basicUnsafeIndexM #-}+ basicUnsafeFreeze (MV_P v) = V_P `liftM` G.basicUnsafeFreeze v+ basicUnsafeThaw ( V_P v) = MV_P `liftM` G.basicUnsafeThaw v+ basicLength ( V_P v) = G.basicLength v+ basicUnsafeSlice m n (V_P v) = V_P (G.basicUnsafeSlice m n v)+ basicUnsafeIndexM (V_P v) i = P `liftM` G.basicUnsafeIndexM v i
src/Linear/Algebra.hs view
@@ -1,136 +1,136 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} ------------------------------------------------------------------------------ --- | --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : provisional --- Portability : portable --- ------------------------------------------------------------------------------ -module Linear.Algebra - ( Algebra(..) - , Coalgebra(..) - , multRep, unitalRep - , comultRep, counitalRep - ) where - -import Control.Lens hiding (index) -import Data.Functor.Rep -import Data.Complex -import Data.Void -import Linear.Vector -import Linear.Quaternion -import Linear.Conjugate -import Linear.V0 -import Linear.V1 -import Linear.V2 -import Linear.V3 -import Linear.V4 - --- | An associative unital algebra over a ring -class Num r => Algebra r m where - mult :: (m -> m -> r) -> m -> r - unital :: r -> m -> r - -multRep :: (Representable f, Algebra r (Rep f)) => f (f r) -> f r -multRep ffr = tabulate $ mult (index . index ffr) - -unitalRep :: (Representable f, Algebra r (Rep f)) => r -> f r -unitalRep = tabulate . unital - -instance Num r => Algebra r Void where - mult _ _ = 0 - unital _ _ = 0 - -instance Num r => Algebra r (E V0) where - mult _ _ = 0 - unital _ _ = 0 - -instance Num r => Algebra r (E V1) where - mult f _ = f ex ex - unital r _ = r - -instance Num r => Algebra r () where - mult f () = f () () - unital r () = r - -instance (Algebra r a, Algebra r b) => Algebra r (a, b) where - mult f (a,b) = mult (\a1 a2 -> mult (\b1 b2 -> f (a1,b1) (a2,b2)) b) a - unital r (a,b) = unital r a * unital r b - -instance Num r => Algebra r (E Complex) where - mult f = \ i -> c^.el i where - c = (f ee ee - f ei ei) :+ (f ee ei + f ei ee) - unital r i = (r :+ 0)^.el i - -instance (Num r, TrivialConjugate r) => Algebra r (E Quaternion) where - mult f = index $ Quaternion - (f ee ee - (f ei ei + f ej ej + f ek ek)) - (V3 (f ee ei + f ei ee + f ej ek - f ek ej) - (f ee ej + f ej ee + f ek ei - f ei ek) - (f ee ek + f ek ee + f ei ej - f ej ei)) - unital r = index (Quaternion r 0) - --- | A coassociative counital coalgebra over a ring -class Num r => Coalgebra r m where - comult :: (m -> r) -> m -> m -> r - counital :: (m -> r) -> r - -comultRep :: (Representable f, Coalgebra r (Rep f)) => f r -> f (f r) -comultRep fr = tabulate $ \i -> tabulate $ \j -> comult (index fr) i j - -counitalRep :: (Representable f, Coalgebra r (Rep f)) => f r -> r -counitalRep = counital . index - -instance Num r => Coalgebra r Void where - comult _ _ _ = 0 - counital _ = 0 - -instance Num r => Coalgebra r () where - comult f () () = f () - counital f = f () - -instance Num r => Coalgebra r (E V0) where - comult _ _ _ = 0 - counital _ = 0 - -instance Num r => Coalgebra r (E V1) where - comult f _ _ = f ex - counital f = f ex - -instance Num r => Coalgebra r (E V2) where - comult f = index . index v where - v = V2 (V2 (f ex) 0) (V2 0 (f ey)) - counital f = f ex + f ey - -instance Num r => Coalgebra r (E V3) where - comult f = index . index q where - q = V3 (V3 (f ex) 0 0) - (V3 0 (f ey) 0) - (V3 0 0 (f ez)) - counital f = f ex + f ey + f ez - -instance Num r => Coalgebra r (E V4) where - comult f = index . index v where - v = V4 (V4 (f ex) 0 0 0) (V4 0 (f ey) 0 0) (V4 0 0 (f ez) 0) (V4 0 0 0 (f ew)) - counital f = f ex + f ey + f ez + f ew - -instance Num r => Coalgebra r (E Complex) where - comult f = \i j -> c^.el i.el j where - c = (f ee :+ 0) :+ (0 :+ f ei) - counital f = f ee + f ei - -instance (Num r, TrivialConjugate r) => Coalgebra r (E Quaternion) where - comult f = index . index - (Quaternion (Quaternion (f ee) (V3 0 0 0)) - (V3 (Quaternion 0 (V3 (f ei) 0 0)) - (Quaternion 0 (V3 0 (f ej) 0)) - (Quaternion 0 (V3 0 0 (f ek))))) - counital f = f ee + f ei + f ej + f ek - -instance (Coalgebra r m, Coalgebra r n) => Coalgebra r (m, n) where - comult f (a1, b1) (a2, b2) = comult (\a -> comult (\b -> f (a, b)) b1 b2) a1 a2 - counital k = counital $ \a -> counital $ \b -> k (a,b) +{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+-----------------------------------------------------------------------------+-- |+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-----------------------------------------------------------------------------+module Linear.Algebra+ ( Algebra(..)+ , Coalgebra(..)+ , multRep, unitalRep+ , comultRep, counitalRep+ ) where++import Control.Lens hiding (index)+import Data.Functor.Rep+import Data.Complex+import Data.Void+import Linear.Vector+import Linear.Quaternion+import Linear.Conjugate+import Linear.V0+import Linear.V1+import Linear.V2+import Linear.V3+import Linear.V4++-- | An associative unital algebra over a ring+class Num r => Algebra r m where+ mult :: (m -> m -> r) -> m -> r+ unital :: r -> m -> r++multRep :: (Representable f, Algebra r (Rep f)) => f (f r) -> f r+multRep ffr = tabulate $ mult (index . index ffr)++unitalRep :: (Representable f, Algebra r (Rep f)) => r -> f r+unitalRep = tabulate . unital++instance Num r => Algebra r Void where+ mult _ _ = 0+ unital _ _ = 0++instance Num r => Algebra r (E V0) where+ mult _ _ = 0+ unital _ _ = 0++instance Num r => Algebra r (E V1) where+ mult f _ = f ex ex+ unital r _ = r++instance Num r => Algebra r () where+ mult f () = f () ()+ unital r () = r++instance (Algebra r a, Algebra r b) => Algebra r (a, b) where+ mult f (a,b) = mult (\a1 a2 -> mult (\b1 b2 -> f (a1,b1) (a2,b2)) b) a+ unital r (a,b) = unital r a * unital r b++instance Num r => Algebra r (E Complex) where+ mult f = \ i -> c^.el i where+ c = (f ee ee - f ei ei) :+ (f ee ei + f ei ee)+ unital r i = (r :+ 0)^.el i++instance (Num r, TrivialConjugate r) => Algebra r (E Quaternion) where+ mult f = index $ Quaternion+ (f ee ee - (f ei ei + f ej ej + f ek ek))+ (V3 (f ee ei + f ei ee + f ej ek - f ek ej)+ (f ee ej + f ej ee + f ek ei - f ei ek)+ (f ee ek + f ek ee + f ei ej - f ej ei))+ unital r = index (Quaternion r 0)++-- | A coassociative counital coalgebra over a ring+class Num r => Coalgebra r m where+ comult :: (m -> r) -> m -> m -> r+ counital :: (m -> r) -> r++comultRep :: (Representable f, Coalgebra r (Rep f)) => f r -> f (f r)+comultRep fr = tabulate $ \i -> tabulate $ \j -> comult (index fr) i j++counitalRep :: (Representable f, Coalgebra r (Rep f)) => f r -> r+counitalRep = counital . index++instance Num r => Coalgebra r Void where+ comult _ _ _ = 0+ counital _ = 0++instance Num r => Coalgebra r () where+ comult f () () = f ()+ counital f = f ()++instance Num r => Coalgebra r (E V0) where+ comult _ _ _ = 0+ counital _ = 0++instance Num r => Coalgebra r (E V1) where+ comult f _ _ = f ex+ counital f = f ex++instance Num r => Coalgebra r (E V2) where+ comult f = index . index v where+ v = V2 (V2 (f ex) 0) (V2 0 (f ey))+ counital f = f ex + f ey++instance Num r => Coalgebra r (E V3) where+ comult f = index . index q where+ q = V3 (V3 (f ex) 0 0)+ (V3 0 (f ey) 0)+ (V3 0 0 (f ez))+ counital f = f ex + f ey + f ez++instance Num r => Coalgebra r (E V4) where+ comult f = index . index v where+ v = V4 (V4 (f ex) 0 0 0) (V4 0 (f ey) 0 0) (V4 0 0 (f ez) 0) (V4 0 0 0 (f ew))+ counital f = f ex + f ey + f ez + f ew++instance Num r => Coalgebra r (E Complex) where+ comult f = \i j -> c^.el i.el j where+ c = (f ee :+ 0) :+ (0 :+ f ei)+ counital f = f ee + f ei++instance (Num r, TrivialConjugate r) => Coalgebra r (E Quaternion) where+ comult f = index . index+ (Quaternion (Quaternion (f ee) (V3 0 0 0))+ (V3 (Quaternion 0 (V3 (f ei) 0 0))+ (Quaternion 0 (V3 0 (f ej) 0))+ (Quaternion 0 (V3 0 0 (f ek)))))+ counital f = f ee + f ei + f ej + f ek++instance (Coalgebra r m, Coalgebra r n) => Coalgebra r (m, n) where+ comult f (a1, b1) (a2, b2) = comult (\a -> comult (\b -> f (a, b)) b1 b2) a1 a2+ counital k = counital $ \a -> counital $ \b -> k (a,b)
src/Linear/Binary.hs view
@@ -1,27 +1,27 @@------------------------------------------------------------------------------ --- | --- Copyright : (C) 2013-2015 Edward Kmett and Anthony Cowley --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : experimental --- Portability : non-portable --- --- Serialization of statically-sized types with the "Data.Binary" --- library. ------------------------------------------------------------------------------- -module Linear.Binary - ( putLinear - , getLinear - ) where - -import Data.Binary -import Data.Foldable (traverse_) - --- | Serialize a linear type. -putLinear :: (Binary a, Foldable t) => t a -> Put -putLinear = traverse_ put - --- | Deserialize a linear type. -getLinear :: (Binary a, Applicative t, Traversable t) => Get (t a) -getLinear = sequenceA $ pure get +-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2013-2015 Edward Kmett and Anthony Cowley+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- Serialization of statically-sized types with the "Data.Binary"+-- library.+------------------------------------------------------------------------------+module Linear.Binary+ ( putLinear+ , getLinear+ ) where++import Data.Binary+import Data.Foldable (traverse_)++-- | Serialize a linear type.+putLinear :: (Binary a, Foldable t) => t a -> Put+putLinear = traverse_ put++-- | Deserialize a linear type.+getLinear :: (Binary a, Applicative t, Traversable t) => Get (t a)+getLinear = sequenceA $ pure get
src/Linear/Conjugate.hs view
@@ -1,86 +1,86 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE DefaultSignatures #-} - ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2012-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : experimental --- Portability : non-portable --- --- Involutive rings ----------------------------------------------------------------------------- -module Linear.Conjugate - ( Conjugate(..) - , TrivialConjugate - ) where - -import Data.Complex hiding (conjugate) -import Data.Int -import Data.Word -import Foreign.C.Types (CFloat, CDouble) - --- $setup --- >>> import Data.Complex (Complex (..)) - - --- | An involutive ring -class Num a => Conjugate a where - -- | Conjugate a value. This defaults to the trivial involution. - -- - -- >>> conjugate (1 :+ 2) - -- 1.0 :+ (-2.0) - -- - -- >>> conjugate 1 - -- 1 - conjugate :: a -> a -#ifndef HLINT - default conjugate :: TrivialConjugate a => a -> a - conjugate = id -#endif - --- | Requires and provides a default definition such that --- --- @ --- 'conjugate' = 'id' --- @ -class Conjugate a => TrivialConjugate a - -instance Conjugate Integer -instance Conjugate Int -instance Conjugate Int64 -instance Conjugate Int32 -instance Conjugate Int16 -instance Conjugate Int8 -instance Conjugate Word -instance Conjugate Word64 -instance Conjugate Word32 -instance Conjugate Word16 -instance Conjugate Word8 -instance Conjugate Double -instance Conjugate Float -instance Conjugate CFloat -instance Conjugate CDouble - -instance (Conjugate a, RealFloat a) => Conjugate (Complex a) where - {-# SPECIALIZE instance Conjugate (Complex Float) #-} - {-# SPECIALIZE instance Conjugate (Complex Double) #-} - conjugate (a :+ b) = conjugate a :+ negate b - -instance TrivialConjugate Integer -instance TrivialConjugate Int -instance TrivialConjugate Int64 -instance TrivialConjugate Int32 -instance TrivialConjugate Int16 -instance TrivialConjugate Int8 -instance TrivialConjugate Word -instance TrivialConjugate Word64 -instance TrivialConjugate Word32 -instance TrivialConjugate Word16 -instance TrivialConjugate Word8 -instance TrivialConjugate Double -instance TrivialConjugate Float -instance TrivialConjugate CFloat -instance TrivialConjugate CDouble +{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2012-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- Involutive rings+----------------------------------------------------------------------------+module Linear.Conjugate+ ( Conjugate(..)+ , TrivialConjugate+ ) where++import Data.Complex hiding (conjugate)+import Data.Int+import Data.Word+import Foreign.C.Types (CFloat, CDouble)++-- $setup+-- >>> import Data.Complex (Complex (..))+++-- | An involutive ring+class Num a => Conjugate a where+ -- | Conjugate a value. This defaults to the trivial involution.+ --+ -- >>> conjugate (1 :+ 2)+ -- 1.0 :+ (-2.0)+ --+ -- >>> conjugate 1+ -- 1+ conjugate :: a -> a+#ifndef HLINT+ default conjugate :: TrivialConjugate a => a -> a+ conjugate = id+#endif++-- | Requires and provides a default definition such that+--+-- @+-- 'conjugate' = 'id'+-- @+class Conjugate a => TrivialConjugate a++instance Conjugate Integer+instance Conjugate Int+instance Conjugate Int64+instance Conjugate Int32+instance Conjugate Int16+instance Conjugate Int8+instance Conjugate Word+instance Conjugate Word64+instance Conjugate Word32+instance Conjugate Word16+instance Conjugate Word8+instance Conjugate Double+instance Conjugate Float+instance Conjugate CFloat+instance Conjugate CDouble++instance (Conjugate a, RealFloat a) => Conjugate (Complex a) where+ {-# SPECIALIZE instance Conjugate (Complex Float) #-}+ {-# SPECIALIZE instance Conjugate (Complex Double) #-}+ conjugate (a :+ b) = conjugate a :+ negate b++instance TrivialConjugate Integer+instance TrivialConjugate Int+instance TrivialConjugate Int64+instance TrivialConjugate Int32+instance TrivialConjugate Int16+instance TrivialConjugate Int8+instance TrivialConjugate Word+instance TrivialConjugate Word64+instance TrivialConjugate Word32+instance TrivialConjugate Word16+instance TrivialConjugate Word8+instance TrivialConjugate Double+instance TrivialConjugate Float+instance TrivialConjugate CFloat+instance TrivialConjugate CDouble
src/Linear/Covector.hs view
@@ -1,73 +1,73 @@-{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} ------------------------------------------------------------------------------ --- | --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : provisional --- Portability : portable --- --- Operations on affine spaces. ------------------------------------------------------------------------------ -module Linear.Covector - ( Covector(..) - , ($*) - ) where - -import Control.Applicative -import Control.Monad -import Data.Functor.Plus hiding (zero) -import qualified Data.Functor.Plus as Plus -import Data.Functor.Bind -import Data.Functor.Rep as Rep -import Linear.Algebra - --- | Linear functionals from elements of an (infinite) free module to a scalar - -newtype Covector r a = Covector { runCovector :: (a -> r) -> r } - -infixr 0 $* - -($*) :: Representable f => Covector r (Rep f) -> f r -> r -Covector f $* m = f (Rep.index m) - -instance Functor (Covector r) where - fmap f (Covector m) = Covector $ \k -> m (k . f) - -instance Apply (Covector r) where - Covector mf <.> Covector ma = Covector $ \k -> mf $ \f -> ma (k . f) - -instance Applicative (Covector r) where - pure a = Covector $ \k -> k a - Covector mf <*> Covector ma = Covector $ \k -> mf $ \f -> ma $ k . f - -instance Bind (Covector r) where - Covector m >>- f = Covector $ \k -> m $ \a -> runCovector (f a) k - -instance Monad (Covector r) where -#if !(MIN_VERSION_base(4,11,0)) - return a = Covector $ \k -> k a -#endif - Covector m >>= f = Covector $ \k -> m $ \a -> runCovector (f a) k - -instance Num r => Alt (Covector r) where - Covector m <!> Covector n = Covector $ \k -> m k + n k - -instance Num r => Plus (Covector r) where - zero = Covector (const 0) - -instance Num r => Alternative (Covector r) where - Covector m <|> Covector n = Covector $ \k -> m k + n k - empty = Covector (const 0) - -instance Num r => MonadPlus (Covector r) where - Covector m `mplus` Covector n = Covector $ \k -> m k + n k - mzero = Covector (const 0) - -instance Coalgebra r m => Num (Covector r m) where - Covector f + Covector g = Covector $ \k -> f k + g k - Covector f - Covector g = Covector $ \k -> f k - g k - Covector f * Covector g = Covector $ \k -> f $ \m -> g $ comult k m - negate (Covector f) = Covector $ \k -> negate (f k) - abs _ = error "Covector.abs: undefined" - signum _ = error "Covector.signum: undefined" - fromInteger n = Covector $ \ k -> fromInteger n * counital k +{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}+-----------------------------------------------------------------------------+-- |+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- Operations on affine spaces.+-----------------------------------------------------------------------------+module Linear.Covector+ ( Covector(..)+ , ($*)+ ) where++import Control.Applicative+import Control.Monad+import Data.Functor.Plus hiding (zero)+import qualified Data.Functor.Plus as Plus+import Data.Functor.Bind+import Data.Functor.Rep as Rep+import Linear.Algebra++-- | Linear functionals from elements of an (infinite) free module to a scalar++newtype Covector r a = Covector { runCovector :: (a -> r) -> r }++infixr 0 $*++($*) :: Representable f => Covector r (Rep f) -> f r -> r+Covector f $* m = f (Rep.index m)++instance Functor (Covector r) where+ fmap f (Covector m) = Covector $ \k -> m (k . f)++instance Apply (Covector r) where+ Covector mf <.> Covector ma = Covector $ \k -> mf $ \f -> ma (k . f)++instance Applicative (Covector r) where+ pure a = Covector $ \k -> k a+ Covector mf <*> Covector ma = Covector $ \k -> mf $ \f -> ma $ k . f++instance Bind (Covector r) where+ Covector m >>- f = Covector $ \k -> m $ \a -> runCovector (f a) k++instance Monad (Covector r) where+#if !(MIN_VERSION_base(4,11,0))+ return a = Covector $ \k -> k a+#endif+ Covector m >>= f = Covector $ \k -> m $ \a -> runCovector (f a) k++instance Num r => Alt (Covector r) where+ Covector m <!> Covector n = Covector $ \k -> m k + n k++instance Num r => Plus (Covector r) where+ zero = Covector (const 0)++instance Num r => Alternative (Covector r) where+ Covector m <|> Covector n = Covector $ \k -> m k + n k+ empty = Covector (const 0)++instance Num r => MonadPlus (Covector r) where+ Covector m `mplus` Covector n = Covector $ \k -> m k + n k+ mzero = Covector (const 0)++instance Coalgebra r m => Num (Covector r m) where+ Covector f + Covector g = Covector $ \k -> f k + g k+ Covector f - Covector g = Covector $ \k -> f k - g k+ Covector f * Covector g = Covector $ \k -> f $ \m -> g $ comult k m+ negate (Covector f) = Covector $ \k -> negate (f k)+ abs _ = error "Covector.abs: undefined"+ signum _ = error "Covector.signum: undefined"+ fromInteger n = Covector $ \ k -> fromInteger n * counital k
src/Linear/Epsilon.hs view
@@ -1,51 +1,51 @@------------------------------------------------------------------------------ --- | --- Copyright : (C) 2012-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : provisional --- Portability : portable --- --- Testing for values "near" zero ------------------------------------------------------------------------------ -module Linear.Epsilon - ( Epsilon(..) - ) where -import Data.Complex (Complex, magnitude) -import Foreign.C.Types (CFloat, CDouble) - --- | Provides a fairly subjective test to see if a quantity is near zero. --- --- >>> nearZero (1e-11 :: Double) --- False --- --- >>> nearZero (1e-17 :: Double) --- True --- --- >>> nearZero (1e-5 :: Float) --- False --- --- >>> nearZero (1e-7 :: Float) --- True -class Num a => Epsilon a where - -- | Determine if a quantity is near zero. - nearZero :: a -> Bool - --- | @'abs' a '<=' 1e-6@ -instance Epsilon Float where - nearZero a = abs a <= 1e-6 - --- | @'abs' a '<=' 1e-12@ -instance Epsilon Double where - nearZero a = abs a <= 1e-12 - --- | @'abs' a '<=' 1e-6@ -instance Epsilon CFloat where - nearZero a = abs a <= 1e-6 - --- | @'abs' a '<=' 1e-12@ -instance Epsilon CDouble where - nearZero a = abs a <= 1e-12 - -instance (Epsilon a, RealFloat a) => Epsilon (Complex a) where - nearZero = nearZero . magnitude +-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2012-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- Testing for values "near" zero+-----------------------------------------------------------------------------+module Linear.Epsilon+ ( Epsilon(..)+ ) where+import Data.Complex (Complex, magnitude)+import Foreign.C.Types (CFloat, CDouble)++-- | Provides a fairly subjective test to see if a quantity is near zero.+--+-- >>> nearZero (1e-11 :: Double)+-- False+--+-- >>> nearZero (1e-17 :: Double)+-- True+--+-- >>> nearZero (1e-5 :: Float)+-- False+--+-- >>> nearZero (1e-7 :: Float)+-- True+class Num a => Epsilon a where+ -- | Determine if a quantity is near zero.+ nearZero :: a -> Bool++-- | @'abs' a '<=' 1e-6@+instance Epsilon Float where+ nearZero a = abs a <= 1e-6++-- | @'abs' a '<=' 1e-12@+instance Epsilon Double where+ nearZero a = abs a <= 1e-12++-- | @'abs' a '<=' 1e-6@+instance Epsilon CFloat where+ nearZero a = abs a <= 1e-6++-- | @'abs' a '<=' 1e-12@+instance Epsilon CDouble where+ nearZero a = abs a <= 1e-12++instance (Epsilon a, RealFloat a) => Epsilon (Complex a) where+ nearZero = nearZero . magnitude
src/Linear/Instances.hs view
@@ -1,14 +1,14 @@-{-# LANGUAGE Safe #-} ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2012-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : provisional --- Portability : portable --- --- Re-exports orphan instances for @Complex@ from the @base-orphans@ package. ------------------------------------------------------------------------------ -module Linear.Instances () where - -import Data.Orphans () +{-# LANGUAGE Safe #-}+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2012-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- Re-exports orphan instances for @Complex@ from the @base-orphans@ package.+-----------------------------------------------------------------------------+module Linear.Instances () where++import Data.Orphans ()
src/Linear/Matrix.hs view
@@ -1,731 +1,731 @@-{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - ---------------------------------------------------------------------------- --- | --- Copyright : (C) 2012-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : experimental --- Portability : non-portable --- --- Simple matrix operation for low-dimensional primitives. ---------------------------------------------------------------------------- -module Linear.Matrix - ( (!*!), (!+!), (!-!), (!*), (*!), (!!*), (*!!), (!!/) - , column - , adjoint - , M22, M23, M24, M32, M33, M34, M42, M43, M44 - , m33_to_m44, m43_to_m44 - , det22, det33, det44, inv22, inv33, inv44 - , identity - , Trace(..) - , translation - , transpose - , fromQuaternion - , mkTransformation - , mkTransformationMat - , _m22, _m23, _m24 - , _m32, _m33, _m34 - , _m42, _m43, _m44 - , lu - , luFinite - , forwardSub - , forwardSubFinite - , backwardSub - , backwardSubFinite - , luSolve - , luSolveFinite - , luInv - , luInvFinite - , luDet - , luDetFinite - ) where - -import Control.Lens hiding (index) -import Control.Lens.Internal.Context -import Data.Distributive -import Data.Foldable as Foldable -import Data.Functor.Rep -import GHC.TypeLits -import Linear.Quaternion -import Linear.V -import Linear.V2 -import Linear.V3 -import Linear.V4 -import Linear.Vector -import Linear.Conjugate -import Linear.Trace - --- $setup --- >>> import Control.Lens hiding (index) --- >>> import Data.Complex (Complex (..)) --- >>> import Linear.V2 --- >>> import Linear.V3 --- >>> import Linear.V --- >>> import qualified Data.IntMap as IntMap --- >>> import Debug.SimpleReflect.Vars - --- | This is a generalization of 'Control.Lens.inside' to work over any corepresentable 'Functor'. --- --- @ --- 'column' :: 'Representable' f => 'Lens' s t a b -> 'Lens' (f s) (f t) (f a) (f b) --- @ --- --- In practice it is used to access a column of a matrix. --- --- >>> V2 (V3 1 2 3) (V3 4 5 6) ^._x --- V3 1 2 3 --- --- >>> V2 (V3 1 2 3) (V3 4 5 6) ^.column _x --- V2 1 4 -column :: Representable f => LensLike (Context a b) s t a b -> Lens (f s) (f t) (f a) (f b) -column l f es = o <$> f i where - go = l (Context id) - i = tabulate $ \ e -> ipos $ go (index es e) - o eb = tabulate $ \ e -> ipeek (index eb e) (go (index es e)) - -infixl 7 !*! --- | Matrix product. This can compute any combination of sparse and dense multiplication. --- --- >>> V2 (V3 1 2 3) (V3 4 5 6) !*! V3 (V2 1 2) (V2 3 4) (V2 4 5) --- V2 (V2 19 25) (V2 43 58) --- --- >>> V2 (IntMap.fromList [(1,2)]) (IntMap.fromList [(2,3)]) !*! IntMap.fromList [(1,V3 0 0 1), (2, V3 0 0 5)] --- V2 (V3 0 0 2) (V3 0 0 15) -(!*!) :: (Functor m, Foldable t, Additive t, Additive n, Num a) => m (t a) -> t (n a) -> m (n a) -f !*! g = fmap (\ f' -> Foldable.foldl' (^+^) zero $ liftI2 (*^) f' g) f - -infixl 6 !+! --- | Entry-wise matrix addition. --- --- >>> V2 (V3 1 2 3) (V3 4 5 6) !+! V2 (V3 7 8 9) (V3 1 2 3) --- V2 (V3 8 10 12) (V3 5 7 9) -(!+!) :: (Additive m, Additive n, Num a) => m (n a) -> m (n a) -> m (n a) -as !+! bs = liftU2 (^+^) as bs - -infixl 6 !-! --- | Entry-wise matrix subtraction. --- --- >>> V2 (V3 1 2 3) (V3 4 5 6) !-! V2 (V3 7 8 9) (V3 1 2 3) --- V2 (V3 (-6) (-6) (-6)) (V3 3 3 3) -(!-!) :: (Additive m, Additive n, Num a) => m (n a) -> m (n a) -> m (n a) -as !-! bs = liftU2 (^-^) as bs - -infixl 7 !* --- | Matrix * column vector --- --- >>> V2 (V3 1 2 3) (V3 4 5 6) !* V3 7 8 9 --- V2 50 122 -(!*) :: (Functor m, Foldable r, Additive r, Num a) => m (r a) -> r a -> m a -m !* v = fmap (\r -> Foldable.sum $ liftI2 (*) r v) m - -infixl 7 *! --- | Row vector * matrix --- --- >>> V2 1 2 *! V2 (V3 3 4 5) (V3 6 7 8) --- V3 15 18 21 - --- (*!) :: (Metric r, Additive n, Num a) => r a -> r (n a) -> n a --- f *! g = dot f <$> distribute g - -(*!) :: (Num a, Foldable t, Additive f, Additive t) => t a -> t (f a) -> f a -f *! g = sumV $ liftI2 (*^) f g - -infixl 7 *!! --- | Scalar-matrix product --- --- >>> 5 *!! V2 (V2 1 2) (V2 3 4) --- V2 (V2 5 10) (V2 15 20) -(*!!) :: (Functor m, Functor r, Num a) => a -> m (r a) -> m (r a) -s *!! m = fmap (s *^) m -{-# INLINE (*!!) #-} - -infixl 7 !!* --- | Matrix-scalar product --- --- >>> V2 (V2 1 2) (V2 3 4) !!* 5 --- V2 (V2 5 10) (V2 15 20) -(!!*) :: (Functor m, Functor r, Num a) => m (r a) -> a -> m (r a) -(!!*) = flip (*!!) -{-# INLINE (!!*) #-} - -infixl 7 !!/ --- | Matrix-scalar division -(!!/) :: (Functor m, Functor r, Fractional a) => m (r a) -> a -> m (r a) -m !!/ s = fmap (^/ s) m -{-# INLINE (!!/) #-} - --- | Hermitian conjugate or conjugate transpose --- --- >>> adjoint (V2 (V2 (1 :+ 2) (3 :+ 4)) (V2 (5 :+ 6) (7 :+ 8))) --- V2 (V2 (1.0 :+ (-2.0)) (5.0 :+ (-6.0))) (V2 (3.0 :+ (-4.0)) (7.0 :+ (-8.0))) -adjoint :: (Functor m, Distributive n, Conjugate a) => m (n a) -> n (m a) -adjoint = collect (fmap conjugate) -{-# INLINE adjoint #-} - --- * Matrices --- --- Matrices use a row-major representation. - --- | A 2x2 matrix with row-major representation -type M22 a = V2 (V2 a) --- | A 2x3 matrix with row-major representation -type M23 a = V2 (V3 a) --- | A 2x4 matrix with row-major representation -type M24 a = V2 (V4 a) --- | A 3x2 matrix with row-major representation -type M32 a = V3 (V2 a) --- | A 3x3 matrix with row-major representation -type M33 a = V3 (V3 a) --- | A 3x4 matrix with row-major representation -type M34 a = V3 (V4 a) --- | A 4x2 matrix with row-major representation -type M42 a = V4 (V2 a) --- | A 4x3 matrix with row-major representation -type M43 a = V4 (V3 a) --- | A 4x4 matrix with row-major representation -type M44 a = V4 (V4 a) - --- | Build a rotation matrix from a unit 'Quaternion'. -fromQuaternion :: Num a => Quaternion a -> M33 a -fromQuaternion (Quaternion w (V3 x y z)) = - V3 (V3 (1-2*(y2+z2)) (2*(xy-zw)) (2*(xz+yw))) - (V3 (2*(xy+zw)) (1-2*(x2+z2)) (2*(yz-xw))) - (V3 (2*(xz-yw)) (2*(yz+xw)) (1-2*(x2+y2))) - where x2 = x*x - y2 = y*y - z2 = z*z - xy = x*y - xz = x*z - xw = x*w - yz = y*z - yw = y*w - zw = z*w -{-# INLINE fromQuaternion #-} - --- | Build a transformation matrix from a rotation matrix and a --- translation vector. -mkTransformationMat :: Num a => M33 a -> V3 a -> M44 a -mkTransformationMat (V3 r1 r2 r3) (V3 tx ty tz) = - V4 (snoc3 r1 tx) (snoc3 r2 ty) (snoc3 r3 tz) (V4 0 0 0 1) - where snoc3 (V3 x y z) = V4 x y z -{-# INLINE mkTransformationMat #-} - --- |Build a transformation matrix from a rotation expressed as a --- 'Quaternion' and a translation vector. -mkTransformation :: Num a => Quaternion a -> V3 a -> M44 a -mkTransformation = mkTransformationMat . fromQuaternion -{-# INLINE mkTransformation #-} - --- | Convert from a 4x3 matrix to a 4x4 matrix, extending it with the @[ 0 0 0 1 ]@ column vector -m43_to_m44 :: Num a => M43 a -> M44 a -m43_to_m44 - (V4 (V3 a b c) - (V3 d e f) - (V3 g h i) - (V3 j k l)) = - V4 (V4 a b c 0) - (V4 d e f 0) - (V4 g h i 0) - (V4 j k l 1) - --- | Convert a 3x3 matrix to a 4x4 matrix extending it with 0's in the new row and column. -m33_to_m44 :: Num a => M33 a -> M44 a -m33_to_m44 (V3 r1 r2 r3) = V4 (vector r1) (vector r2) (vector r3) (point 0) - --- |The identity matrix for any dimension vector. --- --- >>> identity :: M44 Int --- V4 (V4 1 0 0 0) (V4 0 1 0 0) (V4 0 0 1 0) (V4 0 0 0 1) --- >>> identity :: V3 (V3 Int) --- V3 (V3 1 0 0) (V3 0 1 0) (V3 0 0 1) -identity :: (Num a, Traversable t, Applicative t) => t (t a) -identity = scaled (pure 1) - --- |Extract the translation vector (first three entries of the last --- column) from a 3x4 or 4x4 matrix. -translation :: (Representable t, R3 t, R4 v) => Lens' (t (v a)) (V3 a) -translation = column _w._xyz -{- -translation f rs = aux <$> f (view _w <$> view _xyz rs) - where aux (V3 x y z) = (_x._w .~ x) . (_y._w .~ y) . (_z._w .~ z) $ rs - --- translation :: (R3 t, R4 v, Functor f, Functor t) => (V3 a -> f (V3 a)) -> t (v a) -> f (t a) --- translation = (. fmap (^._w)) . _xyz where --- x ^. l = getConst (l Const x) --} - --- |Extract a 2x2 matrix from a matrix of higher dimensions by dropping excess --- rows and columns. -_m22 :: (Representable t, R2 t, R2 v) => Lens' (t (v a)) (M22 a) -_m22 = column _xy._xy - --- |Extract a 2x3 matrix from a matrix of higher dimensions by dropping excess --- rows and columns. -_m23 :: (Representable t, R2 t, R3 v) => Lens' (t (v a)) (M23 a) -_m23 = column _xyz._xy - --- |Extract a 2x4 matrix from a matrix of higher dimensions by dropping excess --- rows and columns. -_m24 :: (Representable t, R2 t, R4 v) => Lens' (t (v a)) (M24 a) -_m24 = column _xyzw._xy - --- |Extract a 3x2 matrix from a matrix of higher dimensions by dropping excess --- rows and columns. -_m32 :: (Representable t, R3 t, R2 v) => Lens' (t (v a)) (M32 a) -_m32 = column _xy._xyz - --- |Extract a 3x3 matrix from a matrix of higher dimensions by dropping excess --- rows and columns. -_m33 :: (Representable t, R3 t, R3 v) => Lens' (t (v a)) (M33 a) -_m33 = column _xyz._xyz - --- |Extract a 3x4 matrix from a matrix of higher dimensions by dropping excess --- rows and columns. -_m34 :: (Representable t, R3 t, R4 v) => Lens' (t (v a)) (M34 a) -_m34 = column _xyzw._xyz - --- |Extract a 4x2 matrix from a matrix of higher dimensions by dropping excess --- rows and columns. -_m42 :: (Representable t, R4 t, R2 v) => Lens' (t (v a)) (M42 a) -_m42 = column _xy._xyzw - --- |Extract a 4x3 matrix from a matrix of higher dimensions by dropping excess --- rows and columns. -_m43 :: (Representable t, R4 t, R3 v) => Lens' (t (v a)) (M43 a) -_m43 = column _xyz._xyzw - --- |Extract a 4x4 matrix from a matrix of higher dimensions by dropping excess --- rows and columns. -_m44 :: (Representable t, R4 t, R4 v) => Lens' (t (v a)) (M44 a) -_m44 = column _xyzw._xyzw - --- |2x2 matrix determinant. --- --- >>> det22 (V2 (V2 a b) (V2 c d)) --- a * d - b * c -det22 :: Num a => M22 a -> a -det22 (V2 (V2 a b) (V2 c d)) = a * d - b * c -{-# INLINE det22 #-} - --- |3x3 matrix determinant. --- --- >>> det33 (V3 (V3 a b c) (V3 d e f) (V3 g h i)) --- a * (e * i - f * h) - d * (b * i - c * h) + g * (b * f - c * e) -det33 :: Num a => M33 a -> a -det33 (V3 (V3 a b c) - (V3 d e f) - (V3 g h i)) = a * (e*i-f*h) - d * (b*i-c*h) + g * (b*f-c*e) -{-# INLINE det33 #-} - --- |4x4 matrix determinant. -det44 :: Num a => M44 a -> a -det44 (V4 (V4 i00 i01 i02 i03) - (V4 i10 i11 i12 i13) - (V4 i20 i21 i22 i23) - (V4 i30 i31 i32 i33)) = - let - s0 = i00 * i11 - i10 * i01 - s1 = i00 * i12 - i10 * i02 - s2 = i00 * i13 - i10 * i03 - s3 = i01 * i12 - i11 * i02 - s4 = i01 * i13 - i11 * i03 - s5 = i02 * i13 - i12 * i03 - - c5 = i22 * i33 - i32 * i23 - c4 = i21 * i33 - i31 * i23 - c3 = i21 * i32 - i31 * i22 - c2 = i20 * i33 - i30 * i23 - c1 = i20 * i32 - i30 * i22 - c0 = i20 * i31 - i30 * i21 - in s0 * c5 - s1 * c4 + s2 * c3 + s3 * c2 - s4 * c1 + s5 * c0 -{-# INLINE det44 #-} - --- |2x2 matrix inverse. --- --- >>> inv22 $ V2 (V2 1 2) (V2 3 4) --- V2 (V2 (-2.0) 1.0) (V2 1.5 (-0.5)) -inv22 :: Fractional a => M22 a -> M22 a -inv22 m@(V2 (V2 a b) (V2 c d)) = (1 / det) *!! V2 (V2 d (-b)) (V2 (-c) a) - where det = det22 m -{-# INLINE inv22 #-} - --- |3x3 matrix inverse. --- --- >>> inv33 $ V3 (V3 1 2 4) (V3 4 2 2) (V3 1 1 1) --- V3 (V3 0.0 0.5 (-1.0)) (V3 (-0.5) (-0.75) 3.5) (V3 0.5 0.25 (-1.5)) -inv33 :: Fractional a => M33 a -> M33 a -inv33 m@(V3 (V3 a b c) - (V3 d e f) - (V3 g h i)) - = (1 / det) *!! V3 (V3 a' b' c') - (V3 d' e' f') - (V3 g' h' i') - where a' = cofactor (e,f,h,i) - b' = cofactor (c,b,i,h) - c' = cofactor (b,c,e,f) - d' = cofactor (f,d,i,g) - e' = cofactor (a,c,g,i) - f' = cofactor (c,a,f,d) - g' = cofactor (d,e,g,h) - h' = cofactor (b,a,h,g) - i' = cofactor (a,b,d,e) - cofactor (q,r,s,t) = det22 (V2 (V2 q r) (V2 s t)) - det = det33 m -{-# INLINE inv33 #-} - - --- | 'transpose' is just an alias for 'distribute' --- --- > transpose (V3 (V2 1 2) (V2 3 4) (V2 5 6)) --- V2 (V3 1 3 5) (V3 2 4 6) -transpose :: (Distributive g, Functor f) => f (g a) -> g (f a) -transpose = distribute -{-# INLINE transpose #-} - --- |4x4 matrix inverse. -inv44 :: Fractional a => M44 a -> M44 a -inv44 (V4 (V4 i00 i01 i02 i03) - (V4 i10 i11 i12 i13) - (V4 i20 i21 i22 i23) - (V4 i30 i31 i32 i33)) = - let s0 = i00 * i11 - i10 * i01 - s1 = i00 * i12 - i10 * i02 - s2 = i00 * i13 - i10 * i03 - s3 = i01 * i12 - i11 * i02 - s4 = i01 * i13 - i11 * i03 - s5 = i02 * i13 - i12 * i03 - c5 = i22 * i33 - i32 * i23 - c4 = i21 * i33 - i31 * i23 - c3 = i21 * i32 - i31 * i22 - c2 = i20 * i33 - i30 * i23 - c1 = i20 * i32 - i30 * i22 - c0 = i20 * i31 - i30 * i21 - det = s0 * c5 - s1 * c4 + s2 * c3 + s3 * c2 - s4 * c1 + s5 * c0 - invDet = recip det - in invDet *!! V4 (V4 (i11 * c5 - i12 * c4 + i13 * c3) - (-i01 * c5 + i02 * c4 - i03 * c3) - (i31 * s5 - i32 * s4 + i33 * s3) - (-i21 * s5 + i22 * s4 - i23 * s3)) - (V4 (-i10 * c5 + i12 * c2 - i13 * c1) - (i00 * c5 - i02 * c2 + i03 * c1) - (-i30 * s5 + i32 * s2 - i33 * s1) - (i20 * s5 - i22 * s2 + i23 * s1)) - (V4 (i10 * c4 - i11 * c2 + i13 * c0) - (-i00 * c4 + i01 * c2 - i03 * c0) - (i30 * s4 - i31 * s2 + i33 * s0) - (-i20 * s4 + i21 * s2 - i23 * s0)) - (V4 (-i10 * c3 + i11 * c1 - i12 * c0) - (i00 * c3 - i01 * c1 + i02 * c0) - (-i30 * s3 + i31 * s1 - i32 * s0) - (i20 * s3 - i21 * s1 + i22 * s0)) -{-# INLINE inv44 #-} - --- | Compute the (L, U) decomposition of a square matrix using Crout's --- algorithm. The 'Index' of the vectors must be 'Integral'. -lu :: ( Num a - , Fractional a - , Foldable m - , Traversable m - , Applicative m - , Additive m - , Ixed (m a) - , Ixed (m (m a)) - , i ~ Index (m a) - , i ~ Index (m (m a)) - , Eq i - , Integral i - , a ~ IxValue (m a) - , m a ~ IxValue (m (m a)) - , Num (m a) - ) - => m (m a) - -> (m (m a), m (m a)) -lu a = - let n = fromIntegral (length a) - initU = identity - initL = zero - buildLVal !i !j !l !u = - let go !k !s - | k == j = s - | otherwise = go (k+1) - ( s - + ( (l ^?! ix i ^?! ix k) - * (u ^?! ix k ^?! ix j) - ) - ) - s' = go 0 0 - in l & (ix i . ix j) .~ ((a ^?! ix i ^?! ix j) - s') - buildL !i !j !l !u - | i == n = l - | otherwise = buildL (i+1) j (buildLVal i j l u) u - buildUVal !i !j !l !u = - let go !k !s - | k == j = s - | otherwise = go (k+1) - ( s - + ( (l ^?! ix j ^?! ix k) - * (u ^?! ix k ^?! ix i) - ) - ) - s' = go 0 0 - in u & (ix j . ix i) .~ ( ((a ^?! ix j ^?! ix i) - s') - / (l ^?! ix j ^?! ix j) - ) - buildU !i !j !l !u - | i == n = u - | otherwise = buildU (i+1) j l (buildUVal i j l u) - buildLU !j !l !u - | j == n = (l, u) - | otherwise = - let l' = buildL j j l u - u' = buildU j j l' u - in buildLU (j+1) l' u' - in buildLU 0 initL initU - --- | Compute the (L, U) decomposition of a square matrix using Crout's --- algorithm, using the vector's 'Finite' instance to provide an index. -luFinite :: ( Num a - , Fractional a - , Functor m - , Finite m - , n ~ Size m - , KnownNat n - , Num (m a) - ) - => m (m a) - -> (m (m a), m (m a)) -luFinite a = - bimap (fmap fromV . fromV) - (fmap fromV . fromV) - (lu (fmap toV (toV a))) - --- | Solve a linear system with a lower-triangular matrix of coefficients with --- forwards substitution. -forwardSub :: ( Num a - , Fractional a - , Foldable m - , Additive m - , Ixed (m a) - , Ixed (m (m a)) - , i ~ Index (m a) - , i ~ Index (m (m a)) - , Eq i - , Ord i - , Integral i - , a ~ IxValue (m a) - , m a ~ IxValue (m (m a)) - ) - => m (m a) - -> m a - -> m a -forwardSub a b = - let n = fromIntegral (length b) - initX = zero - coeff !i !j !s !x - | j == i = s - | otherwise = coeff i (j+1) (s + ((a ^?! ix i ^?! ix j) * (x ^?! ix j))) x - go !i !x - | i == n = x - | otherwise = go (i + 1) (x & ix i .~ ( ((b ^?! ix i) - coeff i 0 0 x) - / (a ^?! ix i ^?! ix i) - )) - in go 0 initX - --- | Solve a linear system with a lower-triangular matrix of coefficients with --- forwards substitution, using the vector's 'Finite' instance to provide an --- index. -forwardSubFinite :: ( Num a - , Fractional a - , Foldable m - , n ~ Size m - , KnownNat n - , Additive m - , Finite m - ) - => m (m a) - -> m a - -> m a -forwardSubFinite a b = fromV (forwardSub (fmap toV (toV a)) (toV b)) - --- | Solve a linear system with an upper-triangular matrix of coefficients with --- backwards substitution. -backwardSub :: ( Num a - , Fractional a - , Foldable m - , Additive m - , Ixed (m a) - , Ixed (m (m a)) - , i ~ Index (m a) - , i ~ Index (m (m a)) - , Eq i - , Ord i - , Integral i - , a ~ IxValue (m a) - , m a ~ IxValue (m (m a)) - ) - => m (m a) - -> m a - -> m a -backwardSub a b = - let n = fromIntegral (length b) - initX = zero - coeff !i !j !s !x - | j == n = s - | otherwise = coeff i - (j+1) - (s + ((a ^?! ix i ^?! ix j) * (x ^?! ix j))) - x - go !i !x - | i < 0 = x - | otherwise = go (i-1) - (x & ix i .~ ( ((b ^?! ix i) - coeff i (i+1) 0 x) - / (a ^?! ix i ^?! ix i) - )) - in go (n-1) initX - --- | Solve a linear system with an upper-triangular matrix of coefficients with --- backwards substitution, using the vector's 'Finite' instance to provide an --- index. -backwardSubFinite :: ( Num a - , Fractional a - , Foldable m - , n ~ Size m - , KnownNat n - , Additive m - , Finite m - ) - => m (m a) - -> m a - -> m a -backwardSubFinite a b = fromV (backwardSub (fmap toV (toV a)) (toV b)) - --- | Solve a linear system with LU decomposition. -luSolve :: ( Num a - , Fractional a - , Foldable m - , Traversable m - , Applicative m - , Additive m - , Ixed (m a) - , Ixed (m (m a)) - , i ~ Index (m a) - , i ~ Index (m (m a)) - , Eq i - , Integral i - , a ~ IxValue (m a) - , m a ~ IxValue (m (m a)) - , Num (m a) - ) - => m (m a) - -> m a - -> m a -luSolve a b = - let (l, u) = lu a - in backwardSub u (forwardSub l b) - --- | Solve a linear system with LU decomposition, using the vector's 'Finite' --- instance to provide an index. -luSolveFinite :: ( Num a - , Fractional a - , Functor m - , Finite m - , n ~ Size m - , KnownNat n - , Num (m a) - ) - => m (m a) - -> m a - -> m a -luSolveFinite a b = fromV (luSolve (fmap toV (toV a)) (toV b)) - --- | Invert a matrix with LU decomposition. -luInv :: ( Num a - , Fractional a - , Foldable m - , Traversable m - , Applicative m - , Additive m - , Distributive m - , Ixed (m a) - , Ixed (m (m a)) - , i ~ Index (m a) - , i ~ Index (m (m a)) - , Eq i - , Integral i - , a ~ IxValue (m a) - , m a ~ IxValue (m (m a)) - , Num (m a) - ) - => m (m a) - -> m (m a) -luInv a = - let n = fromIntegral (length a) - initA' = zero - (l, u) = lu a - go !i !a' - | i == n = a' - | otherwise = let e = zero & ix i .~ 1 - a'r = backwardSub u (forwardSub l e) - in go (i+1) (a' & ix i .~ a'r) - in transpose (go 0 initA') - --- | Invert a matrix with LU decomposition, using the vector's 'Finite' instance --- to provide an index. -luInvFinite :: ( Num a - , Fractional a - , Functor m - , Finite m - , n ~ Size m - , KnownNat n - , Num (m a) - ) - => m (m a) - -> m (m a) -luInvFinite a = fmap fromV (fromV (luInv (fmap toV (toV a)))) - --- | Compute the determinant of a matrix using LU decomposition. -luDet :: ( Num a - , Fractional a - , Foldable m - , Traversable m - , Applicative m - , Additive m - , Trace m - , Ixed (m a) - , Ixed (m (m a)) - , i ~ Index (m a) - , i ~ Index (m (m a)) - , Eq i - , Integral i - , a ~ IxValue (m a) - , m a ~ IxValue (m (m a)) - , Num (m a) - ) - => m (m a) - -> a -luDet a = - let (l, u) = lu a - p = Foldable.foldl (*) 1 - in p (diagonal l) * p (diagonal u) - --- | Compute the determinant of a matrix using LU decomposition, using the --- vector's 'Finite' instance to provide an index. -luDetFinite :: ( Num a - , Fractional a - , Functor m - , Finite m - , n ~ Size m - , KnownNat n - , Num (m a) - ) - => m (m a) - -> a -luDetFinite = luDet . fmap toV . toV +{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++---------------------------------------------------------------------------+-- |+-- Copyright : (C) 2012-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- Simple matrix operation for low-dimensional primitives.+---------------------------------------------------------------------------+module Linear.Matrix+ ( (!*!), (!+!), (!-!), (!*), (*!), (!!*), (*!!), (!!/)+ , column+ , adjoint+ , M22, M23, M24, M32, M33, M34, M42, M43, M44+ , m33_to_m44, m43_to_m44+ , det22, det33, det44, inv22, inv33, inv44+ , identity+ , Trace(..)+ , translation+ , transpose+ , fromQuaternion+ , mkTransformation+ , mkTransformationMat+ , _m22, _m23, _m24+ , _m32, _m33, _m34+ , _m42, _m43, _m44+ , lu+ , luFinite+ , forwardSub+ , forwardSubFinite+ , backwardSub+ , backwardSubFinite+ , luSolve+ , luSolveFinite+ , luInv+ , luInvFinite+ , luDet+ , luDetFinite+ ) where++import Control.Lens hiding (index)+import Control.Lens.Internal.Context+import Data.Distributive+import Data.Foldable as Foldable+import Data.Functor.Rep+import GHC.TypeLits+import Linear.Quaternion+import Linear.V+import Linear.V2+import Linear.V3+import Linear.V4+import Linear.Vector+import Linear.Conjugate+import Linear.Trace++-- $setup+-- >>> import Control.Lens hiding (index)+-- >>> import Data.Complex (Complex (..))+-- >>> import Linear.V2+-- >>> import Linear.V3+-- >>> import Linear.V+-- >>> import qualified Data.IntMap as IntMap+-- >>> import Debug.SimpleReflect.Vars++-- | This is a generalization of 'Control.Lens.inside' to work over any corepresentable 'Functor'.+--+-- @+-- 'column' :: 'Representable' f => 'Lens' s t a b -> 'Lens' (f s) (f t) (f a) (f b)+-- @+--+-- In practice it is used to access a column of a matrix.+--+-- >>> V2 (V3 1 2 3) (V3 4 5 6) ^._x+-- V3 1 2 3+--+-- >>> V2 (V3 1 2 3) (V3 4 5 6) ^.column _x+-- V2 1 4+column :: Representable f => LensLike (Context a b) s t a b -> Lens (f s) (f t) (f a) (f b)+column l f es = o <$> f i where+ go = l (Context id)+ i = tabulate $ \ e -> ipos $ go (index es e)+ o eb = tabulate $ \ e -> ipeek (index eb e) (go (index es e))++infixl 7 !*!+-- | Matrix product. This can compute any combination of sparse and dense multiplication.+--+-- >>> V2 (V3 1 2 3) (V3 4 5 6) !*! V3 (V2 1 2) (V2 3 4) (V2 4 5)+-- V2 (V2 19 25) (V2 43 58)+--+-- >>> V2 (IntMap.fromList [(1,2)]) (IntMap.fromList [(2,3)]) !*! IntMap.fromList [(1,V3 0 0 1), (2, V3 0 0 5)]+-- V2 (V3 0 0 2) (V3 0 0 15)+(!*!) :: (Functor m, Foldable t, Additive t, Additive n, Num a) => m (t a) -> t (n a) -> m (n a)+f !*! g = fmap (\ f' -> Foldable.foldl' (^+^) zero $ liftI2 (*^) f' g) f++infixl 6 !+!+-- | Entry-wise matrix addition.+--+-- >>> V2 (V3 1 2 3) (V3 4 5 6) !+! V2 (V3 7 8 9) (V3 1 2 3)+-- V2 (V3 8 10 12) (V3 5 7 9)+(!+!) :: (Additive m, Additive n, Num a) => m (n a) -> m (n a) -> m (n a)+as !+! bs = liftU2 (^+^) as bs++infixl 6 !-!+-- | Entry-wise matrix subtraction.+--+-- >>> V2 (V3 1 2 3) (V3 4 5 6) !-! V2 (V3 7 8 9) (V3 1 2 3)+-- V2 (V3 (-6) (-6) (-6)) (V3 3 3 3)+(!-!) :: (Additive m, Additive n, Num a) => m (n a) -> m (n a) -> m (n a)+as !-! bs = liftU2 (^-^) as bs++infixl 7 !*+-- | Matrix * column vector+--+-- >>> V2 (V3 1 2 3) (V3 4 5 6) !* V3 7 8 9+-- V2 50 122+(!*) :: (Functor m, Foldable r, Additive r, Num a) => m (r a) -> r a -> m a+m !* v = fmap (\r -> Foldable.sum $ liftI2 (*) r v) m++infixl 7 *!+-- | Row vector * matrix+--+-- >>> V2 1 2 *! V2 (V3 3 4 5) (V3 6 7 8)+-- V3 15 18 21++-- (*!) :: (Metric r, Additive n, Num a) => r a -> r (n a) -> n a+-- f *! g = dot f <$> distribute g++(*!) :: (Num a, Foldable t, Additive f, Additive t) => t a -> t (f a) -> f a+f *! g = sumV $ liftI2 (*^) f g++infixl 7 *!!+-- | Scalar-matrix product+--+-- >>> 5 *!! V2 (V2 1 2) (V2 3 4)+-- V2 (V2 5 10) (V2 15 20)+(*!!) :: (Functor m, Functor r, Num a) => a -> m (r a) -> m (r a)+s *!! m = fmap (s *^) m+{-# INLINE (*!!) #-}++infixl 7 !!*+-- | Matrix-scalar product+--+-- >>> V2 (V2 1 2) (V2 3 4) !!* 5+-- V2 (V2 5 10) (V2 15 20)+(!!*) :: (Functor m, Functor r, Num a) => m (r a) -> a -> m (r a)+(!!*) = flip (*!!)+{-# INLINE (!!*) #-}++infixl 7 !!/+-- | Matrix-scalar division+(!!/) :: (Functor m, Functor r, Fractional a) => m (r a) -> a -> m (r a)+m !!/ s = fmap (^/ s) m+{-# INLINE (!!/) #-}++-- | Hermitian conjugate or conjugate transpose+--+-- >>> adjoint (V2 (V2 (1 :+ 2) (3 :+ 4)) (V2 (5 :+ 6) (7 :+ 8)))+-- V2 (V2 (1.0 :+ (-2.0)) (5.0 :+ (-6.0))) (V2 (3.0 :+ (-4.0)) (7.0 :+ (-8.0)))+adjoint :: (Functor m, Distributive n, Conjugate a) => m (n a) -> n (m a)+adjoint = collect (fmap conjugate)+{-# INLINE adjoint #-}++-- * Matrices+--+-- Matrices use a row-major representation.++-- | A 2x2 matrix with row-major representation+type M22 a = V2 (V2 a)+-- | A 2x3 matrix with row-major representation+type M23 a = V2 (V3 a)+-- | A 2x4 matrix with row-major representation+type M24 a = V2 (V4 a)+-- | A 3x2 matrix with row-major representation+type M32 a = V3 (V2 a)+-- | A 3x3 matrix with row-major representation+type M33 a = V3 (V3 a)+-- | A 3x4 matrix with row-major representation+type M34 a = V3 (V4 a)+-- | A 4x2 matrix with row-major representation+type M42 a = V4 (V2 a)+-- | A 4x3 matrix with row-major representation+type M43 a = V4 (V3 a)+-- | A 4x4 matrix with row-major representation+type M44 a = V4 (V4 a)++-- | Build a rotation matrix from a unit 'Quaternion'.+fromQuaternion :: Num a => Quaternion a -> M33 a+fromQuaternion (Quaternion w (V3 x y z)) =+ V3 (V3 (1-2*(y2+z2)) (2*(xy-zw)) (2*(xz+yw)))+ (V3 (2*(xy+zw)) (1-2*(x2+z2)) (2*(yz-xw)))+ (V3 (2*(xz-yw)) (2*(yz+xw)) (1-2*(x2+y2)))+ where x2 = x*x+ y2 = y*y+ z2 = z*z+ xy = x*y+ xz = x*z+ xw = x*w+ yz = y*z+ yw = y*w+ zw = z*w+{-# INLINE fromQuaternion #-}++-- | Build a transformation matrix from a rotation matrix and a+-- translation vector.+mkTransformationMat :: Num a => M33 a -> V3 a -> M44 a+mkTransformationMat (V3 r1 r2 r3) (V3 tx ty tz) =+ V4 (snoc3 r1 tx) (snoc3 r2 ty) (snoc3 r3 tz) (V4 0 0 0 1)+ where snoc3 (V3 x y z) = V4 x y z+{-# INLINE mkTransformationMat #-}++-- |Build a transformation matrix from a rotation expressed as a+-- 'Quaternion' and a translation vector.+mkTransformation :: Num a => Quaternion a -> V3 a -> M44 a+mkTransformation = mkTransformationMat . fromQuaternion+{-# INLINE mkTransformation #-}++-- | Convert from a 4x3 matrix to a 4x4 matrix, extending it with the @[ 0 0 0 1 ]@ column vector+m43_to_m44 :: Num a => M43 a -> M44 a+m43_to_m44+ (V4 (V3 a b c)+ (V3 d e f)+ (V3 g h i)+ (V3 j k l)) =+ V4 (V4 a b c 0)+ (V4 d e f 0)+ (V4 g h i 0)+ (V4 j k l 1)++-- | Convert a 3x3 matrix to a 4x4 matrix extending it with 0's in the new row and column.+m33_to_m44 :: Num a => M33 a -> M44 a+m33_to_m44 (V3 r1 r2 r3) = V4 (vector r1) (vector r2) (vector r3) (point 0)++-- |The identity matrix for any dimension vector.+--+-- >>> identity :: M44 Int+-- V4 (V4 1 0 0 0) (V4 0 1 0 0) (V4 0 0 1 0) (V4 0 0 0 1)+-- >>> identity :: V3 (V3 Int)+-- V3 (V3 1 0 0) (V3 0 1 0) (V3 0 0 1)+identity :: (Num a, Traversable t, Applicative t) => t (t a)+identity = scaled (pure 1)++-- |Extract the translation vector (first three entries of the last+-- column) from a 3x4 or 4x4 matrix.+translation :: (Representable t, R3 t, R4 v) => Lens' (t (v a)) (V3 a)+translation = column _w._xyz+{-+translation f rs = aux <$> f (view _w <$> view _xyz rs)+ where aux (V3 x y z) = (_x._w .~ x) . (_y._w .~ y) . (_z._w .~ z) $ rs++-- translation :: (R3 t, R4 v, Functor f, Functor t) => (V3 a -> f (V3 a)) -> t (v a) -> f (t a)+-- translation = (. fmap (^._w)) . _xyz where+-- x ^. l = getConst (l Const x)+-}++-- |Extract a 2x2 matrix from a matrix of higher dimensions by dropping excess+-- rows and columns.+_m22 :: (Representable t, R2 t, R2 v) => Lens' (t (v a)) (M22 a)+_m22 = column _xy._xy++-- |Extract a 2x3 matrix from a matrix of higher dimensions by dropping excess+-- rows and columns.+_m23 :: (Representable t, R2 t, R3 v) => Lens' (t (v a)) (M23 a)+_m23 = column _xyz._xy++-- |Extract a 2x4 matrix from a matrix of higher dimensions by dropping excess+-- rows and columns.+_m24 :: (Representable t, R2 t, R4 v) => Lens' (t (v a)) (M24 a)+_m24 = column _xyzw._xy++-- |Extract a 3x2 matrix from a matrix of higher dimensions by dropping excess+-- rows and columns.+_m32 :: (Representable t, R3 t, R2 v) => Lens' (t (v a)) (M32 a)+_m32 = column _xy._xyz++-- |Extract a 3x3 matrix from a matrix of higher dimensions by dropping excess+-- rows and columns.+_m33 :: (Representable t, R3 t, R3 v) => Lens' (t (v a)) (M33 a)+_m33 = column _xyz._xyz++-- |Extract a 3x4 matrix from a matrix of higher dimensions by dropping excess+-- rows and columns.+_m34 :: (Representable t, R3 t, R4 v) => Lens' (t (v a)) (M34 a)+_m34 = column _xyzw._xyz++-- |Extract a 4x2 matrix from a matrix of higher dimensions by dropping excess+-- rows and columns.+_m42 :: (Representable t, R4 t, R2 v) => Lens' (t (v a)) (M42 a)+_m42 = column _xy._xyzw++-- |Extract a 4x3 matrix from a matrix of higher dimensions by dropping excess+-- rows and columns.+_m43 :: (Representable t, R4 t, R3 v) => Lens' (t (v a)) (M43 a)+_m43 = column _xyz._xyzw++-- |Extract a 4x4 matrix from a matrix of higher dimensions by dropping excess+-- rows and columns.+_m44 :: (Representable t, R4 t, R4 v) => Lens' (t (v a)) (M44 a)+_m44 = column _xyzw._xyzw++-- |2x2 matrix determinant.+--+-- >>> det22 (V2 (V2 a b) (V2 c d))+-- a * d - b * c+det22 :: Num a => M22 a -> a+det22 (V2 (V2 a b) (V2 c d)) = a * d - b * c+{-# INLINE det22 #-}++-- |3x3 matrix determinant.+--+-- >>> det33 (V3 (V3 a b c) (V3 d e f) (V3 g h i))+-- a * (e * i - f * h) - d * (b * i - c * h) + g * (b * f - c * e)+det33 :: Num a => M33 a -> a+det33 (V3 (V3 a b c)+ (V3 d e f)+ (V3 g h i)) = a * (e*i-f*h) - d * (b*i-c*h) + g * (b*f-c*e)+{-# INLINE det33 #-}++-- |4x4 matrix determinant.+det44 :: Num a => M44 a -> a+det44 (V4 (V4 i00 i01 i02 i03)+ (V4 i10 i11 i12 i13)+ (V4 i20 i21 i22 i23)+ (V4 i30 i31 i32 i33)) =+ let+ s0 = i00 * i11 - i10 * i01+ s1 = i00 * i12 - i10 * i02+ s2 = i00 * i13 - i10 * i03+ s3 = i01 * i12 - i11 * i02+ s4 = i01 * i13 - i11 * i03+ s5 = i02 * i13 - i12 * i03++ c5 = i22 * i33 - i32 * i23+ c4 = i21 * i33 - i31 * i23+ c3 = i21 * i32 - i31 * i22+ c2 = i20 * i33 - i30 * i23+ c1 = i20 * i32 - i30 * i22+ c0 = i20 * i31 - i30 * i21+ in s0 * c5 - s1 * c4 + s2 * c3 + s3 * c2 - s4 * c1 + s5 * c0+{-# INLINE det44 #-}++-- |2x2 matrix inverse.+--+-- >>> inv22 $ V2 (V2 1 2) (V2 3 4)+-- V2 (V2 (-2.0) 1.0) (V2 1.5 (-0.5))+inv22 :: Fractional a => M22 a -> M22 a+inv22 m@(V2 (V2 a b) (V2 c d)) = (1 / det) *!! V2 (V2 d (-b)) (V2 (-c) a)+ where det = det22 m+{-# INLINE inv22 #-}++-- |3x3 matrix inverse.+--+-- >>> inv33 $ V3 (V3 1 2 4) (V3 4 2 2) (V3 1 1 1)+-- V3 (V3 0.0 0.5 (-1.0)) (V3 (-0.5) (-0.75) 3.5) (V3 0.5 0.25 (-1.5))+inv33 :: Fractional a => M33 a -> M33 a+inv33 m@(V3 (V3 a b c)+ (V3 d e f)+ (V3 g h i))+ = (1 / det) *!! V3 (V3 a' b' c')+ (V3 d' e' f')+ (V3 g' h' i')+ where a' = cofactor (e,f,h,i)+ b' = cofactor (c,b,i,h)+ c' = cofactor (b,c,e,f)+ d' = cofactor (f,d,i,g)+ e' = cofactor (a,c,g,i)+ f' = cofactor (c,a,f,d)+ g' = cofactor (d,e,g,h)+ h' = cofactor (b,a,h,g)+ i' = cofactor (a,b,d,e)+ cofactor (q,r,s,t) = det22 (V2 (V2 q r) (V2 s t))+ det = det33 m+{-# INLINE inv33 #-}+++-- | 'transpose' is just an alias for 'distribute'+--+-- > transpose (V3 (V2 1 2) (V2 3 4) (V2 5 6))+-- V2 (V3 1 3 5) (V3 2 4 6)+transpose :: (Distributive g, Functor f) => f (g a) -> g (f a)+transpose = distribute+{-# INLINE transpose #-}++-- |4x4 matrix inverse.+inv44 :: Fractional a => M44 a -> M44 a+inv44 (V4 (V4 i00 i01 i02 i03)+ (V4 i10 i11 i12 i13)+ (V4 i20 i21 i22 i23)+ (V4 i30 i31 i32 i33)) =+ let s0 = i00 * i11 - i10 * i01+ s1 = i00 * i12 - i10 * i02+ s2 = i00 * i13 - i10 * i03+ s3 = i01 * i12 - i11 * i02+ s4 = i01 * i13 - i11 * i03+ s5 = i02 * i13 - i12 * i03+ c5 = i22 * i33 - i32 * i23+ c4 = i21 * i33 - i31 * i23+ c3 = i21 * i32 - i31 * i22+ c2 = i20 * i33 - i30 * i23+ c1 = i20 * i32 - i30 * i22+ c0 = i20 * i31 - i30 * i21+ det = s0 * c5 - s1 * c4 + s2 * c3 + s3 * c2 - s4 * c1 + s5 * c0+ invDet = recip det+ in invDet *!! V4 (V4 (i11 * c5 - i12 * c4 + i13 * c3)+ (-i01 * c5 + i02 * c4 - i03 * c3)+ (i31 * s5 - i32 * s4 + i33 * s3)+ (-i21 * s5 + i22 * s4 - i23 * s3))+ (V4 (-i10 * c5 + i12 * c2 - i13 * c1)+ (i00 * c5 - i02 * c2 + i03 * c1)+ (-i30 * s5 + i32 * s2 - i33 * s1)+ (i20 * s5 - i22 * s2 + i23 * s1))+ (V4 (i10 * c4 - i11 * c2 + i13 * c0)+ (-i00 * c4 + i01 * c2 - i03 * c0)+ (i30 * s4 - i31 * s2 + i33 * s0)+ (-i20 * s4 + i21 * s2 - i23 * s0))+ (V4 (-i10 * c3 + i11 * c1 - i12 * c0)+ (i00 * c3 - i01 * c1 + i02 * c0)+ (-i30 * s3 + i31 * s1 - i32 * s0)+ (i20 * s3 - i21 * s1 + i22 * s0))+{-# INLINE inv44 #-}++-- | Compute the (L, U) decomposition of a square matrix using Crout's+-- algorithm. The 'Index' of the vectors must be 'Integral'.+lu :: ( Num a+ , Fractional a+ , Foldable m+ , Traversable m+ , Applicative m+ , Additive m+ , Ixed (m a)+ , Ixed (m (m a))+ , i ~ Index (m a)+ , i ~ Index (m (m a))+ , Eq i+ , Integral i+ , a ~ IxValue (m a)+ , m a ~ IxValue (m (m a))+ , Num (m a)+ )+ => m (m a)+ -> (m (m a), m (m a))+lu a =+ let n = fromIntegral (length a)+ initU = identity+ initL = zero+ buildLVal !i !j !l !u =+ let go !k !s+ | k == j = s+ | otherwise = go (k+1)+ ( s+ + ( (l ^?! ix i ^?! ix k)+ * (u ^?! ix k ^?! ix j)+ )+ )+ s' = go 0 0+ in l & (ix i . ix j) .~ ((a ^?! ix i ^?! ix j) - s')+ buildL !i !j !l !u+ | i == n = l+ | otherwise = buildL (i+1) j (buildLVal i j l u) u+ buildUVal !i !j !l !u =+ let go !k !s+ | k == j = s+ | otherwise = go (k+1)+ ( s+ + ( (l ^?! ix j ^?! ix k)+ * (u ^?! ix k ^?! ix i)+ )+ )+ s' = go 0 0+ in u & (ix j . ix i) .~ ( ((a ^?! ix j ^?! ix i) - s')+ / (l ^?! ix j ^?! ix j)+ )+ buildU !i !j !l !u+ | i == n = u+ | otherwise = buildU (i+1) j l (buildUVal i j l u)+ buildLU !j !l !u+ | j == n = (l, u)+ | otherwise =+ let l' = buildL j j l u+ u' = buildU j j l' u+ in buildLU (j+1) l' u'+ in buildLU 0 initL initU++-- | Compute the (L, U) decomposition of a square matrix using Crout's+-- algorithm, using the vector's 'Finite' instance to provide an index.+luFinite :: ( Num a+ , Fractional a+ , Functor m+ , Finite m+ , n ~ Size m+ , KnownNat n+ , Num (m a)+ )+ => m (m a)+ -> (m (m a), m (m a))+luFinite a =+ bimap (fmap fromV . fromV)+ (fmap fromV . fromV)+ (lu (fmap toV (toV a)))++-- | Solve a linear system with a lower-triangular matrix of coefficients with+-- forwards substitution.+forwardSub :: ( Num a+ , Fractional a+ , Foldable m+ , Additive m+ , Ixed (m a)+ , Ixed (m (m a))+ , i ~ Index (m a)+ , i ~ Index (m (m a))+ , Eq i+ , Ord i+ , Integral i+ , a ~ IxValue (m a)+ , m a ~ IxValue (m (m a))+ )+ => m (m a)+ -> m a+ -> m a+forwardSub a b =+ let n = fromIntegral (length b)+ initX = zero+ coeff !i !j !s !x+ | j == i = s+ | otherwise = coeff i (j+1) (s + ((a ^?! ix i ^?! ix j) * (x ^?! ix j))) x+ go !i !x+ | i == n = x+ | otherwise = go (i + 1) (x & ix i .~ ( ((b ^?! ix i) - coeff i 0 0 x)+ / (a ^?! ix i ^?! ix i)+ ))+ in go 0 initX++-- | Solve a linear system with a lower-triangular matrix of coefficients with+-- forwards substitution, using the vector's 'Finite' instance to provide an+-- index.+forwardSubFinite :: ( Num a+ , Fractional a+ , Foldable m+ , n ~ Size m+ , KnownNat n+ , Additive m+ , Finite m+ )+ => m (m a)+ -> m a+ -> m a+forwardSubFinite a b = fromV (forwardSub (fmap toV (toV a)) (toV b))++-- | Solve a linear system with an upper-triangular matrix of coefficients with+-- backwards substitution.+backwardSub :: ( Num a+ , Fractional a+ , Foldable m+ , Additive m+ , Ixed (m a)+ , Ixed (m (m a))+ , i ~ Index (m a)+ , i ~ Index (m (m a))+ , Eq i+ , Ord i+ , Integral i+ , a ~ IxValue (m a)+ , m a ~ IxValue (m (m a))+ )+ => m (m a)+ -> m a+ -> m a+backwardSub a b =+ let n = fromIntegral (length b)+ initX = zero+ coeff !i !j !s !x+ | j == n = s+ | otherwise = coeff i+ (j+1)+ (s + ((a ^?! ix i ^?! ix j) * (x ^?! ix j)))+ x+ go !i !x+ | i < 0 = x+ | otherwise = go (i-1)+ (x & ix i .~ ( ((b ^?! ix i) - coeff i (i+1) 0 x)+ / (a ^?! ix i ^?! ix i)+ ))+ in go (n-1) initX++-- | Solve a linear system with an upper-triangular matrix of coefficients with+-- backwards substitution, using the vector's 'Finite' instance to provide an+-- index.+backwardSubFinite :: ( Num a+ , Fractional a+ , Foldable m+ , n ~ Size m+ , KnownNat n+ , Additive m+ , Finite m+ )+ => m (m a)+ -> m a+ -> m a+backwardSubFinite a b = fromV (backwardSub (fmap toV (toV a)) (toV b))++-- | Solve a linear system with LU decomposition.+luSolve :: ( Num a+ , Fractional a+ , Foldable m+ , Traversable m+ , Applicative m+ , Additive m+ , Ixed (m a)+ , Ixed (m (m a))+ , i ~ Index (m a)+ , i ~ Index (m (m a))+ , Eq i+ , Integral i+ , a ~ IxValue (m a)+ , m a ~ IxValue (m (m a))+ , Num (m a)+ )+ => m (m a)+ -> m a+ -> m a+luSolve a b =+ let (l, u) = lu a+ in backwardSub u (forwardSub l b)++-- | Solve a linear system with LU decomposition, using the vector's 'Finite'+-- instance to provide an index.+luSolveFinite :: ( Num a+ , Fractional a+ , Functor m+ , Finite m+ , n ~ Size m+ , KnownNat n+ , Num (m a)+ )+ => m (m a)+ -> m a+ -> m a+luSolveFinite a b = fromV (luSolve (fmap toV (toV a)) (toV b))++-- | Invert a matrix with LU decomposition.+luInv :: ( Num a+ , Fractional a+ , Foldable m+ , Traversable m+ , Applicative m+ , Additive m+ , Distributive m+ , Ixed (m a)+ , Ixed (m (m a))+ , i ~ Index (m a)+ , i ~ Index (m (m a))+ , Eq i+ , Integral i+ , a ~ IxValue (m a)+ , m a ~ IxValue (m (m a))+ , Num (m a)+ )+ => m (m a)+ -> m (m a)+luInv a =+ let n = fromIntegral (length a)+ initA' = zero+ (l, u) = lu a+ go !i !a'+ | i == n = a'+ | otherwise = let e = zero & ix i .~ 1+ a'r = backwardSub u (forwardSub l e)+ in go (i+1) (a' & ix i .~ a'r)+ in transpose (go 0 initA')++-- | Invert a matrix with LU decomposition, using the vector's 'Finite' instance+-- to provide an index.+luInvFinite :: ( Num a+ , Fractional a+ , Functor m+ , Finite m+ , n ~ Size m+ , KnownNat n+ , Num (m a)+ )+ => m (m a)+ -> m (m a)+luInvFinite a = fmap fromV (fromV (luInv (fmap toV (toV a))))++-- | Compute the determinant of a matrix using LU decomposition.+luDet :: ( Num a+ , Fractional a+ , Foldable m+ , Traversable m+ , Applicative m+ , Additive m+ , Trace m+ , Ixed (m a)+ , Ixed (m (m a))+ , i ~ Index (m a)+ , i ~ Index (m (m a))+ , Eq i+ , Integral i+ , a ~ IxValue (m a)+ , m a ~ IxValue (m (m a))+ , Num (m a)+ )+ => m (m a)+ -> a+luDet a =+ let (l, u) = lu a+ p = Foldable.foldl (*) 1+ in p (diagonal l) * p (diagonal u)++-- | Compute the determinant of a matrix using LU decomposition, using the+-- vector's 'Finite' instance to provide an index.+luDetFinite :: ( Num a+ , Fractional a+ , Functor m+ , Finite m+ , n ~ Size m+ , KnownNat n+ , Num (m a)+ )+ => m (m a)+ -> a+luDetFinite = luDet . fmap toV . toV
src/Linear/Metric.hs view
@@ -1,110 +1,110 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE Trustworthy #-} ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2012-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : experimental --- Portability : non-portable --- --- Free metric spaces ----------------------------------------------------------------------------- -module Linear.Metric - ( Metric(..), normalize, project - ) where - -import Control.Applicative -import Data.Foldable as Foldable -import Data.Functor.Compose -import Data.Functor.Identity -import Data.Functor.Product -import Data.Vector (Vector) -import Data.IntMap (IntMap) -import Data.Map (Map) -import Data.HashMap.Strict (HashMap) -import Data.Hashable (Hashable) -import Linear.Epsilon -import Linear.Vector - --- $setup --- >>> import Linear --- - --- | Free and sparse inner product/metric spaces. -class Additive f => Metric f where - -- | Compute the inner product of two vectors or (equivalently) - -- convert a vector @f a@ into a covector @f a -> a@. - -- - -- >>> V2 1 2 `dot` V2 3 4 - -- 11 - dot :: Num a => f a -> f a -> a -#ifndef HLINT - default dot :: (Foldable f, Num a) => f a -> f a -> a - dot x y = Foldable.sum $ liftI2 (*) x y -#endif - - -- | Compute the squared norm. The name quadrance arises from - -- Norman J. Wildberger's rational trigonometry. - quadrance :: Num a => f a -> a - quadrance v = dot v v - - -- | Compute the quadrance of the difference - qd :: Num a => f a -> f a -> a - qd f g = quadrance (f ^-^ g) - - -- | Compute the distance between two vectors in a metric space - distance :: Floating a => f a -> f a -> a - distance f g = norm (f ^-^ g) - - -- | Compute the norm of a vector in a metric space - norm :: Floating a => f a -> a - norm v = sqrt (quadrance v) - - -- | Convert a non-zero vector to unit vector. - signorm :: Floating a => f a -> f a - signorm v = fmap (/m) v where - m = norm v - -instance (Metric f, Metric g) => Metric (Product f g) where - dot (Pair a b) (Pair c d) = dot a c + dot b d - quadrance (Pair a b) = quadrance a + quadrance b - qd (Pair a b) (Pair c d) = qd a c + qd b d - distance p q = sqrt (qd p q) - -instance (Metric f, Metric g) => Metric (Compose f g) where - dot (Compose a) (Compose b) = quadrance (liftI2 dot a b) - quadrance = quadrance . fmap quadrance . getCompose - qd (Compose a) (Compose b) = quadrance (liftI2 qd a b) - distance (Compose a) (Compose b) = norm (liftI2 qd a b) - -instance Metric Identity where - dot (Identity x) (Identity y) = x * y - -instance Metric [] - -instance Metric Maybe - -instance Metric ZipList where - -- ZipList is missing its Foldable instance - dot (ZipList x) (ZipList y) = dot x y - -instance Metric IntMap - -instance Ord k => Metric (Map k) - -instance (Hashable k, Eq k) => Metric (HashMap k) - -instance Metric Vector - --- | Normalize a 'Metric' functor to have unit 'norm'. This function --- does not change the functor if its 'norm' is 0 or 1. -normalize :: (Floating a, Metric f, Epsilon a) => f a -> f a -normalize v = if nearZero l || nearZero (1-l) then v else fmap (/sqrt l) v - where l = quadrance v - --- | @project u v@ computes the projection of @v@ onto @u@. -project :: (Metric v, Fractional a) => v a -> v a -> v a -project u v = ((v `dot` u) / quadrance u) *^ u +{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE Trustworthy #-}+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2012-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- Free metric spaces+----------------------------------------------------------------------------+module Linear.Metric+ ( Metric(..), normalize, project+ ) where++import Control.Applicative+import Data.Foldable as Foldable+import Data.Functor.Compose+import Data.Functor.Identity+import Data.Functor.Product+import Data.Vector (Vector)+import Data.IntMap (IntMap)+import Data.Map (Map)+import Data.HashMap.Strict (HashMap)+import Data.Hashable (Hashable)+import Linear.Epsilon+import Linear.Vector++-- $setup+-- >>> import Linear+--++-- | Free and sparse inner product/metric spaces.+class Additive f => Metric f where+ -- | Compute the inner product of two vectors or (equivalently)+ -- convert a vector @f a@ into a covector @f a -> a@.+ --+ -- >>> V2 1 2 `dot` V2 3 4+ -- 11+ dot :: Num a => f a -> f a -> a+#ifndef HLINT+ default dot :: (Foldable f, Num a) => f a -> f a -> a+ dot x y = Foldable.sum $ liftI2 (*) x y+#endif++ -- | Compute the squared norm. The name quadrance arises from+ -- Norman J. Wildberger's rational trigonometry.+ quadrance :: Num a => f a -> a+ quadrance v = dot v v++ -- | Compute the quadrance of the difference+ qd :: Num a => f a -> f a -> a+ qd f g = quadrance (f ^-^ g)++ -- | Compute the distance between two vectors in a metric space+ distance :: Floating a => f a -> f a -> a+ distance f g = norm (f ^-^ g)++ -- | Compute the norm of a vector in a metric space+ norm :: Floating a => f a -> a+ norm v = sqrt (quadrance v)++ -- | Convert a non-zero vector to unit vector.+ signorm :: Floating a => f a -> f a+ signorm v = fmap (/m) v where+ m = norm v++instance (Metric f, Metric g) => Metric (Product f g) where+ dot (Pair a b) (Pair c d) = dot a c + dot b d+ quadrance (Pair a b) = quadrance a + quadrance b+ qd (Pair a b) (Pair c d) = qd a c + qd b d+ distance p q = sqrt (qd p q)++instance (Metric f, Metric g) => Metric (Compose f g) where+ dot (Compose a) (Compose b) = quadrance (liftI2 dot a b)+ quadrance = quadrance . fmap quadrance . getCompose+ qd (Compose a) (Compose b) = quadrance (liftI2 qd a b)+ distance (Compose a) (Compose b) = norm (liftI2 qd a b)++instance Metric Identity where+ dot (Identity x) (Identity y) = x * y++instance Metric []++instance Metric Maybe++instance Metric ZipList where+ -- ZipList is missing its Foldable instance+ dot (ZipList x) (ZipList y) = dot x y++instance Metric IntMap++instance Ord k => Metric (Map k)++instance (Hashable k, Eq k) => Metric (HashMap k)++instance Metric Vector++-- | Normalize a 'Metric' functor to have unit 'norm'. This function+-- does not change the functor if its 'norm' is 0 or 1.+normalize :: (Floating a, Metric f, Epsilon a) => f a -> f a+normalize v = if nearZero l || nearZero (1-l) then v else fmap (/sqrt l) v+ where l = quadrance v++-- | @project u v@ computes the projection of @v@ onto @u@.+project :: (Metric v, Fractional a) => v a -> v a -> v a+project u v = ((v `dot` u) / quadrance u) *^ u
src/Linear/Plucker.hs view
@@ -1,698 +1,700 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveLift #-} - -#ifndef MIN_VERSION_vector -#define MIN_VERSION_vector(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_transformers -#define MIN_VERSION_transformers(x,y,z) 1 -#endif ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2012-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : experimental --- Portability : non-portable --- --- Plücker coordinates for lines in 3d homogeneous space. ----------------------------------------------------------------------------- -module Linear.Plucker - ( Plucker(..) - , squaredError - , isotropic - , (><) - , plucker - , plucker3D - -- * Operations on lines - , parallel - , intersects - , LinePass(..) - , passes - , quadranceToOrigin - , closestToOrigin - , isLine - , coincides - , coincides' - -- * Basis elements - , p01, p02, p03 - , p10, p12, p13 - , p20, p21, p23 - , p30, p31, p32 - - , e01, e02, e03, e12, e31, e23 - ) where - -import Control.Applicative -import Control.DeepSeq (NFData(rnf)) -import Control.Monad (liftM) -import Control.Monad.Fix -import Control.Monad.Zip -import Control.Lens as Lens hiding (index, (<.>)) -import Data.Binary as Binary -import Data.Bytes.Serial -import Data.Distributive -import Data.Foldable as Foldable -import qualified Data.Foldable.WithIndex as WithIndex -import Data.Functor.Bind -import Data.Functor.Classes -import Data.Functor.Rep -import qualified Data.Functor.WithIndex as WithIndex -import Data.Hashable -import Data.Semigroup -import Data.Semigroup.Foldable -import Data.Serialize as Cereal -import qualified Data.Traversable.WithIndex as WithIndex -import qualified Data.Vector as V -import qualified Data.Vector.Generic.Mutable as M -import qualified Data.Vector.Generic as G -import qualified Data.Vector.Unboxed.Base as U -import Foreign.Ptr (castPtr) -import Foreign.Storable (Storable(..)) -import GHC.Arr (Ix(..)) -import GHC.Generics (Generic, Generic1) -#if defined(MIN_VERSION_template_haskell) -import Language.Haskell.TH.Syntax (Lift) -#endif -import Linear.Epsilon -import Linear.Metric -import Linear.V -import Linear.V2 -import Linear.V3 -import Linear.V4 -import Linear.Vector -import System.Random (Random(..)) - --- | Plücker coordinates for lines in a 3-dimensional space. -data Plucker a = Plucker !a !a !a !a !a !a deriving (Eq,Ord,Show,Read - ,Generic,Generic1 -#if defined(MIN_VERSION_template_haskell) - ,Lift -#endif - ) - -instance Finite Plucker where - type Size Plucker = 6 - toV (Plucker a b c d e f) = V (V.fromListN 6 [a,b,c,d,e,f]) - fromV (V v) = Plucker (v V.! 0) (v V.! 1) (v V.! 2) (v V.! 3) (v V.! 4) (v V.! 5) - -instance Random a => Random (Plucker a) where - random g = case random g of - (a, g1) -> case random g1 of - (b, g2) -> case random g2 of - (c, g3) -> case random g3 of - (d, g4) -> case random g4 of - (e, g5) -> case random g5 of - (f, g6) -> (Plucker a b c d e f, g6) - randomR (Plucker a b c d e f, Plucker a' b' c' d' e' f') g = case randomR (a,a') g of - (a'', g1) -> case randomR (b,b') g1 of - (b'', g2) -> case randomR (c,c') g2 of - (c'', g3) -> case randomR (d,d') g3 of - (d'', g4) -> case randomR (e,e') g4 of - (e'', g5) -> case randomR (f,f') g5 of - (f'', g6) -> (Plucker a'' b'' c'' d'' e'' f'', g6) - -instance Functor Plucker where - fmap g (Plucker a b c d e f) = Plucker (g a) (g b) (g c) (g d) (g e) (g f) - {-# INLINE fmap #-} - -instance Apply Plucker where - Plucker a b c d e f <.> Plucker g h i j k l = - Plucker (a g) (b h) (c i) (d j) (e k) (f l) - {-# INLINE (<.>) #-} - -instance Applicative Plucker where - pure a = Plucker a a a a a a - {-# INLINE pure #-} - Plucker a b c d e f <*> Plucker g h i j k l = - Plucker (a g) (b h) (c i) (d j) (e k) (f l) - {-# INLINE (<*>) #-} - -instance Additive Plucker where - zero = pure 0 - {-# INLINE zero #-} - liftU2 = liftA2 - {-# INLINE liftU2 #-} - liftI2 = liftA2 - {-# INLINE liftI2 #-} - -instance Bind Plucker where - Plucker a b c d e f >>- g = Plucker a' b' c' d' e' f' where - Plucker a' _ _ _ _ _ = g a - Plucker _ b' _ _ _ _ = g b - Plucker _ _ c' _ _ _ = g c - Plucker _ _ _ d' _ _ = g d - Plucker _ _ _ _ e' _ = g e - Plucker _ _ _ _ _ f' = g f - {-# INLINE (>>-) #-} - -instance Monad Plucker where -#if !(MIN_VERSION_base(4,11,0)) - return a = Plucker a a a a a a - {-# INLINE return #-} -#endif - Plucker a b c d e f >>= g = Plucker a' b' c' d' e' f' where - Plucker a' _ _ _ _ _ = g a - Plucker _ b' _ _ _ _ = g b - Plucker _ _ c' _ _ _ = g c - Plucker _ _ _ d' _ _ = g d - Plucker _ _ _ _ e' _ = g e - Plucker _ _ _ _ _ f' = g f - {-# INLINE (>>=) #-} - -instance Distributive Plucker where - distribute f = Plucker (fmap (\(Plucker x _ _ _ _ _) -> x) f) - (fmap (\(Plucker _ x _ _ _ _) -> x) f) - (fmap (\(Plucker _ _ x _ _ _) -> x) f) - (fmap (\(Plucker _ _ _ x _ _) -> x) f) - (fmap (\(Plucker _ _ _ _ x _) -> x) f) - (fmap (\(Plucker _ _ _ _ _ x) -> x) f) - {-# INLINE distribute #-} - -instance Representable Plucker where - type Rep Plucker = E Plucker - tabulate f = Plucker (f e01) (f e02) (f e03) (f e23) (f e31) (f e12) - {-# INLINE tabulate #-} - index xs (E l) = view l xs - {-# INLINE index #-} - -instance Foldable Plucker where - foldMap g (Plucker a b c d e f) = - g a `mappend` g b `mappend` g c `mappend` g d `mappend` g e `mappend` g f - {-# INLINE foldMap #-} - null _ = False - length _ = 6 - -instance Traversable Plucker where - traverse g (Plucker a b c d e f) = - Plucker <$> g a <*> g b <*> g c <*> g d <*> g e <*> g f - {-# INLINE traverse #-} - -instance Foldable1 Plucker where - foldMap1 g (Plucker a b c d e f) = - g a <> g b <> g c <> g d <> g e <> g f - {-# INLINE foldMap1 #-} - -instance Traversable1 Plucker where - traverse1 g (Plucker a b c d e f) = - Plucker <$> g a <.> g b <.> g c <.> g d <.> g e <.> g f - {-# INLINE traverse1 #-} - -instance Ix a => Ix (Plucker a) where - range (Plucker l1 l2 l3 l4 l5 l6,Plucker u1 u2 u3 u4 u5 u6) = - [Plucker i1 i2 i3 i4 i5 i6 | i1 <- range (l1,u1) - , i2 <- range (l2,u2) - , i3 <- range (l3,u3) - , i4 <- range (l4,u4) - , i5 <- range (l5,u5) - , i6 <- range (l6,u6) - ] - {-# INLINE range #-} - - unsafeIndex (Plucker l1 l2 l3 l4 l5 l6,Plucker u1 u2 u3 u4 u5 u6) (Plucker i1 i2 i3 i4 i5 i6) = - unsafeIndex (l6,u6) i6 + unsafeRangeSize (l6,u6) * ( - unsafeIndex (l5,u5) i5 + unsafeRangeSize (l5,u5) * ( - unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * ( - unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * ( - unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * - unsafeIndex (l1,u1) i1)))) - {-# INLINE unsafeIndex #-} - - inRange (Plucker l1 l2 l3 l4 l5 l6,Plucker u1 u2 u3 u4 u5 u6) (Plucker i1 i2 i3 i4 i5 i6) = - inRange (l1,u1) i1 && inRange (l2,u2) i2 && - inRange (l3,u3) i3 && inRange (l4,u4) i4 && - inRange (l5,u5) i5 && inRange (l6,u6) i6 - {-# INLINE inRange #-} - -instance Num a => Num (Plucker a) where - (+) = liftA2 (+) - {-# INLINE (+) #-} - (-) = liftA2 (-) - {-# INLINE (-) #-} - (*) = liftA2 (*) - {-# INLINE (*) #-} - negate = fmap negate - {-# INLINE negate #-} - abs = fmap abs - {-# INLINE abs #-} - signum = fmap signum - {-# INLINE signum #-} - fromInteger = pure . fromInteger - {-# INLINE fromInteger #-} - -instance Fractional a => Fractional (Plucker a) where - recip = fmap recip - {-# INLINE recip #-} - (/) = liftA2 (/) - {-# INLINE (/) #-} - fromRational = pure . fromRational - {-# INLINE fromRational #-} - -instance Floating a => Floating (Plucker a) where - pi = pure pi - {-# INLINE pi #-} - exp = fmap exp - {-# INLINE exp #-} - sqrt = fmap sqrt - {-# INLINE sqrt #-} - log = fmap log - {-# INLINE log #-} - (**) = liftA2 (**) - {-# INLINE (**) #-} - logBase = liftA2 logBase - {-# INLINE logBase #-} - sin = fmap sin - {-# INLINE sin #-} - tan = fmap tan - {-# INLINE tan #-} - cos = fmap cos - {-# INLINE cos #-} - asin = fmap asin - {-# INLINE asin #-} - atan = fmap atan - {-# INLINE atan #-} - acos = fmap acos - {-# INLINE acos #-} - sinh = fmap sinh - {-# INLINE sinh #-} - tanh = fmap tanh - {-# INLINE tanh #-} - cosh = fmap cosh - {-# INLINE cosh #-} - asinh = fmap asinh - {-# INLINE asinh #-} - atanh = fmap atanh - {-# INLINE atanh #-} - acosh = fmap acosh - {-# INLINE acosh #-} - -instance Hashable a => Hashable (Plucker a) where - hashWithSalt s (Plucker a b c d e f) = s `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c `hashWithSalt` d `hashWithSalt` e `hashWithSalt` f - {-# INLINE hashWithSalt #-} - -instance Storable a => Storable (Plucker a) where - sizeOf _ = 6 * sizeOf (undefined::a) - {-# INLINE sizeOf #-} - alignment _ = alignment (undefined::a) - {-# INLINE alignment #-} - poke ptr (Plucker a b c d e f) = do - poke ptr' a - pokeElemOff ptr' 1 b - pokeElemOff ptr' 2 c - pokeElemOff ptr' 3 d - pokeElemOff ptr' 4 e - pokeElemOff ptr' 5 f - where ptr' = castPtr ptr - {-# INLINE poke #-} - peek ptr = Plucker <$> peek ptr' - <*> peekElemOff ptr' 1 - <*> peekElemOff ptr' 2 - <*> peekElemOff ptr' 3 - <*> peekElemOff ptr' 4 - <*> peekElemOff ptr' 5 - where ptr' = castPtr ptr - {-# INLINE peek #-} - -instance Metric Plucker where - dot (Plucker a b c d e f) (Plucker g h i j k l) = a*g+b*h+c*i+d*j+e*k+f*l - {-# INLINE dot #-} - -instance Epsilon a => Epsilon (Plucker a) where - nearZero = nearZero . quadrance - {-# INLINE nearZero #-} - --- | Given a pair of points represented by homogeneous coordinates --- generate Plücker coordinates for the line through them, directed --- from the second towards the first. -plucker :: Num a => V4 a -> V4 a -> Plucker a -plucker (V4 a b c d) - (V4 e f g h) = - Plucker (a*f-b*e) - (a*g-c*e) - (b*g-c*f) - (a*h-d*e) - (b*h-d*f) - (c*h-d*g) -{-# INLINE plucker #-} - --- | Given a pair of 3D points, generate Plücker coordinates for the --- line through them, directed from the second towards the first. -plucker3D :: Num a => V3 a -> V3 a -> Plucker a -plucker3D p q = Plucker a b c d e f - where V3 a b c = p - q - V3 d e f = p `cross` q - --- | These elements form a basis for the Plücker space, or the Grassmanian manifold @Gr(2,V4)@. --- --- @ --- 'p01' :: 'Lens'' ('Plucker' a) a --- 'p02' :: 'Lens'' ('Plucker' a) a --- 'p03' :: 'Lens'' ('Plucker' a) a --- 'p23' :: 'Lens'' ('Plucker' a) a --- 'p31' :: 'Lens'' ('Plucker' a) a --- 'p12' :: 'Lens'' ('Plucker' a) a --- @ -p01, p02, p03, p23, p31, p12 :: Lens' (Plucker a) a -p01 g (Plucker a b c d e f) = (\a' -> Plucker a' b c d e f) <$> g a -p02 g (Plucker a b c d e f) = (\b' -> Plucker a b' c d e f) <$> g b -p03 g (Plucker a b c d e f) = (\c' -> Plucker a b c' d e f) <$> g c -p23 g (Plucker a b c d e f) = (\d' -> Plucker a b c d' e f) <$> g d -p31 g (Plucker a b c d e f) = (\e' -> Plucker a b c d e' f) <$> g e -p12 g (Plucker a b c d e f) = Plucker a b c d e <$> g f -{-# INLINE p01 #-} -{-# INLINE p02 #-} -{-# INLINE p03 #-} -{-# INLINE p23 #-} -{-# INLINE p31 #-} -{-# INLINE p12 #-} - --- | These elements form an alternate basis for the Plücker space, or the Grassmanian manifold @Gr(2,V4)@. --- --- @ --- 'p10' :: 'Num' a => 'Lens'' ('Plucker' a) a --- 'p20' :: 'Num' a => 'Lens'' ('Plucker' a) a --- 'p30' :: 'Num' a => 'Lens'' ('Plucker' a) a --- 'p32' :: 'Num' a => 'Lens'' ('Plucker' a) a --- 'p13' :: 'Num' a => 'Lens'' ('Plucker' a) a --- 'p21' :: 'Num' a => 'Lens'' ('Plucker' a) a --- @ -p10, p20, p30, p32, p13, p21 :: (Functor f, Num a) => (a -> f a) -> Plucker a -> f (Plucker a) -p10 = anti p01 -p20 = anti p02 -p30 = anti p03 -p32 = anti p23 -p13 = anti p31 -p21 = anti p21 -{-# INLINE p10 #-} -{-# INLINE p20 #-} -{-# INLINE p30 #-} -{-# INLINE p32 #-} -{-# INLINE p13 #-} -{-# INLINE p21 #-} - -anti :: (Functor f, Num a) => ((a -> f a) -> r) -> (a -> f a) -> r -anti k f = k (fmap negate . f . negate) - -e01, e02, e03, e23, e31, e12 :: E Plucker -e01 = E p01 -e02 = E p02 -e03 = E p03 -e23 = E p23 -e31 = E p31 -e12 = E p12 - -instance WithIndex.FunctorWithIndex (E Plucker) Plucker where - imap f (Plucker a b c d e g) = Plucker (f e01 a) (f e02 b) (f e03 c) (f e23 d) (f e31 e) (f e12 g) - {-# INLINE imap #-} - -instance WithIndex.FoldableWithIndex (E Plucker) Plucker where - ifoldMap f (Plucker a b c d e g) = f e01 a `mappend` f e02 b `mappend` f e03 c - `mappend` f e23 d `mappend` f e31 e `mappend` f e12 g - {-# INLINE ifoldMap #-} - -instance WithIndex.TraversableWithIndex (E Plucker) Plucker where - itraverse f (Plucker a b c d e g) = Plucker <$> f e01 a <*> f e02 b <*> f e03 c - <*> f e23 d <*> f e31 e <*> f e12 g - {-# INLINE itraverse #-} - -#if !MIN_VERSION_lens(5,0,0) -instance Lens.FunctorWithIndex (E Plucker) Plucker where imap = WithIndex.imap -instance Lens.FoldableWithIndex (E Plucker) Plucker where ifoldMap = WithIndex.ifoldMap -instance Lens.TraversableWithIndex (E Plucker) Plucker where itraverse = WithIndex.itraverse -#endif - -type instance Index (Plucker a) = E Plucker -type instance IxValue (Plucker a) = a - -instance Ixed (Plucker a) where - ix i = el i - {-# INLINE ix #-} - -instance Each (Plucker a) (Plucker b) a b where - each = traverse - {-# INLINE each #-} - - --- | Valid Plücker coordinates @p@ will have @'squaredError' p '==' 0@ --- --- That said, floating point makes a mockery of this claim, so you may want to use 'nearZero'. -squaredError :: Num a => Plucker a -> a -squaredError v = v >< v -{-# INLINE squaredError #-} - --- | This isn't th actual metric because this bilinear form gives rise to an isotropic quadratic space -infixl 5 >< -(><) :: Num a => Plucker a -> Plucker a -> a -Plucker a b c d e f >< Plucker g h i j k l = a*l-b*k+c*j+d*i-e*h+f*g -{-# INLINE (><) #-} - --- | Checks if the line is near-isotropic (isotropic vectors in this --- quadratic space represent lines in real 3d space). -isotropic :: Epsilon a => Plucker a -> Bool -isotropic a = nearZero (a >< a) -{-# INLINE isotropic #-} - --- | Checks if two lines intersect (or nearly intersect). -intersects :: (Epsilon a, Ord a) => Plucker a -> Plucker a -> Bool -intersects a b = not (a `parallel` b) && passes a b == Coplanar --- intersects :: Epsilon a => Plucker a -> Plucker a -> Bool --- intersects a b = nearZero (a >< b) -{-# INLINE intersects #-} - --- | Describe how two lines pass each other. -data LinePass = Coplanar - -- ^ The lines are coplanar (parallel or intersecting). - | Clockwise - -- ^ The lines pass each other clockwise (right-handed - -- screw) - | Counterclockwise - -- ^ The lines pass each other counterclockwise - -- (left-handed screw). - deriving (Eq, Show,Generic) - --- | Check how two lines pass each other. @passes l1 l2@ describes --- @l2@ when looking down @l1@. -passes :: (Epsilon a, Ord a) => Plucker a -> Plucker a -> LinePass -passes a b - | nearZero s = Coplanar - | s > 0 = Counterclockwise - | otherwise = Clockwise - where s = (u1 `dot` v2) + (u2 `dot` v1) - V2 u1 v1 = toUV a - V2 u2 v2 = toUV b -{-# INLINE passes #-} - --- | Checks if two lines are parallel. -parallel :: Epsilon a => Plucker a -> Plucker a -> Bool -parallel a b = nearZero $ u1 `cross` u2 - where V2 u1 _ = toUV a - V2 u2 _ = toUV b -{-# INLINE parallel #-} - --- | Represent a Plücker coordinate as a pair of 3-tuples, typically --- denoted U and V. -toUV :: Plucker a -> V2 (V3 a) -toUV (Plucker a b c d e f) = V2 (V3 a b c) (V3 d e f) - --- | Checks if two lines coincide in space. In other words, undirected equality. -coincides :: (Epsilon a, Fractional a) => Plucker a -> Plucker a -> Bool -coincides p1 p2 = Foldable.all nearZero $ (s *^ p2) - p1 - where s = maybe 1 getFirst . getOptionCompat . fold $ saveDiv <$> p1 <*> p2 - saveDiv x y | nearZero y = optionCompat Nothing - | otherwise = optionCompat . Just $ First (x / y) -{-# INLINABLE coincides #-} - --- | Checks if two lines coincide in space, and have the same --- orientation. -coincides' :: (Epsilon a, Fractional a, Ord a) => Plucker a -> Plucker a -> Bool -coincides' p1 p2 = Foldable.all nearZero ((s *^ p2) - p1) && s > 0 - where s = maybe 1 getFirst . getOptionCompat . fold $ saveDiv <$> p1 <*> p2 - saveDiv x y | nearZero y = optionCompat Nothing - | otherwise = optionCompat . Just $ First (x / y) -{-# INLINABLE coincides' #-} - --- The coincides and coincides' functions above require the use of a Maybe type --- with the following Monoid instance: --- --- instance Semigroup a => Monoid (Maybe a) where ... --- --- Unfortunately, Maybe has only had such an instance since base-4.11. Prior --- to that, its Monoid instance had an instance context of Monoid a, which is --- too strong. To compensate, we use CPP to define an OptionCompat type --- synonym, which is an alias for Maybe on recent versions of base and an alias --- for Data.Semigroup.Option on older versions of base. We don't want to use --- Option on recent versions of base, as it is deprecated. -#if MIN_VERSION_base(4,11,0) -type OptionCompat = Maybe - -optionCompat :: Maybe a -> OptionCompat a -optionCompat = id - -getOptionCompat :: OptionCompat a -> Maybe a -getOptionCompat = id -#else -type OptionCompat = Option - -optionCompat :: Maybe a -> OptionCompat a -optionCompat = Option - -getOptionCompat :: OptionCompat a -> Maybe a -getOptionCompat = getOption -#endif - --- | The minimum squared distance of a line from the origin. -quadranceToOrigin :: Fractional a => Plucker a -> a -quadranceToOrigin p = (v `dot` v) / (u `dot` u) - where V2 u v = toUV p -{-# INLINE quadranceToOrigin #-} - --- | The point where a line is closest to the origin. -closestToOrigin :: Fractional a => Plucker a -> V3 a -closestToOrigin p = normalizePoint $ V4 x y z (u `dot` u) - where V2 u v = toUV p - V3 x y z = v `cross` u -{-# INLINE closestToOrigin #-} - --- | Not all 6-dimensional points correspond to a line in 3D. This --- predicate tests that a Plücker coordinate lies on the Grassmann --- manifold, and does indeed represent a 3D line. -isLine :: Epsilon a => Plucker a -> Bool -isLine p = nearZero $ u `dot` v - where V2 u v = toUV p -{-# INLINE isLine #-} - --- TODO: drag some more stuff out of my thesis - -data instance U.Vector (Plucker a) = V_Plucker !Int (U.Vector a) -data instance U.MVector s (Plucker a) = MV_Plucker !Int (U.MVector s a) -instance U.Unbox a => U.Unbox (Plucker a) - -instance U.Unbox a => M.MVector U.MVector (Plucker a) where - basicLength (MV_Plucker n _) = n - basicUnsafeSlice m n (MV_Plucker _ v) = MV_Plucker n (M.basicUnsafeSlice (6*m) (6*n) v) - basicOverlaps (MV_Plucker _ v) (MV_Plucker _ u) = M.basicOverlaps v u - basicUnsafeNew n = liftM (MV_Plucker n) (M.basicUnsafeNew (6*n)) - basicUnsafeRead (MV_Plucker _ a) i = - do let o = 6*i - x <- M.basicUnsafeRead a o - y <- M.basicUnsafeRead a (o+1) - z <- M.basicUnsafeRead a (o+2) - w <- M.basicUnsafeRead a (o+3) - v <- M.basicUnsafeRead a (o+4) - u <- M.basicUnsafeRead a (o+5) - return (Plucker x y z w v u) - basicUnsafeWrite (MV_Plucker _ a) i (Plucker x y z w v u) = - do let o = 6*i - M.basicUnsafeWrite a o x - M.basicUnsafeWrite a (o+1) y - M.basicUnsafeWrite a (o+2) z - M.basicUnsafeWrite a (o+3) w - M.basicUnsafeWrite a (o+4) v - M.basicUnsafeWrite a (o+5) u - basicInitialize (MV_Plucker _ v) = M.basicInitialize v - -instance U.Unbox a => G.Vector U.Vector (Plucker a) where - basicUnsafeFreeze (MV_Plucker n v) = liftM ( V_Plucker n) (G.basicUnsafeFreeze v) - basicUnsafeThaw ( V_Plucker n v) = liftM (MV_Plucker n) (G.basicUnsafeThaw v) - basicLength ( V_Plucker n _) = n - basicUnsafeSlice m n (V_Plucker _ v) = V_Plucker n (G.basicUnsafeSlice (6*m) (6*n) v) - basicUnsafeIndexM (V_Plucker _ a) i = - do let o = 6*i - x <- G.basicUnsafeIndexM a o - y <- G.basicUnsafeIndexM a (o+1) - z <- G.basicUnsafeIndexM a (o+2) - w <- G.basicUnsafeIndexM a (o+3) - v <- G.basicUnsafeIndexM a (o+4) - u <- G.basicUnsafeIndexM a (o+5) - return (Plucker x y z w v u) - -instance MonadZip Plucker where - mzipWith = liftA2 - -instance MonadFix Plucker where - mfix f = Plucker (let Plucker a _ _ _ _ _ = f a in a) - (let Plucker _ a _ _ _ _ = f a in a) - (let Plucker _ _ a _ _ _ = f a in a) - (let Plucker _ _ _ a _ _ = f a in a) - (let Plucker _ _ _ _ a _ = f a in a) - (let Plucker _ _ _ _ _ a = f a in a) - -instance NFData a => NFData (Plucker a) where - rnf (Plucker a b c d e f) = rnf a `seq` rnf b `seq` rnf c - `seq` rnf d `seq` rnf e `seq` rnf f - -instance Serial1 Plucker where - serializeWith = traverse_ - deserializeWith k = Plucker <$> k <*> k <*> k <*> k <*> k <*> k - -instance Serial a => Serial (Plucker a) where - serialize = serializeWith serialize - deserialize = deserializeWith deserialize - -instance Binary a => Binary (Plucker a) where - put = serializeWith Binary.put - get = deserializeWith Binary.get - -instance Serialize a => Serialize (Plucker a) where - put = serializeWith Cereal.put - get = deserializeWith Cereal.get - -instance Eq1 Plucker where - liftEq k (Plucker a1 b1 c1 d1 e1 f1) - (Plucker a2 b2 c2 d2 e2 f2) - = k a1 a2 && k b1 b2 && k c1 c2 && k d1 d2 && k e1 e2 && k f1 f2 -instance Ord1 Plucker where - liftCompare k (Plucker a1 b1 c1 d1 e1 f1) - (Plucker a2 b2 c2 d2 e2 f2) - = k a1 a2 `mappend` k b1 b2 `mappend` k c1 c2 `mappend` k d1 d2 `mappend` k e1 e2 `mappend` k f1 f2 -instance Read1 Plucker where - liftReadsPrec k _ z = readParen (z > 10) $ \r -> - [ (Plucker a b c d e f, r7) - | ("Plucker",r1) <- lex r - , (a,r2) <- k 11 r1 - , (b,r3) <- k 11 r2 - , (c,r4) <- k 11 r3 - , (d,r5) <- k 11 r4 - , (e,r6) <- k 11 r5 - , (f,r7) <- k 11 r6 - ] -instance Show1 Plucker where - liftShowsPrec k _ z (Plucker a b c d e f) = showParen (z > 10) $ - showString "Plucker " . k 11 a . showChar ' ' . k 11 b . showChar ' ' . k 11 c . showChar ' ' . k 11 d . showChar ' ' . k 11 e . showChar ' ' . k 11 f - -instance Field1 (Plucker a) (Plucker a) a a where - _1 f (Plucker x y z u v w) = f x <&> \x' -> Plucker x' y z u v w - -instance Field2 (Plucker a) (Plucker a) a a where - _2 f (Plucker x y z u v w) = f y <&> \y' -> Plucker x y' z u v w - -instance Field3 (Plucker a) (Plucker a) a a where - _3 f (Plucker x y z u v w) = f z <&> \z' -> Plucker x y z' u v w - -instance Field4 (Plucker a) (Plucker a) a a where - _4 f (Plucker x y z u v w) = f u <&> \u' -> Plucker x y z u' v w - -instance Field5 (Plucker a) (Plucker a) a a where - _5 f (Plucker x y z u v w) = f v <&> \v' -> Plucker x y z u v' w - -instance Field6 (Plucker a) (Plucker a) a a where - _6 f (Plucker x y z u v w) = f w <&> \w' -> Plucker x y z u v w' - -instance Semigroup a => Semigroup (Plucker a) where - (<>) = liftA2 (<>) - -instance Monoid a => Monoid (Plucker a) where - mempty = pure mempty -#if !(MIN_VERSION_base(4,11,0)) - mappend = liftA2 mappend -#endif +{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveLift #-}++#ifndef MIN_VERSION_vector+#define MIN_VERSION_vector(x,y,z) 1+#endif++#ifndef MIN_VERSION_transformers+#define MIN_VERSION_transformers(x,y,z) 1+#endif+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2012-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- Plücker coordinates for lines in 3d homogeneous space.+----------------------------------------------------------------------------+module Linear.Plucker+ ( Plucker(..)+ , squaredError+ , isotropic+ , (><)+ , plucker+ , plucker3D+ -- * Operations on lines+ , parallel+ , intersects+ , LinePass(..)+ , passes+ , quadranceToOrigin+ , closestToOrigin+ , isLine+ , coincides+ , coincides'+ -- * Basis elements+ , p01, p02, p03+ , p10, p12, p13+ , p20, p21, p23+ , p30, p31, p32++ , e01, e02, e03, e12, e31, e23+ ) where++#if !MIN_VERSION_base(4,18,0)+import Control.Applicative+#endif+import Control.DeepSeq (NFData(rnf))+import Control.Monad (liftM)+import Control.Monad.Fix+import Control.Monad.Zip+import Control.Lens as Lens hiding (index, (<.>))+import Data.Binary as Binary+import Data.Bytes.Serial+import Data.Distributive+import Data.Foldable as Foldable+import qualified Data.Foldable.WithIndex as WithIndex+import Data.Functor.Bind+import Data.Functor.Classes+import Data.Functor.Rep+import qualified Data.Functor.WithIndex as WithIndex+import Data.Hashable+import Data.Semigroup+import Data.Semigroup.Foldable+import Data.Serialize as Cereal+import qualified Data.Traversable.WithIndex as WithIndex+import qualified Data.Vector as V+import qualified Data.Vector.Generic.Mutable as M+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Unboxed.Base as U+import Foreign.Ptr (castPtr)+import Foreign.Storable (Storable(..))+import GHC.Arr (Ix(..))+import GHC.Generics (Generic, Generic1)+#if defined(MIN_VERSION_template_haskell)+import Language.Haskell.TH.Syntax (Lift)+#endif+import Linear.Epsilon+import Linear.Metric+import Linear.V+import Linear.V2+import Linear.V3+import Linear.V4+import Linear.Vector+import System.Random (Random(..))++-- | Plücker coordinates for lines in a 3-dimensional space.+data Plucker a = Plucker !a !a !a !a !a !a deriving (Eq,Ord,Show,Read+ ,Generic,Generic1+#if defined(MIN_VERSION_template_haskell)+ ,Lift+#endif+ )++instance Finite Plucker where+ type Size Plucker = 6+ toV (Plucker a b c d e f) = V (V.fromListN 6 [a,b,c,d,e,f])+ fromV (V v) = Plucker (v V.! 0) (v V.! 1) (v V.! 2) (v V.! 3) (v V.! 4) (v V.! 5)++instance Random a => Random (Plucker a) where+ random g = case random g of+ (a, g1) -> case random g1 of+ (b, g2) -> case random g2 of+ (c, g3) -> case random g3 of+ (d, g4) -> case random g4 of+ (e, g5) -> case random g5 of+ (f, g6) -> (Plucker a b c d e f, g6)+ randomR (Plucker a b c d e f, Plucker a' b' c' d' e' f') g = case randomR (a,a') g of+ (a'', g1) -> case randomR (b,b') g1 of+ (b'', g2) -> case randomR (c,c') g2 of+ (c'', g3) -> case randomR (d,d') g3 of+ (d'', g4) -> case randomR (e,e') g4 of+ (e'', g5) -> case randomR (f,f') g5 of+ (f'', g6) -> (Plucker a'' b'' c'' d'' e'' f'', g6)++instance Functor Plucker where+ fmap g (Plucker a b c d e f) = Plucker (g a) (g b) (g c) (g d) (g e) (g f)+ {-# INLINE fmap #-}++instance Apply Plucker where+ Plucker a b c d e f <.> Plucker g h i j k l =+ Plucker (a g) (b h) (c i) (d j) (e k) (f l)+ {-# INLINE (<.>) #-}++instance Applicative Plucker where+ pure a = Plucker a a a a a a+ {-# INLINE pure #-}+ Plucker a b c d e f <*> Plucker g h i j k l =+ Plucker (a g) (b h) (c i) (d j) (e k) (f l)+ {-# INLINE (<*>) #-}++instance Additive Plucker where+ zero = pure 0+ {-# INLINE zero #-}+ liftU2 = liftA2+ {-# INLINE liftU2 #-}+ liftI2 = liftA2+ {-# INLINE liftI2 #-}++instance Bind Plucker where+ Plucker a b c d e f >>- g = Plucker a' b' c' d' e' f' where+ Plucker a' _ _ _ _ _ = g a+ Plucker _ b' _ _ _ _ = g b+ Plucker _ _ c' _ _ _ = g c+ Plucker _ _ _ d' _ _ = g d+ Plucker _ _ _ _ e' _ = g e+ Plucker _ _ _ _ _ f' = g f+ {-# INLINE (>>-) #-}++instance Monad Plucker where+#if !(MIN_VERSION_base(4,11,0))+ return a = Plucker a a a a a a+ {-# INLINE return #-}+#endif+ Plucker a b c d e f >>= g = Plucker a' b' c' d' e' f' where+ Plucker a' _ _ _ _ _ = g a+ Plucker _ b' _ _ _ _ = g b+ Plucker _ _ c' _ _ _ = g c+ Plucker _ _ _ d' _ _ = g d+ Plucker _ _ _ _ e' _ = g e+ Plucker _ _ _ _ _ f' = g f+ {-# INLINE (>>=) #-}++instance Distributive Plucker where+ distribute f = Plucker (fmap (\(Plucker x _ _ _ _ _) -> x) f)+ (fmap (\(Plucker _ x _ _ _ _) -> x) f)+ (fmap (\(Plucker _ _ x _ _ _) -> x) f)+ (fmap (\(Plucker _ _ _ x _ _) -> x) f)+ (fmap (\(Plucker _ _ _ _ x _) -> x) f)+ (fmap (\(Plucker _ _ _ _ _ x) -> x) f)+ {-# INLINE distribute #-}++instance Representable Plucker where+ type Rep Plucker = E Plucker+ tabulate f = Plucker (f e01) (f e02) (f e03) (f e23) (f e31) (f e12)+ {-# INLINE tabulate #-}+ index xs (E l) = view l xs+ {-# INLINE index #-}++instance Foldable Plucker where+ foldMap g (Plucker a b c d e f) =+ g a `mappend` g b `mappend` g c `mappend` g d `mappend` g e `mappend` g f+ {-# INLINE foldMap #-}+ null _ = False+ length _ = 6++instance Traversable Plucker where+ traverse g (Plucker a b c d e f) =+ Plucker <$> g a <*> g b <*> g c <*> g d <*> g e <*> g f+ {-# INLINE traverse #-}++instance Foldable1 Plucker where+ foldMap1 g (Plucker a b c d e f) =+ g a <> g b <> g c <> g d <> g e <> g f+ {-# INLINE foldMap1 #-}++instance Traversable1 Plucker where+ traverse1 g (Plucker a b c d e f) =+ Plucker <$> g a <.> g b <.> g c <.> g d <.> g e <.> g f+ {-# INLINE traverse1 #-}++instance Ix a => Ix (Plucker a) where+ range (Plucker l1 l2 l3 l4 l5 l6,Plucker u1 u2 u3 u4 u5 u6) =+ [Plucker i1 i2 i3 i4 i5 i6 | i1 <- range (l1,u1)+ , i2 <- range (l2,u2)+ , i3 <- range (l3,u3)+ , i4 <- range (l4,u4)+ , i5 <- range (l5,u5)+ , i6 <- range (l6,u6)+ ]+ {-# INLINE range #-}++ unsafeIndex (Plucker l1 l2 l3 l4 l5 l6,Plucker u1 u2 u3 u4 u5 u6) (Plucker i1 i2 i3 i4 i5 i6) =+ unsafeIndex (l6,u6) i6 + unsafeRangeSize (l6,u6) * (+ unsafeIndex (l5,u5) i5 + unsafeRangeSize (l5,u5) * (+ unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * (+ unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * (+ unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) *+ unsafeIndex (l1,u1) i1))))+ {-# INLINE unsafeIndex #-}++ inRange (Plucker l1 l2 l3 l4 l5 l6,Plucker u1 u2 u3 u4 u5 u6) (Plucker i1 i2 i3 i4 i5 i6) =+ inRange (l1,u1) i1 && inRange (l2,u2) i2 &&+ inRange (l3,u3) i3 && inRange (l4,u4) i4 &&+ inRange (l5,u5) i5 && inRange (l6,u6) i6+ {-# INLINE inRange #-}++instance Num a => Num (Plucker a) where+ (+) = liftA2 (+)+ {-# INLINE (+) #-}+ (-) = liftA2 (-)+ {-# INLINE (-) #-}+ (*) = liftA2 (*)+ {-# INLINE (*) #-}+ negate = fmap negate+ {-# INLINE negate #-}+ abs = fmap abs+ {-# INLINE abs #-}+ signum = fmap signum+ {-# INLINE signum #-}+ fromInteger = pure . fromInteger+ {-# INLINE fromInteger #-}++instance Fractional a => Fractional (Plucker a) where+ recip = fmap recip+ {-# INLINE recip #-}+ (/) = liftA2 (/)+ {-# INLINE (/) #-}+ fromRational = pure . fromRational+ {-# INLINE fromRational #-}++instance Floating a => Floating (Plucker a) where+ pi = pure pi+ {-# INLINE pi #-}+ exp = fmap exp+ {-# INLINE exp #-}+ sqrt = fmap sqrt+ {-# INLINE sqrt #-}+ log = fmap log+ {-# INLINE log #-}+ (**) = liftA2 (**)+ {-# INLINE (**) #-}+ logBase = liftA2 logBase+ {-# INLINE logBase #-}+ sin = fmap sin+ {-# INLINE sin #-}+ tan = fmap tan+ {-# INLINE tan #-}+ cos = fmap cos+ {-# INLINE cos #-}+ asin = fmap asin+ {-# INLINE asin #-}+ atan = fmap atan+ {-# INLINE atan #-}+ acos = fmap acos+ {-# INLINE acos #-}+ sinh = fmap sinh+ {-# INLINE sinh #-}+ tanh = fmap tanh+ {-# INLINE tanh #-}+ cosh = fmap cosh+ {-# INLINE cosh #-}+ asinh = fmap asinh+ {-# INLINE asinh #-}+ atanh = fmap atanh+ {-# INLINE atanh #-}+ acosh = fmap acosh+ {-# INLINE acosh #-}++instance Hashable a => Hashable (Plucker a) where+ hashWithSalt s (Plucker a b c d e f) = s `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c `hashWithSalt` d `hashWithSalt` e `hashWithSalt` f+ {-# INLINE hashWithSalt #-}++instance Storable a => Storable (Plucker a) where+ sizeOf _ = 6 * sizeOf (undefined::a)+ {-# INLINE sizeOf #-}+ alignment _ = alignment (undefined::a)+ {-# INLINE alignment #-}+ poke ptr (Plucker a b c d e f) = do+ poke ptr' a+ pokeElemOff ptr' 1 b+ pokeElemOff ptr' 2 c+ pokeElemOff ptr' 3 d+ pokeElemOff ptr' 4 e+ pokeElemOff ptr' 5 f+ where ptr' = castPtr ptr+ {-# INLINE poke #-}+ peek ptr = Plucker <$> peek ptr'+ <*> peekElemOff ptr' 1+ <*> peekElemOff ptr' 2+ <*> peekElemOff ptr' 3+ <*> peekElemOff ptr' 4+ <*> peekElemOff ptr' 5+ where ptr' = castPtr ptr+ {-# INLINE peek #-}++instance Metric Plucker where+ dot (Plucker a b c d e f) (Plucker g h i j k l) = a*g+b*h+c*i+d*j+e*k+f*l+ {-# INLINE dot #-}++instance Epsilon a => Epsilon (Plucker a) where+ nearZero = nearZero . quadrance+ {-# INLINE nearZero #-}++-- | Given a pair of points represented by homogeneous coordinates+-- generate Plücker coordinates for the line through them, directed+-- from the second towards the first.+plucker :: Num a => V4 a -> V4 a -> Plucker a+plucker (V4 a b c d)+ (V4 e f g h) =+ Plucker (a*f-b*e)+ (a*g-c*e)+ (b*g-c*f)+ (a*h-d*e)+ (b*h-d*f)+ (c*h-d*g)+{-# INLINE plucker #-}++-- | Given a pair of 3D points, generate Plücker coordinates for the+-- line through them, directed from the second towards the first.+plucker3D :: Num a => V3 a -> V3 a -> Plucker a+plucker3D p q = Plucker a b c d e f+ where V3 a b c = p - q+ V3 d e f = p `cross` q++-- | These elements form a basis for the Plücker space, or the Grassmanian manifold @Gr(2,V4)@.+--+-- @+-- 'p01' :: 'Lens'' ('Plucker' a) a+-- 'p02' :: 'Lens'' ('Plucker' a) a+-- 'p03' :: 'Lens'' ('Plucker' a) a+-- 'p23' :: 'Lens'' ('Plucker' a) a+-- 'p31' :: 'Lens'' ('Plucker' a) a+-- 'p12' :: 'Lens'' ('Plucker' a) a+-- @+p01, p02, p03, p23, p31, p12 :: Lens' (Plucker a) a+p01 g (Plucker a b c d e f) = (\a' -> Plucker a' b c d e f) <$> g a+p02 g (Plucker a b c d e f) = (\b' -> Plucker a b' c d e f) <$> g b+p03 g (Plucker a b c d e f) = (\c' -> Plucker a b c' d e f) <$> g c+p23 g (Plucker a b c d e f) = (\d' -> Plucker a b c d' e f) <$> g d+p31 g (Plucker a b c d e f) = (\e' -> Plucker a b c d e' f) <$> g e+p12 g (Plucker a b c d e f) = Plucker a b c d e <$> g f+{-# INLINE p01 #-}+{-# INLINE p02 #-}+{-# INLINE p03 #-}+{-# INLINE p23 #-}+{-# INLINE p31 #-}+{-# INLINE p12 #-}++-- | These elements form an alternate basis for the Plücker space, or the Grassmanian manifold @Gr(2,V4)@.+--+-- @+-- 'p10' :: 'Num' a => 'Lens'' ('Plucker' a) a+-- 'p20' :: 'Num' a => 'Lens'' ('Plucker' a) a+-- 'p30' :: 'Num' a => 'Lens'' ('Plucker' a) a+-- 'p32' :: 'Num' a => 'Lens'' ('Plucker' a) a+-- 'p13' :: 'Num' a => 'Lens'' ('Plucker' a) a+-- 'p21' :: 'Num' a => 'Lens'' ('Plucker' a) a+-- @+p10, p20, p30, p32, p13, p21 :: (Functor f, Num a) => (a -> f a) -> Plucker a -> f (Plucker a)+p10 = anti p01+p20 = anti p02+p30 = anti p03+p32 = anti p23+p13 = anti p31+p21 = anti p21+{-# INLINE p10 #-}+{-# INLINE p20 #-}+{-# INLINE p30 #-}+{-# INLINE p32 #-}+{-# INLINE p13 #-}+{-# INLINE p21 #-}++anti :: (Functor f, Num a) => ((a -> f a) -> r) -> (a -> f a) -> r+anti k f = k (fmap negate . f . negate)++e01, e02, e03, e23, e31, e12 :: E Plucker+e01 = E p01+e02 = E p02+e03 = E p03+e23 = E p23+e31 = E p31+e12 = E p12++instance WithIndex.FunctorWithIndex (E Plucker) Plucker where+ imap f (Plucker a b c d e g) = Plucker (f e01 a) (f e02 b) (f e03 c) (f e23 d) (f e31 e) (f e12 g)+ {-# INLINE imap #-}++instance WithIndex.FoldableWithIndex (E Plucker) Plucker where+ ifoldMap f (Plucker a b c d e g) = f e01 a `mappend` f e02 b `mappend` f e03 c+ `mappend` f e23 d `mappend` f e31 e `mappend` f e12 g+ {-# INLINE ifoldMap #-}++instance WithIndex.TraversableWithIndex (E Plucker) Plucker where+ itraverse f (Plucker a b c d e g) = Plucker <$> f e01 a <*> f e02 b <*> f e03 c+ <*> f e23 d <*> f e31 e <*> f e12 g+ {-# INLINE itraverse #-}++#if !MIN_VERSION_lens(5,0,0)+instance Lens.FunctorWithIndex (E Plucker) Plucker where imap = WithIndex.imap+instance Lens.FoldableWithIndex (E Plucker) Plucker where ifoldMap = WithIndex.ifoldMap+instance Lens.TraversableWithIndex (E Plucker) Plucker where itraverse = WithIndex.itraverse+#endif++type instance Index (Plucker a) = E Plucker+type instance IxValue (Plucker a) = a++instance Ixed (Plucker a) where+ ix i = el i+ {-# INLINE ix #-}++instance Each (Plucker a) (Plucker b) a b where+ each = traverse+ {-# INLINE each #-}+++-- | Valid Plücker coordinates @p@ will have @'squaredError' p '==' 0@+--+-- That said, floating point makes a mockery of this claim, so you may want to use 'nearZero'.+squaredError :: Num a => Plucker a -> a+squaredError v = v >< v+{-# INLINE squaredError #-}++-- | This isn't th actual metric because this bilinear form gives rise to an isotropic quadratic space+infixl 5 ><+(><) :: Num a => Plucker a -> Plucker a -> a+Plucker a b c d e f >< Plucker g h i j k l = a*l-b*k+c*j+d*i-e*h+f*g+{-# INLINE (><) #-}++-- | Checks if the line is near-isotropic (isotropic vectors in this+-- quadratic space represent lines in real 3d space).+isotropic :: Epsilon a => Plucker a -> Bool+isotropic a = nearZero (a >< a)+{-# INLINE isotropic #-}++-- | Checks if two lines intersect (or nearly intersect).+intersects :: (Epsilon a, Ord a) => Plucker a -> Plucker a -> Bool+intersects a b = not (a `parallel` b) && passes a b == Coplanar+-- intersects :: Epsilon a => Plucker a -> Plucker a -> Bool+-- intersects a b = nearZero (a >< b)+{-# INLINE intersects #-}++-- | Describe how two lines pass each other.+data LinePass = Coplanar+ -- ^ The lines are coplanar (parallel or intersecting).+ | Clockwise+ -- ^ The lines pass each other clockwise (right-handed+ -- screw)+ | Counterclockwise+ -- ^ The lines pass each other counterclockwise+ -- (left-handed screw).+ deriving (Eq, Show,Generic)++-- | Check how two lines pass each other. @passes l1 l2@ describes+-- @l2@ when looking down @l1@.+passes :: (Epsilon a, Ord a) => Plucker a -> Plucker a -> LinePass+passes a b+ | nearZero s = Coplanar+ | s > 0 = Counterclockwise+ | otherwise = Clockwise+ where s = (u1 `dot` v2) + (u2 `dot` v1)+ V2 u1 v1 = toUV a+ V2 u2 v2 = toUV b+{-# INLINE passes #-}++-- | Checks if two lines are parallel.+parallel :: Epsilon a => Plucker a -> Plucker a -> Bool+parallel a b = nearZero $ u1 `cross` u2+ where V2 u1 _ = toUV a+ V2 u2 _ = toUV b+{-# INLINE parallel #-}++-- | Represent a Plücker coordinate as a pair of 3-tuples, typically+-- denoted U and V.+toUV :: Plucker a -> V2 (V3 a)+toUV (Plucker a b c d e f) = V2 (V3 a b c) (V3 d e f)++-- | Checks if two lines coincide in space. In other words, undirected equality.+coincides :: (Epsilon a, Fractional a) => Plucker a -> Plucker a -> Bool+coincides p1 p2 = Foldable.all nearZero $ (s *^ p2) - p1+ where s = maybe 1 getFirst . getOptionCompat . fold $ saveDiv <$> p1 <*> p2+ saveDiv x y | nearZero y = optionCompat Nothing+ | otherwise = optionCompat . Just $ First (x / y)+{-# INLINABLE coincides #-}++-- | Checks if two lines coincide in space, and have the same+-- orientation.+coincides' :: (Epsilon a, Fractional a, Ord a) => Plucker a -> Plucker a -> Bool+coincides' p1 p2 = Foldable.all nearZero ((s *^ p2) - p1) && s > 0+ where s = maybe 1 getFirst . getOptionCompat . fold $ saveDiv <$> p1 <*> p2+ saveDiv x y | nearZero y = optionCompat Nothing+ | otherwise = optionCompat . Just $ First (x / y)+{-# INLINABLE coincides' #-}++-- The coincides and coincides' functions above require the use of a Maybe type+-- with the following Monoid instance:+--+-- instance Semigroup a => Monoid (Maybe a) where ...+--+-- Unfortunately, Maybe has only had such an instance since base-4.11. Prior+-- to that, its Monoid instance had an instance context of Monoid a, which is+-- too strong. To compensate, we use CPP to define an OptionCompat type+-- synonym, which is an alias for Maybe on recent versions of base and an alias+-- for Data.Semigroup.Option on older versions of base. We don't want to use+-- Option on recent versions of base, as it is deprecated.+#if MIN_VERSION_base(4,11,0)+type OptionCompat = Maybe++optionCompat :: Maybe a -> OptionCompat a+optionCompat = id++getOptionCompat :: OptionCompat a -> Maybe a+getOptionCompat = id+#else+type OptionCompat = Option++optionCompat :: Maybe a -> OptionCompat a+optionCompat = Option++getOptionCompat :: OptionCompat a -> Maybe a+getOptionCompat = getOption+#endif++-- | The minimum squared distance of a line from the origin.+quadranceToOrigin :: Fractional a => Plucker a -> a+quadranceToOrigin p = (v `dot` v) / (u `dot` u)+ where V2 u v = toUV p+{-# INLINE quadranceToOrigin #-}++-- | The point where a line is closest to the origin.+closestToOrigin :: Fractional a => Plucker a -> V3 a+closestToOrigin p = normalizePoint $ V4 x y z (u `dot` u)+ where V2 u v = toUV p+ V3 x y z = v `cross` u+{-# INLINE closestToOrigin #-}++-- | Not all 6-dimensional points correspond to a line in 3D. This+-- predicate tests that a Plücker coordinate lies on the Grassmann+-- manifold, and does indeed represent a 3D line.+isLine :: Epsilon a => Plucker a -> Bool+isLine p = nearZero $ u `dot` v+ where V2 u v = toUV p+{-# INLINE isLine #-}++-- TODO: drag some more stuff out of my thesis++data instance U.Vector (Plucker a) = V_Plucker !Int (U.Vector a)+data instance U.MVector s (Plucker a) = MV_Plucker !Int (U.MVector s a)+instance U.Unbox a => U.Unbox (Plucker a)++instance U.Unbox a => M.MVector U.MVector (Plucker a) where+ basicLength (MV_Plucker n _) = n+ basicUnsafeSlice m n (MV_Plucker _ v) = MV_Plucker n (M.basicUnsafeSlice (6*m) (6*n) v)+ basicOverlaps (MV_Plucker _ v) (MV_Plucker _ u) = M.basicOverlaps v u+ basicUnsafeNew n = liftM (MV_Plucker n) (M.basicUnsafeNew (6*n))+ basicUnsafeRead (MV_Plucker _ a) i =+ do let o = 6*i+ x <- M.basicUnsafeRead a o+ y <- M.basicUnsafeRead a (o+1)+ z <- M.basicUnsafeRead a (o+2)+ w <- M.basicUnsafeRead a (o+3)+ v <- M.basicUnsafeRead a (o+4)+ u <- M.basicUnsafeRead a (o+5)+ return (Plucker x y z w v u)+ basicUnsafeWrite (MV_Plucker _ a) i (Plucker x y z w v u) =+ do let o = 6*i+ M.basicUnsafeWrite a o x+ M.basicUnsafeWrite a (o+1) y+ M.basicUnsafeWrite a (o+2) z+ M.basicUnsafeWrite a (o+3) w+ M.basicUnsafeWrite a (o+4) v+ M.basicUnsafeWrite a (o+5) u+ basicInitialize (MV_Plucker _ v) = M.basicInitialize v++instance U.Unbox a => G.Vector U.Vector (Plucker a) where+ basicUnsafeFreeze (MV_Plucker n v) = liftM ( V_Plucker n) (G.basicUnsafeFreeze v)+ basicUnsafeThaw ( V_Plucker n v) = liftM (MV_Plucker n) (G.basicUnsafeThaw v)+ basicLength ( V_Plucker n _) = n+ basicUnsafeSlice m n (V_Plucker _ v) = V_Plucker n (G.basicUnsafeSlice (6*m) (6*n) v)+ basicUnsafeIndexM (V_Plucker _ a) i =+ do let o = 6*i+ x <- G.basicUnsafeIndexM a o+ y <- G.basicUnsafeIndexM a (o+1)+ z <- G.basicUnsafeIndexM a (o+2)+ w <- G.basicUnsafeIndexM a (o+3)+ v <- G.basicUnsafeIndexM a (o+4)+ u <- G.basicUnsafeIndexM a (o+5)+ return (Plucker x y z w v u)++instance MonadZip Plucker where+ mzipWith = liftA2++instance MonadFix Plucker where+ mfix f = Plucker (let Plucker a _ _ _ _ _ = f a in a)+ (let Plucker _ a _ _ _ _ = f a in a)+ (let Plucker _ _ a _ _ _ = f a in a)+ (let Plucker _ _ _ a _ _ = f a in a)+ (let Plucker _ _ _ _ a _ = f a in a)+ (let Plucker _ _ _ _ _ a = f a in a)++instance NFData a => NFData (Plucker a) where+ rnf (Plucker a b c d e f) = rnf a `seq` rnf b `seq` rnf c+ `seq` rnf d `seq` rnf e `seq` rnf f++instance Serial1 Plucker where+ serializeWith = traverse_+ deserializeWith k = Plucker <$> k <*> k <*> k <*> k <*> k <*> k++instance Serial a => Serial (Plucker a) where+ serialize = serializeWith serialize+ deserialize = deserializeWith deserialize++instance Binary a => Binary (Plucker a) where+ put = serializeWith Binary.put+ get = deserializeWith Binary.get++instance Serialize a => Serialize (Plucker a) where+ put = serializeWith Cereal.put+ get = deserializeWith Cereal.get++instance Eq1 Plucker where+ liftEq k (Plucker a1 b1 c1 d1 e1 f1)+ (Plucker a2 b2 c2 d2 e2 f2)+ = k a1 a2 && k b1 b2 && k c1 c2 && k d1 d2 && k e1 e2 && k f1 f2+instance Ord1 Plucker where+ liftCompare k (Plucker a1 b1 c1 d1 e1 f1)+ (Plucker a2 b2 c2 d2 e2 f2)+ = k a1 a2 `mappend` k b1 b2 `mappend` k c1 c2 `mappend` k d1 d2 `mappend` k e1 e2 `mappend` k f1 f2+instance Read1 Plucker where+ liftReadsPrec k _ z = readParen (z > 10) $ \r ->+ [ (Plucker a b c d e f, r7)+ | ("Plucker",r1) <- lex r+ , (a,r2) <- k 11 r1+ , (b,r3) <- k 11 r2+ , (c,r4) <- k 11 r3+ , (d,r5) <- k 11 r4+ , (e,r6) <- k 11 r5+ , (f,r7) <- k 11 r6+ ]+instance Show1 Plucker where+ liftShowsPrec k _ z (Plucker a b c d e f) = showParen (z > 10) $+ showString "Plucker " . k 11 a . showChar ' ' . k 11 b . showChar ' ' . k 11 c . showChar ' ' . k 11 d . showChar ' ' . k 11 e . showChar ' ' . k 11 f++instance Field1 (Plucker a) (Plucker a) a a where+ _1 f (Plucker x y z u v w) = f x <&> \x' -> Plucker x' y z u v w++instance Field2 (Plucker a) (Plucker a) a a where+ _2 f (Plucker x y z u v w) = f y <&> \y' -> Plucker x y' z u v w++instance Field3 (Plucker a) (Plucker a) a a where+ _3 f (Plucker x y z u v w) = f z <&> \z' -> Plucker x y z' u v w++instance Field4 (Plucker a) (Plucker a) a a where+ _4 f (Plucker x y z u v w) = f u <&> \u' -> Plucker x y z u' v w++instance Field5 (Plucker a) (Plucker a) a a where+ _5 f (Plucker x y z u v w) = f v <&> \v' -> Plucker x y z u v' w++instance Field6 (Plucker a) (Plucker a) a a where+ _6 f (Plucker x y z u v w) = f w <&> \w' -> Plucker x y z u v w'++instance Semigroup a => Semigroup (Plucker a) where+ (<>) = liftA2 (<>)++instance Monoid a => Monoid (Plucker a) where+ mempty = pure mempty+#if !(MIN_VERSION_base(4,11,0))+ mappend = liftA2 mappend+#endif
src/Linear/Plucker/Coincides.hs view
@@ -1,38 +1,38 @@-{-# LANGUAGE GADTs #-} ---------------------------------------------------------------------------------- --- | --- Copyright : (C) 2012-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : experimental --- Portability : non-portable --- --- Utility for working with Plücker coordinates for lines in 3d homogeneous space. ----------------------------------------------------------------------------------- -module Linear.Plucker.Coincides - ( Coincides(..) - ) where - -import Linear.Epsilon -import Linear.Plucker - --- | When lines are represented as Plücker coordinates, we have the --- ability to check for both directed and undirected --- equality. Undirected equality between 'Line's (or a 'Line' and a --- 'Ray') checks that the two lines coincide in 3D space. Directed --- equality, between two 'Ray's, checks that two lines coincide in 3D, --- and have the same direction. To accomodate these two notions of --- equality, we use an 'Eq' instance on the 'Coincides' data type. --- --- For example, to check the /directed/ equality between two lines, --- @p1@ and @p2@, we write, @Ray p1 == Ray p2@. -data Coincides a where - Line :: (Epsilon a, Fractional a) => Plucker a -> Coincides a - Ray :: (Epsilon a, Fractional a, Ord a) => Plucker a -> Coincides a - -instance Eq (Coincides a) where - Line a == Line b = coincides a b - Line a == Ray b = coincides a b - Ray a == Line b = coincides a b - Ray a == Ray b = coincides' a b +{-# LANGUAGE GADTs #-}+---------------------------------------------------------------------------------+-- |+-- Copyright : (C) 2012-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- Utility for working with Plücker coordinates for lines in 3d homogeneous space.+----------------------------------------------------------------------------------+module Linear.Plucker.Coincides+ ( Coincides(..)+ ) where++import Linear.Epsilon+import Linear.Plucker++-- | When lines are represented as Plücker coordinates, we have the+-- ability to check for both directed and undirected+-- equality. Undirected equality between 'Line's (or a 'Line' and a+-- 'Ray') checks that the two lines coincide in 3D space. Directed+-- equality, between two 'Ray's, checks that two lines coincide in 3D,+-- and have the same direction. To accomodate these two notions of+-- equality, we use an 'Eq' instance on the 'Coincides' data type.+--+-- For example, to check the /directed/ equality between two lines,+-- @p1@ and @p2@, we write, @Ray p1 == Ray p2@.+data Coincides a where+ Line :: (Epsilon a, Fractional a) => Plucker a -> Coincides a+ Ray :: (Epsilon a, Fractional a, Ord a) => Plucker a -> Coincides a++instance Eq (Coincides a) where+ Line a == Line b = coincides a b+ Line a == Ray b = coincides a b+ Ray a == Line b = coincides a b+ Ray a == Ray b = coincides' a b
src/Linear/Projection.hs view
@@ -1,260 +1,260 @@-{-# LANGUAGE CPP #-} ---------------------------------------------------------------------------- --- | --- Copyright : (C) 2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : experimental --- Portability : non-portable --- --- Common projection matrices: e.g. perspective/orthographic transformation --- matrices. --- --- Analytically derived inverses are also supplied, because they can be --- much more accurate in practice than computing them through general --- purpose means ---------------------------------------------------------------------------- -module Linear.Projection - ( lookAt - , perspective, inversePerspective - , infinitePerspective, inverseInfinitePerspective - , frustum, inverseFrustum - , ortho, inverseOrtho - ) where - -import Control.Lens hiding (index) -import Linear.V3 -import Linear.V4 -import Linear.Matrix -import Linear.Epsilon -import Linear.Metric - --- $setup --- >>> import Linear.Matrix --- >>> import Linear.V2 --- >>> import Linear.V4 - --- | Build a look at view matrix -lookAt - :: (Epsilon a, Floating a) - => V3 a -- ^ Eye - -> V3 a -- ^ Center - -> V3 a -- ^ Up - -> M44 a -lookAt eye center up = - V4 (V4 (xa^._x) (xa^._y) (xa^._z) xd) - (V4 (ya^._x) (ya^._y) (ya^._z) yd) - (V4 (-za^._x) (-za^._y) (-za^._z) zd) - (V4 0 0 0 1) - where za = normalize $ center - eye - xa = normalize $ cross za up - ya = cross xa za - xd = -dot xa eye - yd = -dot ya eye - zd = dot za eye - --- | Build a matrix for a symmetric perspective-view frustum -perspective - :: Floating a - => a -- ^ FOV (y direction, in radians) - -> a -- ^ Aspect ratio - -> a -- ^ Near plane - -> a -- ^ Far plane - -> M44 a -perspective fovy aspect near far = - V4 (V4 x 0 0 0) - (V4 0 y 0 0) - (V4 0 0 z w) - (V4 0 0 (-1) 0) - where tanHalfFovy = tan $ fovy / 2 - x = 1 / (aspect * tanHalfFovy) - y = 1 / tanHalfFovy - fpn = far + near - fmn = far - near - oon = 0.5/near - oof = 0.5/far - -- z = 1 / (near/fpn - far/fpn) -- would be better by .5 bits - z = -fpn/fmn - w = 1/(oof-oon) -- 13 bits error reduced to 0.17 - -- w = -(2 * far * near) / fmn - -#ifdef HERBIE -{-# ANN perspective "NoHerbie" #-} -#endif - --- | Build an inverse perspective matrix -inversePerspective - :: Floating a - => a -- ^ FOV (y direction, in radians) - -> a -- ^ Aspect ratio - -> a -- ^ Near plane - -> a -- ^ Far plane - -> M44 a -inversePerspective fovy aspect near far = - V4 (V4 a 0 0 0 ) - (V4 0 b 0 0 ) - (V4 0 0 0 (-1)) - (V4 0 0 c d ) - where tanHalfFovy = tan $ fovy / 2 - a = aspect * tanHalfFovy - b = tanHalfFovy - c = oon - oof - d = oon + oof - oon = 0.5/near - oof = 0.5/far - - --- | Build a perspective matrix per the classic @glFrustum@ arguments. -frustum - :: Floating a - => a -- ^ Left - -> a -- ^ Right - -> a -- ^ Bottom - -> a -- ^ Top - -> a -- ^ Near - -> a -- ^ Far - -> M44 a -frustum l r b t n f = - V4 (V4 x 0 a 0) - (V4 0 y e 0) - (V4 0 0 c d) - (V4 0 0 (-1) 0) - where - rml = r-l - tmb = t-b - fmn = f-n - x = 2*n/rml - y = 2*n/tmb - a = (r+l)/rml - e = (t+b)/tmb - c = negate (f+n)/fmn - d = (-2*f*n)/fmn - -inverseFrustum - :: Floating a - => a -- ^ Left - -> a -- ^ Right - -> a -- ^ Bottom - -> a -- ^ Top - -> a -- ^ Near - -> a -- ^ Far - -> M44 a -inverseFrustum l r b t n f = - V4 (V4 rx 0 0 ax) - (V4 0 ry 0 by) - (V4 0 0 0 (-1)) - (V4 0 0 rd cd) - where - hrn = 0.5/n - hrnf = 0.5/(n*f) - rx = (r-l)*hrn - ry = (t-b)*hrn - ax = (r+l)*hrn - by = (t+b)*hrn - cd = (f+n)*hrnf - rd = (n-f)*hrnf - --- | Build a matrix for a symmetric perspective-view frustum with a far plane at infinite -infinitePerspective - :: Floating a - => a -- ^ FOV (y direction, in radians) - -> a -- ^ Aspect Ratio - -> a -- ^ Near plane - -> M44 a -infinitePerspective fovy a n = - V4 (V4 x 0 0 0) - (V4 0 y 0 0) - (V4 0 0 (-1) w) - (V4 0 0 (-1) 0) - where - t = n*tan(fovy/2) - b = -t - l = b*a - r = t*a - x = (2*n)/(r-l) - y = (2*n)/(t-b) - w = -2*n - -inverseInfinitePerspective - :: Floating a - => a -- ^ FOV (y direction, in radians) - -> a -- ^ Aspect Ratio - -> a -- ^ Near plane - -> M44 a -inverseInfinitePerspective fovy a n = - V4 (V4 rx 0 0 0) - (V4 0 ry 0 0) - (V4 0 0 0 (-1)) - (V4 0 0 rw (-rw)) - where - t = n*tan(fovy/2) - b = -t - l = b*a - r = t*a - hrn = 0.5/n - rx = (r-l)*hrn - ry = (t-b)*hrn - rw = -hrn - --- | Build an orthographic perspective matrix from 6 clipping planes. --- This matrix takes the region delimited by these planes and maps it --- to normalized device coordinates between [-1,1] --- --- This call is designed to mimic the parameters to the OpenGL @glOrtho@ --- call, so it has a slightly strange convention: Notably: the near and --- far planes are negated. --- --- Consequently: --- --- @ --- 'ortho' l r b t n f !* 'V4' l b (-n) 1 = 'V4' (-1) (-1) (-1) 1 --- 'ortho' l r b t n f !* 'V4' r t (-f) 1 = 'V4' 1 1 1 1 --- @ --- --- Examples: --- --- >>> ortho 1 2 3 4 5 6 !* V4 1 3 (-5) 1 --- V4 (-1.0) (-1.0) (-1.0) 1.0 --- --- >>> ortho 1 2 3 4 5 6 !* V4 2 4 (-6) 1 --- V4 1.0 1.0 1.0 1.0 -ortho - :: Fractional a - => a -- ^ Left - -> a -- ^ Right - -> a -- ^ Bottom - -> a -- ^ Top - -> a -- ^ Near - -> a -- ^ Far - -> M44 a -ortho l r b t n f = - V4 (V4 (-2*x) 0 0 ((r+l)*x)) - (V4 0 (-2*y) 0 ((t+b)*y)) - (V4 0 0 (2*z) ((f+n)*z)) - (V4 0 0 0 1) - where x = recip(l-r) - y = recip(b-t) - z = recip(n-f) - --- | Build an inverse orthographic perspective matrix from 6 clipping planes -inverseOrtho - :: Fractional a - => a -- ^ Left - -> a -- ^ Right - -> a -- ^ Bottom - -> a -- ^ Top - -> a -- ^ Near - -> a -- ^ Far - -> M44 a -inverseOrtho l r b t n f = - V4 (V4 x 0 0 c) - (V4 0 y 0 d) - (V4 0 0 z e) - (V4 0 0 0 1) - where x = 0.5*(r-l) - y = 0.5*(t-b) - z = 0.5*(n-f) - c = 0.5*(l+r) - d = 0.5*(b+t) - e = -0.5*(n+f) +{-# LANGUAGE CPP #-}+---------------------------------------------------------------------------+-- |+-- Copyright : (C) 2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- Common projection matrices: e.g. perspective/orthographic transformation+-- matrices.+--+-- Analytically derived inverses are also supplied, because they can be+-- much more accurate in practice than computing them through general+-- purpose means+---------------------------------------------------------------------------+module Linear.Projection+ ( lookAt+ , perspective, inversePerspective+ , infinitePerspective, inverseInfinitePerspective+ , frustum, inverseFrustum+ , ortho, inverseOrtho+ ) where++import Control.Lens hiding (index)+import Linear.V3+import Linear.V4+import Linear.Matrix+import Linear.Epsilon+import Linear.Metric++-- $setup+-- >>> import Linear.Matrix+-- >>> import Linear.V2+-- >>> import Linear.V4++-- | Build a look at view matrix+lookAt+ :: (Epsilon a, Floating a)+ => V3 a -- ^ Eye+ -> V3 a -- ^ Center+ -> V3 a -- ^ Up+ -> M44 a+lookAt eye center up =+ V4 (V4 (xa^._x) (xa^._y) (xa^._z) xd)+ (V4 (ya^._x) (ya^._y) (ya^._z) yd)+ (V4 (-za^._x) (-za^._y) (-za^._z) zd)+ (V4 0 0 0 1)+ where za = normalize $ center - eye+ xa = normalize $ cross za up+ ya = cross xa za+ xd = -dot xa eye+ yd = -dot ya eye+ zd = dot za eye++-- | Build a matrix for a symmetric perspective-view frustum+perspective+ :: Floating a+ => a -- ^ FOV (y direction, in radians)+ -> a -- ^ Aspect ratio+ -> a -- ^ Near plane+ -> a -- ^ Far plane+ -> M44 a+perspective fovy aspect near far =+ V4 (V4 x 0 0 0)+ (V4 0 y 0 0)+ (V4 0 0 z w)+ (V4 0 0 (-1) 0)+ where tanHalfFovy = tan $ fovy / 2+ x = 1 / (aspect * tanHalfFovy)+ y = 1 / tanHalfFovy+ fpn = far + near+ fmn = far - near+ oon = 0.5/near+ oof = 0.5/far+ -- z = 1 / (near/fpn - far/fpn) -- would be better by .5 bits+ z = -fpn/fmn+ w = 1/(oof-oon) -- 13 bits error reduced to 0.17+ -- w = -(2 * far * near) / fmn++#ifdef HERBIE+{-# ANN perspective "NoHerbie" #-}+#endif++-- | Build an inverse perspective matrix+inversePerspective+ :: Floating a+ => a -- ^ FOV (y direction, in radians)+ -> a -- ^ Aspect ratio+ -> a -- ^ Near plane+ -> a -- ^ Far plane+ -> M44 a+inversePerspective fovy aspect near far =+ V4 (V4 a 0 0 0 )+ (V4 0 b 0 0 )+ (V4 0 0 0 (-1))+ (V4 0 0 c d )+ where tanHalfFovy = tan $ fovy / 2+ a = aspect * tanHalfFovy+ b = tanHalfFovy+ c = oon - oof+ d = oon + oof+ oon = 0.5/near+ oof = 0.5/far+++-- | Build a perspective matrix per the classic @glFrustum@ arguments.+frustum+ :: Floating a+ => a -- ^ Left+ -> a -- ^ Right+ -> a -- ^ Bottom+ -> a -- ^ Top+ -> a -- ^ Near+ -> a -- ^ Far+ -> M44 a+frustum l r b t n f =+ V4 (V4 x 0 a 0)+ (V4 0 y e 0)+ (V4 0 0 c d)+ (V4 0 0 (-1) 0)+ where+ rml = r-l+ tmb = t-b+ fmn = f-n+ x = 2*n/rml+ y = 2*n/tmb+ a = (r+l)/rml+ e = (t+b)/tmb+ c = negate (f+n)/fmn+ d = (-2*f*n)/fmn++inverseFrustum+ :: Floating a+ => a -- ^ Left+ -> a -- ^ Right+ -> a -- ^ Bottom+ -> a -- ^ Top+ -> a -- ^ Near+ -> a -- ^ Far+ -> M44 a+inverseFrustum l r b t n f =+ V4 (V4 rx 0 0 ax)+ (V4 0 ry 0 by)+ (V4 0 0 0 (-1))+ (V4 0 0 rd cd)+ where+ hrn = 0.5/n+ hrnf = 0.5/(n*f)+ rx = (r-l)*hrn+ ry = (t-b)*hrn+ ax = (r+l)*hrn+ by = (t+b)*hrn+ cd = (f+n)*hrnf+ rd = (n-f)*hrnf++-- | Build a matrix for a symmetric perspective-view frustum with a far plane at infinite+infinitePerspective+ :: Floating a+ => a -- ^ FOV (y direction, in radians)+ -> a -- ^ Aspect Ratio+ -> a -- ^ Near plane+ -> M44 a+infinitePerspective fovy a n =+ V4 (V4 x 0 0 0)+ (V4 0 y 0 0)+ (V4 0 0 (-1) w)+ (V4 0 0 (-1) 0)+ where+ t = n*tan(fovy/2)+ b = -t+ l = b*a+ r = t*a+ x = (2*n)/(r-l)+ y = (2*n)/(t-b)+ w = -2*n++inverseInfinitePerspective+ :: Floating a+ => a -- ^ FOV (y direction, in radians)+ -> a -- ^ Aspect Ratio+ -> a -- ^ Near plane+ -> M44 a+inverseInfinitePerspective fovy a n =+ V4 (V4 rx 0 0 0)+ (V4 0 ry 0 0)+ (V4 0 0 0 (-1))+ (V4 0 0 rw (-rw))+ where+ t = n*tan(fovy/2)+ b = -t+ l = b*a+ r = t*a+ hrn = 0.5/n+ rx = (r-l)*hrn+ ry = (t-b)*hrn+ rw = -hrn++-- | Build an orthographic perspective matrix from 6 clipping planes.+-- This matrix takes the region delimited by these planes and maps it+-- to normalized device coordinates between [-1,1]+--+-- This call is designed to mimic the parameters to the OpenGL @glOrtho@+-- call, so it has a slightly strange convention: Notably: the near and+-- far planes are negated.+--+-- Consequently:+--+-- @+-- 'ortho' l r b t n f !* 'V4' l b (-n) 1 = 'V4' (-1) (-1) (-1) 1+-- 'ortho' l r b t n f !* 'V4' r t (-f) 1 = 'V4' 1 1 1 1+-- @+--+-- Examples:+--+-- >>> ortho 1 2 3 4 5 6 !* V4 1 3 (-5) 1+-- V4 (-1.0) (-1.0) (-1.0) 1.0+--+-- >>> ortho 1 2 3 4 5 6 !* V4 2 4 (-6) 1+-- V4 1.0 1.0 1.0 1.0+ortho+ :: Fractional a+ => a -- ^ Left+ -> a -- ^ Right+ -> a -- ^ Bottom+ -> a -- ^ Top+ -> a -- ^ Near+ -> a -- ^ Far+ -> M44 a+ortho l r b t n f =+ V4 (V4 (-2*x) 0 0 ((r+l)*x))+ (V4 0 (-2*y) 0 ((t+b)*y))+ (V4 0 0 (2*z) ((f+n)*z))+ (V4 0 0 0 1)+ where x = recip(l-r)+ y = recip(b-t)+ z = recip(n-f)++-- | Build an inverse orthographic perspective matrix from 6 clipping planes+inverseOrtho+ :: Fractional a+ => a -- ^ Left+ -> a -- ^ Right+ -> a -- ^ Bottom+ -> a -- ^ Top+ -> a -- ^ Near+ -> a -- ^ Far+ -> M44 a+inverseOrtho l r b t n f =+ V4 (V4 x 0 0 c)+ (V4 0 y 0 d)+ (V4 0 0 z e)+ (V4 0 0 0 1)+ where x = 0.5*(r-l)+ y = 0.5*(t-b)+ z = 0.5*(n-f)+ c = 0.5*(l+r)+ d = 0.5*(b+t)+ e = -0.5*(n+f)
src/Linear/Quaternion.hs view
@@ -1,707 +1,707 @@-{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveLift #-} - -#ifndef MIN_VERSION_hashable -#define MIN_VERSION_hashable(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_vector -#define MIN_VERSION_vector(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_base -#define MIN_VERSION_base(x,y,z) 1 -#endif - ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2012-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : experimental --- Portability : non-portable --- --- Quaternions ----------------------------------------------------------------------------- -module Linear.Quaternion - ( Quaternion(..) - , Complicated(..) - , Hamiltonian(..) - , ee, ei, ej, ek - , slerp - , asinq - , acosq - , atanq - , asinhq - , acoshq - , atanhq - , absi - , pow - , rotate - , axisAngle - ) where - -import Control.Applicative -import Control.DeepSeq (NFData(rnf)) -import Control.Monad (liftM) -import Control.Monad.Fix -import Control.Monad.Zip -import Control.Lens as Lens hiding ((<.>)) -import Data.Binary as Binary -import Data.Bytes.Serial -import Data.Complex (Complex((:+))) -import Data.Data -import Data.Distributive -import Data.Foldable -import qualified Data.Foldable.WithIndex as WithIndex -import Data.Functor.Bind -import Data.Functor.Classes -import Data.Functor.Rep -import qualified Data.Functor.WithIndex as WithIndex -import Data.Hashable -import Data.Hashable.Lifted -#if !(MIN_VERSION_base(4,11,0)) -import Data.Semigroup (Semigroup(..)) -#endif -import Data.Serialize as Cereal -import GHC.Arr (Ix(..)) -import qualified Data.Foldable as F -import qualified Data.Traversable.WithIndex as WithIndex -import qualified Data.Vector as V -import qualified Data.Vector.Generic.Mutable as M -import qualified Data.Vector.Generic as G -import qualified Data.Vector.Unboxed.Base as U -import Foreign.Ptr (castPtr, plusPtr) -import Foreign.Storable (Storable(..)) -import GHC.Generics (Generic, Generic1) -#if defined(MIN_VERSION_template_haskell) -import Language.Haskell.TH.Syntax (Lift) -#endif -import Linear.Epsilon -import Linear.Conjugate -import Linear.Metric -import Linear.V -import Linear.V2 -import Linear.V3 -import Linear.V4 -import Linear.Vector -import Prelude hiding (any) -import System.Random (Random(..)) - --- | Quaternions -data Quaternion a = Quaternion !a {-# UNPACK #-}!(V3 a) - deriving (Eq,Ord,Read,Show,Data - ,Generic,Generic1 -#if defined(MIN_VERSION_template_haskell) - ,Lift -#endif - ) - -instance Finite Quaternion where - type Size Quaternion = 4 - toV (Quaternion a (V3 b c d)) = V (V.fromListN 4 [a, b, c, d]) - fromV (V v) = Quaternion (v V.! 0) (V3 (v V.! 1) (v V.! 2) (v V.! 3)) - -instance Random a => Random (Quaternion a) where - random g = case random g of - (a, g') -> case random g' of - (b, g'') -> (Quaternion a b, g'') - randomR (Quaternion a b, Quaternion c d) g = case randomR (a,c) g of - (e, g') -> case randomR (b,d) g' of - (f, g'') -> (Quaternion e f, g'') - -instance Functor Quaternion where - fmap f (Quaternion e v) = Quaternion (f e) (fmap f v) - {-# INLINE fmap #-} - a <$ _ = Quaternion a (V3 a a a) - {-# INLINE (<$) #-} - -instance Apply Quaternion where - Quaternion f fv <.> Quaternion a v = Quaternion (f a) (fv <.> v) - {-# INLINE (<.>) #-} - -instance Applicative Quaternion where - pure a = Quaternion a (pure a) - {-# INLINE pure #-} - Quaternion f fv <*> Quaternion a v = Quaternion (f a) (fv <*> v) - {-# INLINE (<*>) #-} - -instance Additive Quaternion where - zero = pure 0 - {-# INLINE zero #-} - liftU2 = liftA2 - {-# INLINE liftU2 #-} - liftI2 = liftA2 - {-# INLINE liftI2 #-} - -instance Bind Quaternion where - Quaternion a (V3 b c d) >>- f = Quaternion a' (V3 b' c' d') where - Quaternion a' _ = f a - Quaternion _ (V3 b' _ _) = f b - Quaternion _ (V3 _ c' _) = f c - Quaternion _ (V3 _ _ d') = f d - {-# INLINE (>>-) #-} - -instance Monad Quaternion where - return = pure - {-# INLINE return #-} - -- the diagonal of a sedenion is super useful! - Quaternion a (V3 b c d) >>= f = Quaternion a' (V3 b' c' d') where - Quaternion a' _ = f a - Quaternion _ (V3 b' _ _) = f b - Quaternion _ (V3 _ c' _) = f c - Quaternion _ (V3 _ _ d') = f d - {-# INLINE (>>=) #-} - -instance Ix a => Ix (Quaternion a) where - {-# SPECIALISE instance Ix (Quaternion Int) #-} - - range (Quaternion l1 l2, Quaternion u1 u2) = - [ Quaternion i1 i2 | i1 <- range (l1,u1), i2 <- range (l2,u2) ] - {-# INLINE range #-} - - unsafeIndex (Quaternion l1 l2, Quaternion u1 u2) (Quaternion i1 i2) = - unsafeIndex (l1,u1) i1 * unsafeRangeSize (l2,u2) + unsafeIndex (l2,u2) i2 - {-# INLINE unsafeIndex #-} - - inRange (Quaternion l1 l2, Quaternion u1 u2) (Quaternion i1 i2) = - inRange (l1,u1) i1 && inRange (l2,u2) i2 - {-# INLINE inRange #-} - -instance Representable Quaternion where - type Rep Quaternion = E Quaternion - tabulate f = Quaternion (f ee) (V3 (f ei) (f ej) (f ek)) - {-# INLINE tabulate #-} - index xs (E l) = view l xs - {-# INLINE index #-} - -instance WithIndex.FunctorWithIndex (E Quaternion) Quaternion where - imap f (Quaternion a (V3 b c d)) = Quaternion (f ee a) $ V3 (f ei b) (f ej c) (f ek d) - {-# INLINE imap #-} - -instance WithIndex.FoldableWithIndex (E Quaternion) Quaternion where - ifoldMap f (Quaternion a (V3 b c d)) = f ee a `mappend` f ei b `mappend` f ej c `mappend` f ek d - {-# INLINE ifoldMap #-} - -instance WithIndex.TraversableWithIndex (E Quaternion) Quaternion where - itraverse f (Quaternion a (V3 b c d)) = Quaternion <$> f ee a <*> (V3 <$> f ei b <*> f ej c <*> f ek d) - {-# INLINE itraverse #-} - -#if !MIN_VERSION_lens(5,0,0) -instance Lens.FunctorWithIndex (E Quaternion) Quaternion where imap = WithIndex.imap -instance Lens.FoldableWithIndex (E Quaternion) Quaternion where ifoldMap = WithIndex.ifoldMap -instance Lens.TraversableWithIndex (E Quaternion) Quaternion where itraverse = WithIndex.itraverse -#endif - -type instance Index (Quaternion a) = E Quaternion -type instance IxValue (Quaternion a) = a - -instance Ixed (Quaternion a) where - ix i = el i - {-# INLINE ix #-} - -instance Each (Quaternion a) (Quaternion b) a b where - each = traverse - {-# INLINE each #-} - -instance Foldable Quaternion where - foldMap f (Quaternion e v) = f e `mappend` foldMap f v - {-# INLINE foldMap #-} - foldr f z (Quaternion e v) = f e (F.foldr f z v) - {-# INLINE foldr #-} - null _ = False - length _ = 4 - -instance Traversable Quaternion where - traverse f (Quaternion e v) = Quaternion <$> f e <*> traverse f v - {-# INLINE traverse #-} - -instance Storable a => Storable (Quaternion a) where - sizeOf _ = 4 * sizeOf (undefined::a) - {-# INLINE sizeOf #-} - alignment _ = alignment (undefined::a) - {-# INLINE alignment #-} - poke ptr (Quaternion e v) = poke (castPtr ptr) e >> - poke (castPtr (ptr `plusPtr` sz)) v - where sz = sizeOf (undefined::a) - {-# INLINE poke #-} - peek ptr = Quaternion <$> peek (castPtr ptr) - <*> peek (castPtr (ptr `plusPtr` sz)) - where sz = sizeOf (undefined::a) - {-# INLINE peek #-} - -instance RealFloat a => Num (Quaternion a) where - {-# SPECIALIZE instance Num (Quaternion Float) #-} - {-# SPECIALIZE instance Num (Quaternion Double) #-} - (+) = liftA2 (+) - {-# INLINE (+) #-} - (-) = liftA2 (-) - {-# INLINE (-) #-} - negate = fmap negate - {-# INLINE negate #-} - Quaternion s1 v1 * Quaternion s2 v2 = Quaternion (s1*s2 - (v1 `dot` v2)) $ - (v1 `cross` v2) + s1*^v2 + s2*^v1 - {-# INLINE (*) #-} - fromInteger x = Quaternion (fromInteger x) 0 - {-# INLINE fromInteger #-} - abs z = Quaternion (norm z) 0 - {-# INLINE abs #-} - signum q@(Quaternion e (V3 i j k)) - | m == 0.0 = q - | not (isInfinite m || isNaN m) = q ^/ sqrt m - | any isNaN q = qNaN - | not (ii || ij || ik) = Quaternion 1 (V3 0 0 0) - | not (ie || ij || ik) = Quaternion 0 (V3 1 0 0) - | not (ie || ii || ik) = Quaternion 0 (V3 0 1 0) - | not (ie || ii || ij) = Quaternion 0 (V3 0 0 1) - | otherwise = qNaN - where - m = quadrance q - ie = isInfinite e - ii = isInfinite i - ij = isInfinite j - ik = isInfinite k - {-# INLINE signum #-} - -instance Hashable a => Hashable (Quaternion a) where - hashWithSalt s (Quaternion a b) = s `hashWithSalt` a `hashWithSalt` b - {-# INLINE hashWithSalt #-} - -instance Hashable1 Quaternion where - liftHashWithSalt h s (Quaternion a b) = liftHashWithSalt h (h s a) b - {-# INLINE liftHashWithSalt #-} - -qNaN :: RealFloat a => Quaternion a -qNaN = Quaternion fNaN (V3 fNaN fNaN fNaN) where fNaN = 0/0 -{-# INLINE qNaN #-} - --- {-# RULES "abs/norm" abs x = Quaternion (norm x) 0 #-} --- {-# RULES "signum/signorm" signum = signorm #-} - --- this will attempt to rewrite calls to abs to use norm intead when it is available. - -instance RealFloat a => Fractional (Quaternion a) where - {-# SPECIALIZE instance Fractional (Quaternion Float) #-} - {-# SPECIALIZE instance Fractional (Quaternion Double) #-} - Quaternion q0 (V3 q1 q2 q3) / Quaternion r0 (V3 r1 r2 r3) = - Quaternion (r0*q0+r1*q1+r2*q2+r3*q3) - (V3 (r0*q1-r1*q0-r2*q3+r3*q2) - (r0*q2+r1*q3-r2*q0-r3*q1) - (r0*q3-r1*q2+r2*q1-r3*q0)) - ^/ (r0*r0 + r1*r1 + r2*r2 + r3*r3) - {-# INLINE (/) #-} - recip q@(Quaternion e v) = Quaternion e (negate v) ^/ quadrance q - {-# INLINE recip #-} - fromRational x = Quaternion (fromRational x) 0 - {-# INLINE fromRational #-} - -instance Metric Quaternion where - Quaternion e v `dot` Quaternion e' v' = e*e' + (v `dot` v') - {-# INLINE dot #-} - --- | A vector space that includes the basis elements '_e' and '_i' -class Complicated t where - _e, _i :: Lens' (t a) a - -ee, ei :: Complicated t => E t -ee = E _e -ei = E _i - -instance Complicated Complex where - _e f (a :+ b) = (:+ b) <$> f a - {-# INLINE _e #-} - _i f (a :+ b) = (a :+) <$> f b - {-# INLINE _i #-} - -instance Complicated Quaternion where - _e f (Quaternion a v) = (`Quaternion` v) <$> f a - {-# INLINE _e #-} - _i f (Quaternion a v) = Quaternion a <$> _x f v - {-# INLINE _i #-} - --- | A vector space that includes the basis elements '_e', '_i', '_j' and '_k' -class Complicated t => Hamiltonian t where - _j, _k :: Lens' (t a) a - _ijk :: Lens' (t a) (V3 a) - -ej, ek :: Hamiltonian t => E t -ej = E _j -ek = E _k - -instance Hamiltonian Quaternion where - _j f (Quaternion a v) = Quaternion a <$> _y f v - {-# INLINE _j #-} - _k f (Quaternion a v) = Quaternion a <$> _z f v - {-# INLINE _k #-} - _ijk f (Quaternion a v) = Quaternion a <$> f v - {-# INLINE _ijk #-} - -instance Distributive Quaternion where - distribute f = Quaternion (fmap (\(Quaternion x _) -> x) f) $ V3 - (fmap (\(Quaternion _ (V3 y _ _)) -> y) f) - (fmap (\(Quaternion _ (V3 _ z _)) -> z) f) - (fmap (\(Quaternion _ (V3 _ _ w)) -> w) f) - {-# INLINE distribute #-} - -instance (Conjugate a, RealFloat a) => Conjugate (Quaternion a) where - conjugate (Quaternion e v) = Quaternion (conjugate e) (negate v) - {-# INLINE conjugate #-} - -reimagine :: RealFloat a => a -> a -> Quaternion a -> Quaternion a -reimagine r s (Quaternion _ v) - | isNaN s || isInfinite s = let aux 0 = 0 - aux x = s * x - in Quaternion r (aux <$> v) - | otherwise = Quaternion r (v^*s) -{-# INLINE reimagine #-} - --- | quadrance of the imaginary component -qi :: Num a => Quaternion a -> a -qi (Quaternion _ v) = quadrance v -{-# INLINE qi #-} - --- | norm of the imaginary component -absi :: Floating a => Quaternion a -> a -absi = sqrt . qi -{-# INLINE absi #-} - --- | raise a 'Quaternion' to a scalar power -pow :: RealFloat a => Quaternion a -> a -> Quaternion a -pow q t = exp (t *^ log q) -{-# INLINE pow #-} - -sqrte2pqiq :: (Floating a, Ord a) => a -> a -> a -sqrte2pqiq e qiq -- = sqrt (e*e + qiq) - | e < - 1.5097698010472593e153 = -(qiq/e) - e - | e < 5.582399551122541e57 = sqrt (e*e + qiq) -- direct definition - | otherwise = (qiq/e) + e --- {-# SPECIALIZE sqrte2pqiq :: Double -> Double -> Double #-} --- {-# SPECIALIZE sqrte2pqiq :: Float -> Float -> Float #-} -#ifdef HERBIE -{-# ANN sqrte2pqiq "NoHerbie" #-} -#endif - -tanrhs :: (Floating a, Ord a) => a -> a -> a -> a -tanrhs sai ai d -- = cosh ai * (sai / ai) / d -- improved from 6.04 bits of error to 0.19 bits - | sai < -4.618902267687042e-52 = (sai / d / ai) * cosh ai - | sai < 1.038530535935153e-39 = (cosh ai * sai) / ai / d - | otherwise = (sai / d / ai) * cosh ai --- {-# SPECIALIZE tanrhs :: Double -> Double -> Double -> Double #-} --- {-# SPECIALIZE tanrhs :: Float -> Float -> Float -> Float #-} -#ifdef HERBIE -{-# ANN tanrhs "NoHerbie" #-} -#endif - - --- ehh.. -instance RealFloat a => Floating (Quaternion a) where - {-# SPECIALIZE instance Floating (Quaternion Float) #-} - {-# SPECIALIZE instance Floating (Quaternion Double) #-} - pi = Quaternion pi 0 - {-# INLINE pi #-} - exp q@(Quaternion e v) - | qiq == 0 = Quaternion (exp e) v - | ai <- sqrt qiq, exe <- exp e = reimagine (exe * cos ai) (exe * (sin ai / ai)) q - where qiq = qi q - {-# INLINE exp #-} - log q@(Quaternion e v) - | qiq == 0 = if e >= 0 - then Quaternion (log e) v -- Using v rather than 0 preserves negative zeros - else Quaternion (negate (log (negate e))) v -- negative scalar: negate quaternion, take log, negate again, preserves negative zeros - | ai <- sqrt qiq = reimagine (log m) (acos (e / m) / ai) q - where qiq = qi q - m = sqrte2pqiq e qiq - {-# INLINE log #-} - - x ** y = exp (y * log x) - {-# INLINE (**) #-} - - sqrt q@(Quaternion e v) - | m == 0 = q - | qiq == 0 = if e > 0 - then Quaternion (sqrt e) 0 - else Quaternion 0 (V3 (sqrt (negate e)) 0 0) - | im <- sqrt (0.5*(m-e)) / sqrt qiq = Quaternion (0.5*(m+e)) (v^*im) - where qiq = qi q - m = sqrte2pqiq e qiq - {-# INLINE sqrt #-} - - cos q@(Quaternion e v) - | qiq == 0 = Quaternion (cos e) v - | ai <- sqrt qiq = reimagine (cos e * cosh ai) (- sin e / ai / sinh ai) q -- 0.15 bits error - where qiq = qi q - {-# INLINE cos #-} - - sin q@(Quaternion e v) - | qiq == 0 = Quaternion (sin e) v - | ai <- sqrt qiq = reimagine (sin e * cosh ai) (cos e * sinh ai / ai) q - where qiq = qi q - {-# INLINE sin #-} - - tan q@(Quaternion e v) - | qiq == 0 = Quaternion (tan e) v - | ai <- sqrt qiq, ce <- cos e, sai <- sinh ai, d <- ce*ce + sai*sai = - reimagine (ce * sin e / d) (tanrhs sai ai d) q - where qiq = qi q - {-# INLINE tan #-} - - sinh q@(Quaternion e v) - | qiq == 0 = Quaternion (sinh e) v - | ai <- sqrt qiq = reimagine (sinh e * cos ai) (cosh e * sin ai / ai) q - where qiq = qi q - {-# INLINE sinh #-} - - cosh q@(Quaternion e v) - | qiq == 0 = Quaternion (cosh e) v - | ai <- sqrt qiq = reimagine (cosh e * cos ai) (sin ai * (sinh e / ai)) q - where qiq = qi q - {-# INLINE cosh #-} - - tanh q@(Quaternion e v) - | qiq == 0 = Quaternion (tanh e) v - | ai <- sqrt qiq, se <- sinh e, cai <- cos ai, d <- se*se + cai*cai = - reimagine (cosh e * se / d) (tanhrhs cai ai d) q - where qiq = qi q - {-# INLINE tanh #-} - - asin = cut asin - {-# INLINE asin #-} - acos = cut acos - {-# INLINE acos #-} - atan = cut atan - {-# INLINE atan #-} - - asinh = cut asinh - {-# INLINE asinh #-} - acosh = cut acosh - {-# INLINE acosh #-} - atanh = cut atanh - {-# INLINE atanh #-} - -tanhrhs :: (Floating a, Ord a) => a -> a -> a -> a -tanhrhs cai ai d -- = cai * (sin ai / ai) / d - | d >= -4.2173720203427147e-29 && d < 4.446702369113811e64 = cai / (d * (ai / sin ai)) - | otherwise = cai * (1 / ai / sin ai) / d --- {-# SPECIALIZE tanhrhs :: Double -> Double -> Double -> Double #-} --- {-# SPECIALIZE tanhrhs :: Float -> Float -> Float -> Float #-} -#ifdef HERBIE -{-# ANN tanhrhs "NoHerbie" #-} -#endif - --- | Helper for calculating with specific branch cuts -cut :: RealFloat a => (Complex a -> Complex a) -> Quaternion a -> Quaternion a -cut f q@(Quaternion e (V3 _ y z)) - | qiq == 0 = Quaternion a (V3 b y z) - | otherwise = reimagine a (b / ai) q - where qiq = qi q - ai = sqrt qiq - a :+ b = f (e :+ ai) -{-# INLINE cut #-} - --- | Helper for calculating with specific branch cuts -cutWith :: RealFloat a => Complex a -> Quaternion a -> Quaternion a -cutWith (r :+ im) q@(Quaternion e v) - | e /= 0 || qiq == 0 || isNaN qiq || isInfinite qiq = error "bad cut" - | s <- im / sqrt qiq = Quaternion r (v^*s) - where qiq = qi q -{-# INLINE cutWith #-} - --- | 'asin' with a specified branch cut. -asinq :: RealFloat a => Quaternion a -> Quaternion a -> Quaternion a -asinq q@(Quaternion e _) u - | qiq /= 0.0 || e >= -1 && e <= 1 = asin q - | otherwise = cutWith (asin (e :+ sqrt qiq)) u - where qiq = qi q -{-# INLINE asinq #-} - --- | 'acos' with a specified branch cut. -acosq :: RealFloat a => Quaternion a -> Quaternion a -> Quaternion a -acosq q@(Quaternion e _) u - | qiq /= 0.0 || e >= -1 && e <= 1 = acos q - | otherwise = cutWith (acos (e :+ sqrt qiq)) u - where qiq = qi q -{-# INLINE acosq #-} - --- | 'atan' with a specified branch cut. -atanq :: RealFloat a => Quaternion a -> Quaternion a -> Quaternion a -atanq q@(Quaternion e _) u - | e /= 0.0 || qiq >= -1 && qiq <= 1 = atan q - | otherwise = cutWith (atan (e :+ sqrt qiq)) u - where qiq = qi q -{-# INLINE atanq #-} - --- | 'asinh' with a specified branch cut. -asinhq :: RealFloat a => Quaternion a -> Quaternion a -> Quaternion a -asinhq q@(Quaternion e _) u - | e /= 0.0 || qiq >= -1 && qiq <= 1 = asinh q - | otherwise = cutWith (asinh (e :+ sqrt qiq)) u - where qiq = qi q -{-# INLINE asinhq #-} - --- | 'acosh' with a specified branch cut. -acoshq :: RealFloat a => Quaternion a -> Quaternion a -> Quaternion a -acoshq q@(Quaternion e _) u - | qiq /= 0.0 || e >= 1 = asinh q - | otherwise = cutWith (acosh (e :+ sqrt qiq)) u - where qiq = qi q -{-# INLINE acoshq #-} - --- | 'atanh' with a specified branch cut. -atanhq :: RealFloat a => Quaternion a -> Quaternion a -> Quaternion a -atanhq q@(Quaternion e _) u - | qiq /= 0.0 || e > -1 && e < 1 = atanh q - | otherwise = cutWith (atanh (e :+ sqrt qiq)) u - where qiq = qi q -{-# INLINE atanhq #-} - --- | Spherical linear interpolation between two quaternions. - -slerp :: RealFloat a => Quaternion a -> Quaternion a -> a -> Quaternion a -slerp q p t - | 1.0 - cosphi < 1e-8 = q - | otherwise = ((sin ((1-t)*phi) *^ q) + sin (t*phi) *^ f p) ^/ sin phi - where - dqp = dot q p - (cosphi, f) = if dqp < 0 then (-dqp, negate) else (dqp, id) - phi = acos cosphi -{-# SPECIALIZE slerp :: Quaternion Float -> Quaternion Float -> Float -> Quaternion Float #-} -{-# SPECIALIZE slerp :: Quaternion Double -> Quaternion Double -> Double -> Quaternion Double #-} - --- | Apply a rotation to a vector. -rotate :: (Conjugate a, RealFloat a) => Quaternion a -> V3 a -> V3 a -rotate q v = ijk where - Quaternion _ ijk = q * Quaternion 0 v * conjugate q -{-# SPECIALIZE rotate :: Quaternion Float -> V3 Float -> V3 Float #-} -{-# SPECIALIZE rotate :: Quaternion Double -> V3 Double -> V3 Double #-} - -instance (RealFloat a, Epsilon a) => Epsilon (Quaternion a) where - nearZero = nearZero . quadrance - {-# INLINE nearZero #-} - --- | @'axisAngle' axis theta@ builds a 'Quaternion' representing a --- rotation of @theta@ radians about @axis@. -axisAngle :: (Epsilon a, Floating a) => V3 a -> a -> Quaternion a -axisAngle axis theta = Quaternion (cos half) (sin half *^ normalize axis) - where half = theta / 2 -{-# INLINE axisAngle #-} - -data instance U.Vector (Quaternion a) = V_Quaternion !Int (U.Vector a) -data instance U.MVector s (Quaternion a) = MV_Quaternion !Int (U.MVector s a) -instance U.Unbox a => U.Unbox (Quaternion a) - -instance U.Unbox a => M.MVector U.MVector (Quaternion a) where - basicLength (MV_Quaternion n _) = n - basicUnsafeSlice m n (MV_Quaternion _ v) = MV_Quaternion n (M.basicUnsafeSlice (4*m) (4*n) v) - basicOverlaps (MV_Quaternion _ v) (MV_Quaternion _ u) = M.basicOverlaps v u - basicUnsafeNew n = liftM (MV_Quaternion n) (M.basicUnsafeNew (4*n)) - basicUnsafeRead (MV_Quaternion _ v) i = - do let o = 4*i - x <- M.basicUnsafeRead v o - y <- M.basicUnsafeRead v (o+1) - z <- M.basicUnsafeRead v (o+2) - w <- M.basicUnsafeRead v (o+3) - return (Quaternion x (V3 y z w)) - basicUnsafeWrite (MV_Quaternion _ v) i (Quaternion x (V3 y z w)) = - do let o = 4*i - M.basicUnsafeWrite v o x - M.basicUnsafeWrite v (o+1) y - M.basicUnsafeWrite v (o+2) z - M.basicUnsafeWrite v (o+3) w - basicInitialize (MV_Quaternion _ v) = M.basicInitialize v - -instance U.Unbox a => G.Vector U.Vector (Quaternion a) where - basicUnsafeFreeze (MV_Quaternion n v) = liftM ( V_Quaternion n) (G.basicUnsafeFreeze v) - basicUnsafeThaw ( V_Quaternion n v) = liftM (MV_Quaternion n) (G.basicUnsafeThaw v) - basicLength ( V_Quaternion n _) = n - basicUnsafeSlice m n (V_Quaternion _ v) = V_Quaternion n (G.basicUnsafeSlice (4*m) (4*n) v) - basicUnsafeIndexM (V_Quaternion _ v) i = - do let o = 4*i - x <- G.basicUnsafeIndexM v o - y <- G.basicUnsafeIndexM v (o+1) - z <- G.basicUnsafeIndexM v (o+2) - w <- G.basicUnsafeIndexM v (o+3) - return (Quaternion x (V3 y z w)) - -instance MonadZip Quaternion where - mzipWith = liftA2 - -instance MonadFix Quaternion where - mfix f = Quaternion (let Quaternion a _ = f a in a) - (V3 (let Quaternion _ (V3 a _ _) = f a in a) - (let Quaternion _ (V3 _ a _) = f a in a) - (let Quaternion _ (V3 _ _ a) = f a in a)) - -instance NFData a => NFData (Quaternion a) where - rnf (Quaternion a b) = rnf a `seq` rnf b - -instance Serial1 Quaternion where - serializeWith f (Quaternion a b) = f a >> serializeWith f b - deserializeWith f = Quaternion <$> f <*> deserializeWith f - -instance Serial a => Serial (Quaternion a) where - serialize = serializeWith serialize - deserialize = deserializeWith deserialize - -instance Binary a => Binary (Quaternion a) where - put = serializeWith Binary.put - get = deserializeWith Binary.get - -instance Serialize a => Serialize (Quaternion a) where - put = serializeWith Cereal.put - get = deserializeWith Cereal.get - -instance Eq1 Quaternion where - liftEq f (Quaternion a b) (Quaternion c d) = f a c && liftEq f b d -instance Ord1 Quaternion where - liftCompare f (Quaternion a b) (Quaternion c d) = f a c `mappend` liftCompare f b d -instance Show1 Quaternion where - liftShowsPrec f g d (Quaternion a b) = showsBinaryWith f (liftShowsPrec f g) "Quaternion" d a b -instance Read1 Quaternion where - liftReadsPrec f g = readsData $ readsBinaryWith f (liftReadsPrec f g) "Quaternion" Quaternion - -instance Field1 (Quaternion a) (Quaternion a) a a where - _1 f (Quaternion w xyz) = f w <&> \w' -> Quaternion w' xyz - -instance Field2 (Quaternion a) (Quaternion a) a a where - _2 f (Quaternion w (V3 x y z)) = f x <&> \x' -> Quaternion w (V3 x' y z) - -instance Field3 (Quaternion a) (Quaternion a) a a where - _3 f (Quaternion w (V3 x y z)) = f y <&> \y' -> Quaternion w (V3 x y' z) - -instance Field4 (Quaternion a) (Quaternion a) a a where - _4 f (Quaternion w (V3 x y z)) = f z <&> \z' -> Quaternion w (V3 x y z') - -instance Semigroup a => Semigroup (Quaternion a) where - (<>) = liftA2 (<>) - -instance Monoid a => Monoid (Quaternion a) where - mempty = pure mempty -#if !(MIN_VERSION_base(4,11,0)) - mappend = liftA2 mappend -#endif - -instance R1 Quaternion where - _x f (Quaternion w (V3 x y z)) = f x <&> \x' -> Quaternion w (V3 x' y z) - -instance R2 Quaternion where - _y f (Quaternion w (V3 x y z)) = f y <&> \y' -> Quaternion w (V3 x y' z) - _xy f (Quaternion w (V3 x y z)) = f (V2 x y) <&> \(V2 x' y') -> Quaternion w (V3 x' y' z) - -instance R3 Quaternion where - _z f (Quaternion w (V3 x y z)) = f z <&> \z' -> Quaternion w (V3 x y z') - _xyz f (Quaternion w xyz) = Quaternion w <$> f xyz - -instance R4 Quaternion where - _w f (Quaternion w xyz) = f w <&> \w' -> Quaternion w' xyz - _xyzw f (Quaternion w (V3 x y z)) = f (V4 x y z w) <&> \(V4 x' y' z' w') -> Quaternion w' (V3 x' y' z') - +{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveLift #-}++#ifndef MIN_VERSION_hashable+#define MIN_VERSION_hashable(x,y,z) 1+#endif++#ifndef MIN_VERSION_vector+#define MIN_VERSION_vector(x,y,z) 1+#endif++#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1+#endif++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2012-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- Quaternions+----------------------------------------------------------------------------+module Linear.Quaternion+ ( Quaternion(..)+ , Complicated(..)+ , Hamiltonian(..)+ , ee, ei, ej, ek+ , slerp+ , asinq+ , acosq+ , atanq+ , asinhq+ , acoshq+ , atanhq+ , absi+ , pow+ , rotate+ , axisAngle+ ) where++import Control.Applicative+import Control.DeepSeq (NFData(rnf))+import Control.Monad (liftM)+import Control.Monad.Fix+import Control.Monad.Zip+import Control.Lens as Lens hiding ((<.>))+import Data.Binary as Binary+import Data.Bytes.Serial+import Data.Complex (Complex((:+)))+import Data.Data+import Data.Distributive+import Data.Foldable+import qualified Data.Foldable.WithIndex as WithIndex+import Data.Functor.Bind+import Data.Functor.Classes+import Data.Functor.Rep+import qualified Data.Functor.WithIndex as WithIndex+import Data.Hashable+import Data.Hashable.Lifted+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup(..))+#endif+import Data.Serialize as Cereal+import GHC.Arr (Ix(..))+import qualified Data.Foldable as F+import qualified Data.Traversable.WithIndex as WithIndex+import qualified Data.Vector as V+import qualified Data.Vector.Generic.Mutable as M+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Unboxed.Base as U+import Foreign.Ptr (castPtr, plusPtr)+import Foreign.Storable (Storable(..))+import GHC.Generics (Generic, Generic1)+#if defined(MIN_VERSION_template_haskell)+import Language.Haskell.TH.Syntax (Lift)+#endif+import Linear.Epsilon+import Linear.Conjugate+import Linear.Metric+import Linear.V+import Linear.V2+import Linear.V3+import Linear.V4+import Linear.Vector+import Prelude hiding (any)+import System.Random (Random(..))++-- | Quaternions+data Quaternion a = Quaternion !a {-# UNPACK #-}!(V3 a)+ deriving (Eq,Ord,Read,Show,Data+ ,Generic,Generic1+#if defined(MIN_VERSION_template_haskell)+ ,Lift+#endif+ )++instance Finite Quaternion where+ type Size Quaternion = 4+ toV (Quaternion a (V3 b c d)) = V (V.fromListN 4 [a, b, c, d])+ fromV (V v) = Quaternion (v V.! 0) (V3 (v V.! 1) (v V.! 2) (v V.! 3))++instance Random a => Random (Quaternion a) where+ random g = case random g of+ (a, g') -> case random g' of+ (b, g'') -> (Quaternion a b, g'')+ randomR (Quaternion a b, Quaternion c d) g = case randomR (a,c) g of+ (e, g') -> case randomR (b,d) g' of+ (f, g'') -> (Quaternion e f, g'')++instance Functor Quaternion where+ fmap f (Quaternion e v) = Quaternion (f e) (fmap f v)+ {-# INLINE fmap #-}+ a <$ _ = Quaternion a (V3 a a a)+ {-# INLINE (<$) #-}++instance Apply Quaternion where+ Quaternion f fv <.> Quaternion a v = Quaternion (f a) (fv <.> v)+ {-# INLINE (<.>) #-}++instance Applicative Quaternion where+ pure a = Quaternion a (pure a)+ {-# INLINE pure #-}+ Quaternion f fv <*> Quaternion a v = Quaternion (f a) (fv <*> v)+ {-# INLINE (<*>) #-}++instance Additive Quaternion where+ zero = pure 0+ {-# INLINE zero #-}+ liftU2 = liftA2+ {-# INLINE liftU2 #-}+ liftI2 = liftA2+ {-# INLINE liftI2 #-}++instance Bind Quaternion where+ Quaternion a (V3 b c d) >>- f = Quaternion a' (V3 b' c' d') where+ Quaternion a' _ = f a+ Quaternion _ (V3 b' _ _) = f b+ Quaternion _ (V3 _ c' _) = f c+ Quaternion _ (V3 _ _ d') = f d+ {-# INLINE (>>-) #-}++instance Monad Quaternion where+ return = pure+ {-# INLINE return #-}+ -- the diagonal of a sedenion is super useful!+ Quaternion a (V3 b c d) >>= f = Quaternion a' (V3 b' c' d') where+ Quaternion a' _ = f a+ Quaternion _ (V3 b' _ _) = f b+ Quaternion _ (V3 _ c' _) = f c+ Quaternion _ (V3 _ _ d') = f d+ {-# INLINE (>>=) #-}++instance Ix a => Ix (Quaternion a) where+ {-# SPECIALISE instance Ix (Quaternion Int) #-}++ range (Quaternion l1 l2, Quaternion u1 u2) =+ [ Quaternion i1 i2 | i1 <- range (l1,u1), i2 <- range (l2,u2) ]+ {-# INLINE range #-}++ unsafeIndex (Quaternion l1 l2, Quaternion u1 u2) (Quaternion i1 i2) =+ unsafeIndex (l1,u1) i1 * unsafeRangeSize (l2,u2) + unsafeIndex (l2,u2) i2+ {-# INLINE unsafeIndex #-}++ inRange (Quaternion l1 l2, Quaternion u1 u2) (Quaternion i1 i2) =+ inRange (l1,u1) i1 && inRange (l2,u2) i2+ {-# INLINE inRange #-}++instance Representable Quaternion where+ type Rep Quaternion = E Quaternion+ tabulate f = Quaternion (f ee) (V3 (f ei) (f ej) (f ek))+ {-# INLINE tabulate #-}+ index xs (E l) = view l xs+ {-# INLINE index #-}++instance WithIndex.FunctorWithIndex (E Quaternion) Quaternion where+ imap f (Quaternion a (V3 b c d)) = Quaternion (f ee a) $ V3 (f ei b) (f ej c) (f ek d)+ {-# INLINE imap #-}++instance WithIndex.FoldableWithIndex (E Quaternion) Quaternion where+ ifoldMap f (Quaternion a (V3 b c d)) = f ee a `mappend` f ei b `mappend` f ej c `mappend` f ek d+ {-# INLINE ifoldMap #-}++instance WithIndex.TraversableWithIndex (E Quaternion) Quaternion where+ itraverse f (Quaternion a (V3 b c d)) = Quaternion <$> f ee a <*> (V3 <$> f ei b <*> f ej c <*> f ek d)+ {-# INLINE itraverse #-}++#if !MIN_VERSION_lens(5,0,0)+instance Lens.FunctorWithIndex (E Quaternion) Quaternion where imap = WithIndex.imap+instance Lens.FoldableWithIndex (E Quaternion) Quaternion where ifoldMap = WithIndex.ifoldMap+instance Lens.TraversableWithIndex (E Quaternion) Quaternion where itraverse = WithIndex.itraverse+#endif++type instance Index (Quaternion a) = E Quaternion+type instance IxValue (Quaternion a) = a++instance Ixed (Quaternion a) where+ ix i = el i+ {-# INLINE ix #-}++instance Each (Quaternion a) (Quaternion b) a b where+ each = traverse+ {-# INLINE each #-}++instance Foldable Quaternion where+ foldMap f (Quaternion e v) = f e `mappend` foldMap f v+ {-# INLINE foldMap #-}+ foldr f z (Quaternion e v) = f e (F.foldr f z v)+ {-# INLINE foldr #-}+ null _ = False+ length _ = 4++instance Traversable Quaternion where+ traverse f (Quaternion e v) = Quaternion <$> f e <*> traverse f v+ {-# INLINE traverse #-}++instance Storable a => Storable (Quaternion a) where+ sizeOf _ = 4 * sizeOf (undefined::a)+ {-# INLINE sizeOf #-}+ alignment _ = alignment (undefined::a)+ {-# INLINE alignment #-}+ poke ptr (Quaternion e v) = poke (castPtr ptr) e >>+ poke (castPtr (ptr `plusPtr` sz)) v+ where sz = sizeOf (undefined::a)+ {-# INLINE poke #-}+ peek ptr = Quaternion <$> peek (castPtr ptr)+ <*> peek (castPtr (ptr `plusPtr` sz))+ where sz = sizeOf (undefined::a)+ {-# INLINE peek #-}++instance RealFloat a => Num (Quaternion a) where+ {-# SPECIALIZE instance Num (Quaternion Float) #-}+ {-# SPECIALIZE instance Num (Quaternion Double) #-}+ (+) = liftA2 (+)+ {-# INLINE (+) #-}+ (-) = liftA2 (-)+ {-# INLINE (-) #-}+ negate = fmap negate+ {-# INLINE negate #-}+ Quaternion s1 v1 * Quaternion s2 v2 = Quaternion (s1*s2 - (v1 `dot` v2)) $+ (v1 `cross` v2) + s1*^v2 + s2*^v1+ {-# INLINE (*) #-}+ fromInteger x = Quaternion (fromInteger x) 0+ {-# INLINE fromInteger #-}+ abs z = Quaternion (norm z) 0+ {-# INLINE abs #-}+ signum q@(Quaternion e (V3 i j k))+ | m == 0.0 = q+ | not (isInfinite m || isNaN m) = q ^/ sqrt m+ | any isNaN q = qNaN+ | not (ii || ij || ik) = Quaternion 1 (V3 0 0 0)+ | not (ie || ij || ik) = Quaternion 0 (V3 1 0 0)+ | not (ie || ii || ik) = Quaternion 0 (V3 0 1 0)+ | not (ie || ii || ij) = Quaternion 0 (V3 0 0 1)+ | otherwise = qNaN+ where+ m = quadrance q+ ie = isInfinite e+ ii = isInfinite i+ ij = isInfinite j+ ik = isInfinite k+ {-# INLINE signum #-}++instance Hashable a => Hashable (Quaternion a) where+ hashWithSalt s (Quaternion a b) = s `hashWithSalt` a `hashWithSalt` b+ {-# INLINE hashWithSalt #-}++instance Hashable1 Quaternion where+ liftHashWithSalt h s (Quaternion a b) = liftHashWithSalt h (h s a) b+ {-# INLINE liftHashWithSalt #-}++qNaN :: RealFloat a => Quaternion a+qNaN = Quaternion fNaN (V3 fNaN fNaN fNaN) where fNaN = 0/0+{-# INLINE qNaN #-}++-- {-# RULES "abs/norm" abs x = Quaternion (norm x) 0 #-}+-- {-# RULES "signum/signorm" signum = signorm #-}++-- this will attempt to rewrite calls to abs to use norm intead when it is available.++instance RealFloat a => Fractional (Quaternion a) where+ {-# SPECIALIZE instance Fractional (Quaternion Float) #-}+ {-# SPECIALIZE instance Fractional (Quaternion Double) #-}+ Quaternion q0 (V3 q1 q2 q3) / Quaternion r0 (V3 r1 r2 r3) =+ Quaternion (r0*q0+r1*q1+r2*q2+r3*q3)+ (V3 (r0*q1-r1*q0-r2*q3+r3*q2)+ (r0*q2+r1*q3-r2*q0-r3*q1)+ (r0*q3-r1*q2+r2*q1-r3*q0))+ ^/ (r0*r0 + r1*r1 + r2*r2 + r3*r3)+ {-# INLINE (/) #-}+ recip q@(Quaternion e v) = Quaternion e (negate v) ^/ quadrance q+ {-# INLINE recip #-}+ fromRational x = Quaternion (fromRational x) 0+ {-# INLINE fromRational #-}++instance Metric Quaternion where+ Quaternion e v `dot` Quaternion e' v' = e*e' + (v `dot` v')+ {-# INLINE dot #-}++-- | A vector space that includes the basis elements '_e' and '_i'+class Complicated t where+ _e, _i :: Lens' (t a) a++ee, ei :: Complicated t => E t+ee = E _e+ei = E _i++instance Complicated Complex where+ _e f (a :+ b) = (:+ b) <$> f a+ {-# INLINE _e #-}+ _i f (a :+ b) = (a :+) <$> f b+ {-# INLINE _i #-}++instance Complicated Quaternion where+ _e f (Quaternion a v) = (`Quaternion` v) <$> f a+ {-# INLINE _e #-}+ _i f (Quaternion a v) = Quaternion a <$> _x f v+ {-# INLINE _i #-}++-- | A vector space that includes the basis elements '_e', '_i', '_j' and '_k'+class Complicated t => Hamiltonian t where+ _j, _k :: Lens' (t a) a+ _ijk :: Lens' (t a) (V3 a)++ej, ek :: Hamiltonian t => E t+ej = E _j+ek = E _k++instance Hamiltonian Quaternion where+ _j f (Quaternion a v) = Quaternion a <$> _y f v+ {-# INLINE _j #-}+ _k f (Quaternion a v) = Quaternion a <$> _z f v+ {-# INLINE _k #-}+ _ijk f (Quaternion a v) = Quaternion a <$> f v+ {-# INLINE _ijk #-}++instance Distributive Quaternion where+ distribute f = Quaternion (fmap (\(Quaternion x _) -> x) f) $ V3+ (fmap (\(Quaternion _ (V3 y _ _)) -> y) f)+ (fmap (\(Quaternion _ (V3 _ z _)) -> z) f)+ (fmap (\(Quaternion _ (V3 _ _ w)) -> w) f)+ {-# INLINE distribute #-}++instance (Conjugate a, RealFloat a) => Conjugate (Quaternion a) where+ conjugate (Quaternion e v) = Quaternion (conjugate e) (negate v)+ {-# INLINE conjugate #-}++reimagine :: RealFloat a => a -> a -> Quaternion a -> Quaternion a+reimagine r s (Quaternion _ v)+ | isNaN s || isInfinite s = let aux 0 = 0+ aux x = s * x+ in Quaternion r (aux <$> v)+ | otherwise = Quaternion r (v^*s)+{-# INLINE reimagine #-}++-- | quadrance of the imaginary component+qi :: Num a => Quaternion a -> a+qi (Quaternion _ v) = quadrance v+{-# INLINE qi #-}++-- | norm of the imaginary component+absi :: Floating a => Quaternion a -> a+absi = sqrt . qi+{-# INLINE absi #-}++-- | raise a 'Quaternion' to a scalar power+pow :: RealFloat a => Quaternion a -> a -> Quaternion a+pow q t = exp (t *^ log q)+{-# INLINE pow #-}++sqrte2pqiq :: (Floating a, Ord a) => a -> a -> a+sqrte2pqiq e qiq -- = sqrt (e*e + qiq)+ | e < - 1.5097698010472593e153 = -(qiq/e) - e+ | e < 5.582399551122541e57 = sqrt (e*e + qiq) -- direct definition+ | otherwise = (qiq/e) + e+-- {-# SPECIALIZE sqrte2pqiq :: Double -> Double -> Double #-}+-- {-# SPECIALIZE sqrte2pqiq :: Float -> Float -> Float #-}+#ifdef HERBIE+{-# ANN sqrte2pqiq "NoHerbie" #-}+#endif++tanrhs :: (Floating a, Ord a) => a -> a -> a -> a+tanrhs sai ai d -- = cosh ai * (sai / ai) / d -- improved from 6.04 bits of error to 0.19 bits+ | sai < -4.618902267687042e-52 = (sai / d / ai) * cosh ai+ | sai < 1.038530535935153e-39 = (cosh ai * sai) / ai / d+ | otherwise = (sai / d / ai) * cosh ai+-- {-# SPECIALIZE tanrhs :: Double -> Double -> Double -> Double #-}+-- {-# SPECIALIZE tanrhs :: Float -> Float -> Float -> Float #-}+#ifdef HERBIE+{-# ANN tanrhs "NoHerbie" #-}+#endif+++-- ehh..+instance RealFloat a => Floating (Quaternion a) where+ {-# SPECIALIZE instance Floating (Quaternion Float) #-}+ {-# SPECIALIZE instance Floating (Quaternion Double) #-}+ pi = Quaternion pi 0+ {-# INLINE pi #-}+ exp q@(Quaternion e v)+ | qiq == 0 = Quaternion (exp e) v+ | ai <- sqrt qiq, exe <- exp e = reimagine (exe * cos ai) (exe * (sin ai / ai)) q+ where qiq = qi q+ {-# INLINE exp #-}+ log q@(Quaternion e v)+ | qiq == 0 = if e >= 0+ then Quaternion (log e) v -- Using v rather than 0 preserves negative zeros+ else Quaternion (negate (log (negate e))) v -- negative scalar: negate quaternion, take log, negate again, preserves negative zeros+ | ai <- sqrt qiq = reimagine (log m) (acos (e / m) / ai) q+ where qiq = qi q+ m = sqrte2pqiq e qiq+ {-# INLINE log #-}++ x ** y = exp (y * log x)+ {-# INLINE (**) #-}++ sqrt q@(Quaternion e v)+ | m == 0 = q+ | qiq == 0 = if e > 0+ then Quaternion (sqrt e) 0+ else Quaternion 0 (V3 (sqrt (negate e)) 0 0)+ | im <- sqrt (0.5*(m-e)) / sqrt qiq = Quaternion (0.5*(m+e)) (v^*im)+ where qiq = qi q+ m = sqrte2pqiq e qiq+ {-# INLINE sqrt #-}++ cos q@(Quaternion e v)+ | qiq == 0 = Quaternion (cos e) v+ | ai <- sqrt qiq = reimagine (cos e * cosh ai) (- sin e / ai / sinh ai) q -- 0.15 bits error+ where qiq = qi q+ {-# INLINE cos #-}++ sin q@(Quaternion e v)+ | qiq == 0 = Quaternion (sin e) v+ | ai <- sqrt qiq = reimagine (sin e * cosh ai) (cos e * sinh ai / ai) q+ where qiq = qi q+ {-# INLINE sin #-}++ tan q@(Quaternion e v)+ | qiq == 0 = Quaternion (tan e) v+ | ai <- sqrt qiq, ce <- cos e, sai <- sinh ai, d <- ce*ce + sai*sai =+ reimagine (ce * sin e / d) (tanrhs sai ai d) q+ where qiq = qi q+ {-# INLINE tan #-}++ sinh q@(Quaternion e v)+ | qiq == 0 = Quaternion (sinh e) v+ | ai <- sqrt qiq = reimagine (sinh e * cos ai) (cosh e * sin ai / ai) q+ where qiq = qi q+ {-# INLINE sinh #-}++ cosh q@(Quaternion e v)+ | qiq == 0 = Quaternion (cosh e) v+ | ai <- sqrt qiq = reimagine (cosh e * cos ai) (sin ai * (sinh e / ai)) q+ where qiq = qi q+ {-# INLINE cosh #-}++ tanh q@(Quaternion e v)+ | qiq == 0 = Quaternion (tanh e) v+ | ai <- sqrt qiq, se <- sinh e, cai <- cos ai, d <- se*se + cai*cai =+ reimagine (cosh e * se / d) (tanhrhs cai ai d) q+ where qiq = qi q+ {-# INLINE tanh #-}++ asin = cut asin+ {-# INLINE asin #-}+ acos = cut acos+ {-# INLINE acos #-}+ atan = cut atan+ {-# INLINE atan #-}++ asinh = cut asinh+ {-# INLINE asinh #-}+ acosh = cut acosh+ {-# INLINE acosh #-}+ atanh = cut atanh+ {-# INLINE atanh #-}++tanhrhs :: (Floating a, Ord a) => a -> a -> a -> a+tanhrhs cai ai d -- = cai * (sin ai / ai) / d+ | d >= -4.2173720203427147e-29 && d < 4.446702369113811e64 = cai / (d * (ai / sin ai))+ | otherwise = cai * (1 / ai / sin ai) / d+-- {-# SPECIALIZE tanhrhs :: Double -> Double -> Double -> Double #-}+-- {-# SPECIALIZE tanhrhs :: Float -> Float -> Float -> Float #-}+#ifdef HERBIE+{-# ANN tanhrhs "NoHerbie" #-}+#endif++-- | Helper for calculating with specific branch cuts+cut :: RealFloat a => (Complex a -> Complex a) -> Quaternion a -> Quaternion a+cut f q@(Quaternion e (V3 _ y z))+ | qiq == 0 = Quaternion a (V3 b y z)+ | otherwise = reimagine a (b / ai) q+ where qiq = qi q+ ai = sqrt qiq+ a :+ b = f (e :+ ai)+{-# INLINE cut #-}++-- | Helper for calculating with specific branch cuts+cutWith :: RealFloat a => Complex a -> Quaternion a -> Quaternion a+cutWith (r :+ im) q@(Quaternion e v)+ | e /= 0 || qiq == 0 || isNaN qiq || isInfinite qiq = error "bad cut"+ | s <- im / sqrt qiq = Quaternion r (v^*s)+ where qiq = qi q+{-# INLINE cutWith #-}++-- | 'asin' with a specified branch cut.+asinq :: RealFloat a => Quaternion a -> Quaternion a -> Quaternion a+asinq q@(Quaternion e _) u+ | qiq /= 0.0 || e >= -1 && e <= 1 = asin q+ | otherwise = cutWith (asin (e :+ sqrt qiq)) u+ where qiq = qi q+{-# INLINE asinq #-}++-- | 'acos' with a specified branch cut.+acosq :: RealFloat a => Quaternion a -> Quaternion a -> Quaternion a+acosq q@(Quaternion e _) u+ | qiq /= 0.0 || e >= -1 && e <= 1 = acos q+ | otherwise = cutWith (acos (e :+ sqrt qiq)) u+ where qiq = qi q+{-# INLINE acosq #-}++-- | 'atan' with a specified branch cut.+atanq :: RealFloat a => Quaternion a -> Quaternion a -> Quaternion a+atanq q@(Quaternion e _) u+ | e /= 0.0 || qiq >= -1 && qiq <= 1 = atan q+ | otherwise = cutWith (atan (e :+ sqrt qiq)) u+ where qiq = qi q+{-# INLINE atanq #-}++-- | 'asinh' with a specified branch cut.+asinhq :: RealFloat a => Quaternion a -> Quaternion a -> Quaternion a+asinhq q@(Quaternion e _) u+ | e /= 0.0 || qiq >= -1 && qiq <= 1 = asinh q+ | otherwise = cutWith (asinh (e :+ sqrt qiq)) u+ where qiq = qi q+{-# INLINE asinhq #-}++-- | 'acosh' with a specified branch cut.+acoshq :: RealFloat a => Quaternion a -> Quaternion a -> Quaternion a+acoshq q@(Quaternion e _) u+ | qiq /= 0.0 || e >= 1 = asinh q+ | otherwise = cutWith (acosh (e :+ sqrt qiq)) u+ where qiq = qi q+{-# INLINE acoshq #-}++-- | 'atanh' with a specified branch cut.+atanhq :: RealFloat a => Quaternion a -> Quaternion a -> Quaternion a+atanhq q@(Quaternion e _) u+ | qiq /= 0.0 || e > -1 && e < 1 = atanh q+ | otherwise = cutWith (atanh (e :+ sqrt qiq)) u+ where qiq = qi q+{-# INLINE atanhq #-}++-- | Spherical linear interpolation between two quaternions.++slerp :: RealFloat a => Quaternion a -> Quaternion a -> a -> Quaternion a+slerp q p t+ | 1.0 - cosphi < 1e-8 = q+ | otherwise = ((sin ((1-t)*phi) *^ q) + sin (t*phi) *^ f p) ^/ sin phi+ where+ dqp = dot q p+ (cosphi, f) = if dqp < 0 then (-dqp, negate) else (dqp, id)+ phi = acos cosphi+{-# SPECIALIZE slerp :: Quaternion Float -> Quaternion Float -> Float -> Quaternion Float #-}+{-# SPECIALIZE slerp :: Quaternion Double -> Quaternion Double -> Double -> Quaternion Double #-}++-- | Apply a rotation to a vector.+rotate :: (Conjugate a, RealFloat a) => Quaternion a -> V3 a -> V3 a+rotate q v = ijk where+ Quaternion _ ijk = q * Quaternion 0 v * conjugate q+{-# SPECIALIZE rotate :: Quaternion Float -> V3 Float -> V3 Float #-}+{-# SPECIALIZE rotate :: Quaternion Double -> V3 Double -> V3 Double #-}++instance (RealFloat a, Epsilon a) => Epsilon (Quaternion a) where+ nearZero = nearZero . quadrance+ {-# INLINE nearZero #-}++-- | @'axisAngle' axis theta@ builds a 'Quaternion' representing a+-- rotation of @theta@ radians about @axis@.+axisAngle :: (Epsilon a, Floating a) => V3 a -> a -> Quaternion a+axisAngle axis theta = Quaternion (cos half) (sin half *^ normalize axis)+ where half = theta / 2+{-# INLINE axisAngle #-}++data instance U.Vector (Quaternion a) = V_Quaternion !Int (U.Vector a)+data instance U.MVector s (Quaternion a) = MV_Quaternion !Int (U.MVector s a)+instance U.Unbox a => U.Unbox (Quaternion a)++instance U.Unbox a => M.MVector U.MVector (Quaternion a) where+ basicLength (MV_Quaternion n _) = n+ basicUnsafeSlice m n (MV_Quaternion _ v) = MV_Quaternion n (M.basicUnsafeSlice (4*m) (4*n) v)+ basicOverlaps (MV_Quaternion _ v) (MV_Quaternion _ u) = M.basicOverlaps v u+ basicUnsafeNew n = liftM (MV_Quaternion n) (M.basicUnsafeNew (4*n))+ basicUnsafeRead (MV_Quaternion _ v) i =+ do let o = 4*i+ x <- M.basicUnsafeRead v o+ y <- M.basicUnsafeRead v (o+1)+ z <- M.basicUnsafeRead v (o+2)+ w <- M.basicUnsafeRead v (o+3)+ return (Quaternion x (V3 y z w))+ basicUnsafeWrite (MV_Quaternion _ v) i (Quaternion x (V3 y z w)) =+ do let o = 4*i+ M.basicUnsafeWrite v o x+ M.basicUnsafeWrite v (o+1) y+ M.basicUnsafeWrite v (o+2) z+ M.basicUnsafeWrite v (o+3) w+ basicInitialize (MV_Quaternion _ v) = M.basicInitialize v++instance U.Unbox a => G.Vector U.Vector (Quaternion a) where+ basicUnsafeFreeze (MV_Quaternion n v) = liftM ( V_Quaternion n) (G.basicUnsafeFreeze v)+ basicUnsafeThaw ( V_Quaternion n v) = liftM (MV_Quaternion n) (G.basicUnsafeThaw v)+ basicLength ( V_Quaternion n _) = n+ basicUnsafeSlice m n (V_Quaternion _ v) = V_Quaternion n (G.basicUnsafeSlice (4*m) (4*n) v)+ basicUnsafeIndexM (V_Quaternion _ v) i =+ do let o = 4*i+ x <- G.basicUnsafeIndexM v o+ y <- G.basicUnsafeIndexM v (o+1)+ z <- G.basicUnsafeIndexM v (o+2)+ w <- G.basicUnsafeIndexM v (o+3)+ return (Quaternion x (V3 y z w))++instance MonadZip Quaternion where+ mzipWith = liftA2++instance MonadFix Quaternion where+ mfix f = Quaternion (let Quaternion a _ = f a in a)+ (V3 (let Quaternion _ (V3 a _ _) = f a in a)+ (let Quaternion _ (V3 _ a _) = f a in a)+ (let Quaternion _ (V3 _ _ a) = f a in a))++instance NFData a => NFData (Quaternion a) where+ rnf (Quaternion a b) = rnf a `seq` rnf b++instance Serial1 Quaternion where+ serializeWith f (Quaternion a b) = f a >> serializeWith f b+ deserializeWith f = Quaternion <$> f <*> deserializeWith f++instance Serial a => Serial (Quaternion a) where+ serialize = serializeWith serialize+ deserialize = deserializeWith deserialize++instance Binary a => Binary (Quaternion a) where+ put = serializeWith Binary.put+ get = deserializeWith Binary.get++instance Serialize a => Serialize (Quaternion a) where+ put = serializeWith Cereal.put+ get = deserializeWith Cereal.get++instance Eq1 Quaternion where+ liftEq f (Quaternion a b) (Quaternion c d) = f a c && liftEq f b d+instance Ord1 Quaternion where+ liftCompare f (Quaternion a b) (Quaternion c d) = f a c `mappend` liftCompare f b d+instance Show1 Quaternion where+ liftShowsPrec f g d (Quaternion a b) = showsBinaryWith f (liftShowsPrec f g) "Quaternion" d a b+instance Read1 Quaternion where+ liftReadsPrec f g = readsData $ readsBinaryWith f (liftReadsPrec f g) "Quaternion" Quaternion++instance Field1 (Quaternion a) (Quaternion a) a a where+ _1 f (Quaternion w xyz) = f w <&> \w' -> Quaternion w' xyz++instance Field2 (Quaternion a) (Quaternion a) a a where+ _2 f (Quaternion w (V3 x y z)) = f x <&> \x' -> Quaternion w (V3 x' y z)++instance Field3 (Quaternion a) (Quaternion a) a a where+ _3 f (Quaternion w (V3 x y z)) = f y <&> \y' -> Quaternion w (V3 x y' z)++instance Field4 (Quaternion a) (Quaternion a) a a where+ _4 f (Quaternion w (V3 x y z)) = f z <&> \z' -> Quaternion w (V3 x y z')++instance Semigroup a => Semigroup (Quaternion a) where+ (<>) = liftA2 (<>)++instance Monoid a => Monoid (Quaternion a) where+ mempty = pure mempty+#if !(MIN_VERSION_base(4,11,0))+ mappend = liftA2 mappend+#endif++instance R1 Quaternion where+ _x f (Quaternion w (V3 x y z)) = f x <&> \x' -> Quaternion w (V3 x' y z)++instance R2 Quaternion where+ _y f (Quaternion w (V3 x y z)) = f y <&> \y' -> Quaternion w (V3 x y' z)+ _xy f (Quaternion w (V3 x y z)) = f (V2 x y) <&> \(V2 x' y') -> Quaternion w (V3 x' y' z)++instance R3 Quaternion where+ _z f (Quaternion w (V3 x y z)) = f z <&> \z' -> Quaternion w (V3 x y z')+ _xyz f (Quaternion w xyz) = Quaternion w <$> f xyz++instance R4 Quaternion where+ _w f (Quaternion w xyz) = f w <&> \w' -> Quaternion w' xyz+ _xyzw f (Quaternion w (V3 x y z)) = f (V4 x y z w) <&> \(V4 x' y' z' w') -> Quaternion w' (V3 x' y' z')+
src/Linear/Trace.hs view
@@ -1,116 +1,116 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE Trustworthy #-} ---------------------------------------------------------------------------- --- | --- Copyright : (C) 2012-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : experimental --- Portability : non-portable --- --- Simple matrix operation for low-dimensional primitives. ---------------------------------------------------------------------------- -module Linear.Trace - ( Trace(..) - , frobenius - ) where - -import Control.Monad as Monad -import Linear.V0 -import Linear.V1 -import Linear.V2 -import Linear.V3 -import Linear.V4 -import Linear.Plucker -import Linear.Quaternion -import Linear.V -import Linear.Vector -import Data.Complex -import Data.Distributive -import Data.Foldable as Foldable -import Data.Functor.Bind as Bind -import Data.Functor.Compose -import Data.Functor.Product -import Data.Hashable -import Data.HashMap.Lazy -import Data.IntMap (IntMap) -import Data.Map (Map) - --- $setup --- >>> import Data.Complex --- >>> import Debug.SimpleReflect.Vars --- >>> import Linear.V2 - -class Functor m => Trace m where - -- | Compute the trace of a matrix - -- - -- >>> trace (V2 (V2 a b) (V2 c d)) - -- a + d - trace :: Num a => m (m a) -> a -#ifndef HLINT - default trace :: (Foldable m, Num a) => m (m a) -> a - trace = Foldable.sum . diagonal - {-# INLINE trace #-} -#endif - - -- | Compute the diagonal of a matrix - -- - -- >>> diagonal (V2 (V2 a b) (V2 c d)) - -- V2 a d - diagonal :: m (m a) -> m a -#ifndef HLINT - default diagonal :: Monad m => m (m a) -> m a - diagonal = Monad.join - {-# INLINE diagonal #-} -#endif - -instance Trace IntMap where - diagonal = Bind.join - {-# INLINE diagonal #-} - -instance Ord k => Trace (Map k) where - diagonal = Bind.join - {-# INLINE diagonal #-} - -instance (Eq k, Hashable k) => Trace (HashMap k) where - diagonal = Bind.join - {-# INLINE diagonal #-} - -instance Dim n => Trace (V n) -instance Trace V0 -instance Trace V1 -instance Trace V2 -instance Trace V3 -instance Trace V4 -instance Trace Plucker -instance Trace Quaternion - -instance Trace Complex where - trace ((a :+ _) :+ (_ :+ b)) = a + b - {-# INLINE trace #-} - diagonal ((a :+ _) :+ (_ :+ b)) = a :+ b - {-# INLINE diagonal #-} - -instance (Trace f, Trace g) => Trace (Product f g) where - trace (Pair xx yy) = trace (pfst <$> xx) + trace (psnd <$> yy) where - pfst (Pair x _) = x - psnd (Pair _ y) = y - {-# INLINE trace #-} - diagonal (Pair xx yy) = diagonal (pfst <$> xx) `Pair` diagonal (psnd <$> yy) where - pfst (Pair x _) = x - psnd (Pair _ y) = y - {-# INLINE diagonal #-} - -instance (Distributive g, Trace g, Trace f) => Trace (Compose g f) where - trace = trace . fmap (fmap trace . distribute) . getCompose . fmap getCompose - {-# INLINE trace #-} - diagonal = Compose . fmap diagonal . diagonal . fmap distribute . getCompose . fmap getCompose - {-# INLINE diagonal #-} - --- | Compute the <http://mathworld.wolfram.com/FrobeniusNorm.html Frobenius norm> of a matrix. -frobenius :: (Num a, Foldable f, Additive f, Additive g, Distributive g, Trace g) => f (g a) -> a -frobenius m = trace $ fmap (\ f' -> Foldable.foldl' (^+^) zero $ liftI2 (*^) f' m) (distribute m) +{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Trustworthy #-}+---------------------------------------------------------------------------+-- |+-- Copyright : (C) 2012-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- Simple matrix operation for low-dimensional primitives.+---------------------------------------------------------------------------+module Linear.Trace+ ( Trace(..)+ , frobenius+ ) where++import Control.Monad as Monad+import Linear.V0+import Linear.V1+import Linear.V2+import Linear.V3+import Linear.V4+import Linear.Plucker+import Linear.Quaternion+import Linear.V+import Linear.Vector+import Data.Complex+import Data.Distributive+import Data.Foldable as Foldable+import Data.Functor.Bind as Bind+import Data.Functor.Compose+import Data.Functor.Product+import Data.Hashable+import Data.HashMap.Lazy+import Data.IntMap (IntMap)+import Data.Map (Map)++-- $setup+-- >>> import Data.Complex+-- >>> import Debug.SimpleReflect.Vars+-- >>> import Linear.V2++class Functor m => Trace m where+ -- | Compute the trace of a matrix+ --+ -- >>> trace (V2 (V2 a b) (V2 c d))+ -- a + d+ trace :: Num a => m (m a) -> a+#ifndef HLINT+ default trace :: (Foldable m, Num a) => m (m a) -> a+ trace = Foldable.sum . diagonal+ {-# INLINE trace #-}+#endif++ -- | Compute the diagonal of a matrix+ --+ -- >>> diagonal (V2 (V2 a b) (V2 c d))+ -- V2 a d+ diagonal :: m (m a) -> m a+#ifndef HLINT+ default diagonal :: Monad m => m (m a) -> m a+ diagonal = Monad.join+ {-# INLINE diagonal #-}+#endif++instance Trace IntMap where+ diagonal = Bind.join+ {-# INLINE diagonal #-}++instance Ord k => Trace (Map k) where+ diagonal = Bind.join+ {-# INLINE diagonal #-}++instance (Eq k, Hashable k) => Trace (HashMap k) where+ diagonal = Bind.join+ {-# INLINE diagonal #-}++instance Dim n => Trace (V n)+instance Trace V0+instance Trace V1+instance Trace V2+instance Trace V3+instance Trace V4+instance Trace Plucker+instance Trace Quaternion++instance Trace Complex where+ trace ((a :+ _) :+ (_ :+ b)) = a + b+ {-# INLINE trace #-}+ diagonal ((a :+ _) :+ (_ :+ b)) = a :+ b+ {-# INLINE diagonal #-}++instance (Trace f, Trace g) => Trace (Product f g) where+ trace (Pair xx yy) = trace (pfst <$> xx) + trace (psnd <$> yy) where+ pfst (Pair x _) = x+ psnd (Pair _ y) = y+ {-# INLINE trace #-}+ diagonal (Pair xx yy) = diagonal (pfst <$> xx) `Pair` diagonal (psnd <$> yy) where+ pfst (Pair x _) = x+ psnd (Pair _ y) = y+ {-# INLINE diagonal #-}++instance (Distributive g, Trace g, Trace f) => Trace (Compose g f) where+ trace = trace . fmap (fmap trace . distribute) . getCompose . fmap getCompose+ {-# INLINE trace #-}+ diagonal = Compose . fmap diagonal . diagonal . fmap distribute . getCompose . fmap getCompose+ {-# INLINE diagonal #-}++-- | Compute the <http://mathworld.wolfram.com/FrobeniusNorm.html Frobenius norm> of a matrix.+frobenius :: (Num a, Foldable f, Additive f, Additive g, Distributive g, Trace g) => f (g a) -> a+frobenius m = trace $ fmap (\ f' -> Foldable.foldl' (^+^) zero $ liftI2 (*^) f' m) (distribute m)
src/Linear/V.hs view
@@ -1,600 +1,600 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE DeriveGeneric #-} - -#ifndef MIN_VERSION_hashable -#define MIN_VERSION_hashable(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_reflection -#define MIN_VERSION_reflection(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_transformers -#define MIN_VERSION_transformers(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_base -#define MIN_VERSION_base(x,y,z) 1 -#endif - ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2012-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : experimental --- Portability : non-portable --- --- n-D Vectors ----------------------------------------------------------------------------- - -module Linear.V - ( V(V,toVector) -#ifdef MIN_VERSION_template_haskell - , int -#endif - , dim - , Dim(..) - , reifyDim - , reifyVector - , reifyDimNat - , reifyVectorNat - , fromVector - , Finite(..) - , _V, _V' - ) where - -import Control.Applicative -import Control.DeepSeq (NFData) -import Control.Monad -import Control.Monad.Fix -import Control.Monad.Trans.State -import Control.Monad.Zip -import Control.Lens as Lens -import Data.Binary as Binary -import Data.Bytes.Serial -import Data.Complex -import Data.Data -import Data.Distributive -import Data.Foldable as Foldable -import qualified Data.Foldable.WithIndex as WithIndex -import Data.Functor.Bind -import Data.Functor.Classes -import Data.Functor.Rep as Rep -import qualified Data.Functor.WithIndex as WithIndex -import Data.Hashable -import Data.Hashable.Lifted -import Data.Kind -import Data.Reflection as R -import Data.Serialize as Cereal -import qualified Data.Traversable.WithIndex as WithIndex -import qualified Data.Vector as V -import Data.Vector (Vector) -import Data.Vector.Fusion.Util (Box(..)) -import qualified Data.Vector.Generic as G -import qualified Data.Vector.Unboxed as U -import qualified Data.Vector.Generic.Mutable as M -import Foreign.Ptr -import Foreign.Storable -import GHC.TypeLits -import GHC.Generics (Generic, Generic1) -#if !(MIN_VERSION_reflection(1,3,0)) && defined(MIN_VERSION_template_haskell) -import Language.Haskell.TH -#endif -import Linear.Epsilon -import Linear.Metric -import Linear.Vector -import Prelude as P -#if !(MIN_VERSION_base(4,11,0)) -import Data.Semigroup -#endif -import System.Random (Random(..)) - -class Dim n where - reflectDim :: p n -> Int - -type role V nominal representational - -class Finite v where - type Size (v :: Type -> Type) :: Nat -- this should allow kind k, for Reifies k Int - toV :: v a -> V (Size v) a - default toV :: Foldable v => v a -> V (Size v) a - toV = V . V.fromList . Foldable.toList - fromV :: V (Size v) a -> v a - -instance Finite Complex where - type Size Complex = 2 - toV (a :+ b) = V (V.fromListN 2 [a, b]) - fromV (V v) = (v V.! 0) :+ (v V.! 1) - -_V :: (Finite u, Finite v) => Iso (V (Size u) a) (V (Size v) b) (u a) (v b) -_V = iso fromV toV - -_V' :: Finite v => Iso (V (Size v) a) (V (Size v) b) (v a) (v b) -_V' = iso fromV toV - -instance Finite (V (n :: Nat)) where - type Size (V n) = n - toV = id - fromV = id - -newtype V n a = V { toVector :: V.Vector a } deriving (Eq,Ord,Show,Read,NFData - ,Generic,Generic1 - ) - -dim :: forall n a. Dim n => V n a -> Int -dim _ = reflectDim (Proxy :: Proxy n) -{-# INLINE dim #-} - -instance KnownNat n => Dim (n :: Nat) where - reflectDim = fromInteger . natVal - {-# INLINE reflectDim #-} - -instance (Dim n, Random a) => Random (V n a) where - random = runState (V <$> V.replicateM (reflectDim (Proxy :: Proxy n)) (state random)) - randomR (V ls,V hs) = runState (V <$> V.zipWithM (\l h -> state $ randomR (l,h)) ls hs) - -data ReifiedDim (s :: Type) - -retagDim :: (Proxy s -> a) -> proxy (ReifiedDim s) -> a -retagDim f _ = f Proxy -{-# INLINE retagDim #-} - -instance Reifies s Int => Dim (ReifiedDim s) where - reflectDim = retagDim reflect - {-# INLINE reflectDim #-} - -reifyDimNat :: Int -> (forall (n :: Nat). KnownNat n => Proxy n -> r) -> r -reifyDimNat i f = R.reifyNat (fromIntegral i) f -{-# INLINE reifyDimNat #-} - -reifyVectorNat :: forall a r. Vector a -> (forall (n :: Nat). KnownNat n => V n a -> r) -> r -reifyVectorNat v f = reifyNat (fromIntegral $ V.length v) $ \(Proxy :: Proxy n) -> f (V v :: V n a) -{-# INLINE reifyVectorNat #-} - -reifyDim :: Int -> (forall (n :: Type). Dim n => Proxy n -> r) -> r -reifyDim i f = R.reify i (go f) where - go :: (Proxy (ReifiedDim n) -> a) -> proxy n -> a - go g _ = g Proxy -{-# INLINE reifyDim #-} - -reifyVector :: forall a r. Vector a -> (forall (n :: Type). Dim n => V n a -> r) -> r -reifyVector v f = reifyDim (V.length v) $ \(Proxy :: Proxy n) -> f (V v :: V n a) -{-# INLINE reifyVector #-} - -instance Dim n => Dim (V n a) where - reflectDim _ = reflectDim (Proxy :: Proxy n) - {-# INLINE reflectDim #-} - -instance (Dim n, Semigroup a) => Semigroup (V n a) where - (<>) = liftA2 (<>) - -instance (Dim n, Monoid a) => Monoid (V n a) where - mempty = pure mempty -#if !(MIN_VERSION_base(4,11,0)) - mappend = liftA2 mappend -#endif - -instance Functor (V n) where - fmap f (V as) = V (fmap f as) - {-# INLINE fmap #-} - -instance WithIndex.FunctorWithIndex Int (V n) where - imap f (V as) = V (Lens.imap f as) - {-# INLINE imap #-} - -instance Foldable (V n) where - fold (V as) = fold as - {-# INLINE fold #-} - foldMap f (V as) = Foldable.foldMap f as - {-# INLINE foldMap #-} - foldr f z (V as) = V.foldr f z as - {-# INLINE foldr #-} - foldl f z (V as) = V.foldl f z as - {-# INLINE foldl #-} - foldr' f z (V as) = V.foldr' f z as - {-# INLINE foldr' #-} - foldl' f z (V as) = V.foldl' f z as - {-# INLINE foldl' #-} - foldr1 f (V as) = V.foldr1 f as - {-# INLINE foldr1 #-} - foldl1 f (V as) = V.foldl1 f as - {-# INLINE foldl1 #-} - length (V as) = V.length as - {-# INLINE length #-} - null (V as) = V.null as - {-# INLINE null #-} - toList (V as) = V.toList as - {-# INLINE toList #-} - elem a (V as) = V.elem a as - {-# INLINE elem #-} - maximum (V as) = V.maximum as - {-# INLINE maximum #-} - minimum (V as) = V.minimum as - {-# INLINE minimum #-} - sum (V as) = V.sum as - {-# INLINE sum #-} - product (V as) = V.product as - {-# INLINE product #-} - -instance WithIndex.FoldableWithIndex Int (V n) where - ifoldMap f (V as) = ifoldMap f as - {-# INLINE ifoldMap #-} - -instance Traversable (V n) where - traverse f (V as) = V <$> traverse f as - {-# INLINE traverse #-} - -instance WithIndex.TraversableWithIndex Int (V n) where - itraverse f (V as) = V <$> itraverse f as - {-# INLINE itraverse #-} - -#if !MIN_VERSION_lens(5,0,0) -instance Lens.FunctorWithIndex Int (V n) where imap = WithIndex.imap -instance Lens.FoldableWithIndex Int (V n) where ifoldMap = WithIndex.ifoldMap -instance Lens.TraversableWithIndex Int (V n) where itraverse = WithIndex.itraverse -#endif - -instance Apply (V n) where - V as <.> V bs = V (V.zipWith id as bs) - {-# INLINE (<.>) #-} - -instance Dim n => Applicative (V n) where - pure = V . V.replicate (reflectDim (Proxy :: Proxy n)) - {-# INLINE pure #-} - - V as <*> V bs = V (V.zipWith id as bs) - {-# INLINE (<*>) #-} - -instance Bind (V n) where - V as >>- f = V $ V.generate (V.length as) $ \i -> - toVector (f (as `V.unsafeIndex` i)) `V.unsafeIndex` i - {-# INLINE (>>-) #-} - -instance Dim n => Monad (V n) where -#if !(MIN_VERSION_base(4,11,0)) - return = V . V.replicate (reflectDim (Proxy :: Proxy n)) - {-# INLINE return #-} -#endif - V as >>= f = V $ V.generate (reflectDim (Proxy :: Proxy n)) $ \i -> - toVector (f (as `V.unsafeIndex` i)) `V.unsafeIndex` i - {-# INLINE (>>=) #-} - -instance Dim n => Additive (V n) where - zero = pure 0 - {-# INLINE zero #-} - liftU2 f (V as) (V bs) = V (V.zipWith f as bs) - {-# INLINE liftU2 #-} - liftI2 f (V as) (V bs) = V (V.zipWith f as bs) - {-# INLINE liftI2 #-} - -instance (Dim n, Num a) => Num (V n a) where - V as + V bs = V $ V.zipWith (+) as bs - {-# INLINE (+) #-} - V as - V bs = V $ V.zipWith (-) as bs - {-# INLINE (-) #-} - V as * V bs = V $ V.zipWith (*) as bs - {-# INLINE (*) #-} - negate = fmap negate - {-# INLINE negate #-} - abs = fmap abs - {-# INLINE abs #-} - signum = fmap signum - {-# INLINE signum #-} - fromInteger = pure . fromInteger - {-# INLINE fromInteger #-} - -instance (Dim n, Fractional a) => Fractional (V n a) where - recip = fmap recip - {-# INLINE recip #-} - V as / V bs = V $ V.zipWith (/) as bs - {-# INLINE (/) #-} - fromRational = pure . fromRational - {-# INLINE fromRational #-} - -instance (Dim n, Floating a) => Floating (V n a) where - pi = pure pi - {-# INLINE pi #-} - exp = fmap exp - {-# INLINE exp #-} - sqrt = fmap sqrt - {-# INLINE sqrt #-} - log = fmap log - {-# INLINE log #-} - V as ** V bs = V $ V.zipWith (**) as bs - {-# INLINE (**) #-} - logBase (V as) (V bs) = V $ V.zipWith logBase as bs - {-# INLINE logBase #-} - sin = fmap sin - {-# INLINE sin #-} - tan = fmap tan - {-# INLINE tan #-} - cos = fmap cos - {-# INLINE cos #-} - asin = fmap asin - {-# INLINE asin #-} - atan = fmap atan - {-# INLINE atan #-} - acos = fmap acos - {-# INLINE acos #-} - sinh = fmap sinh - {-# INLINE sinh #-} - tanh = fmap tanh - {-# INLINE tanh #-} - cosh = fmap cosh - {-# INLINE cosh #-} - asinh = fmap asinh - {-# INLINE asinh #-} - atanh = fmap atanh - {-# INLINE atanh #-} - acosh = fmap acosh - {-# INLINE acosh #-} - -instance Dim n => Distributive (V n) where - distribute f = V $ V.generate (reflectDim (Proxy :: Proxy n)) $ \i -> fmap (\(V v) -> V.unsafeIndex v i) f - {-# INLINE distribute #-} - -instance Hashable a => Hashable (V n a) where - hashWithSalt s0 (V v) = - V.foldl' (\s a -> s `hashWithSalt` a) s0 v - `hashWithSalt` V.length v - -instance Dim n => Hashable1 (V n) where - liftHashWithSalt h s0 (V v) = - V.foldl' (\s a -> h s a) s0 v - `hashWithSalt` V.length v - {-# INLINE liftHashWithSalt #-} - -instance (Dim n, Storable a) => Storable (V n a) where - sizeOf _ = reflectDim (Proxy :: Proxy n) * sizeOf (undefined:: a) - {-# INLINE sizeOf #-} - alignment _ = alignment (undefined :: a) - {-# INLINE alignment #-} - poke ptr (V xs) = Foldable.forM_ [0..reflectDim (Proxy :: Proxy n)-1] $ \i -> - pokeElemOff ptr' i (V.unsafeIndex xs i) - where ptr' = castPtr ptr - {-# INLINE poke #-} - peek ptr = V <$> V.generateM (reflectDim (Proxy :: Proxy n)) (peekElemOff ptr') - where ptr' = castPtr ptr - {-# INLINE peek #-} - -instance (Dim n, Epsilon a) => Epsilon (V n a) where - nearZero = nearZero . quadrance - {-# INLINE nearZero #-} - -instance Dim n => Metric (V n) where - dot (V a) (V b) = V.sum $ V.zipWith (*) a b - {-# INLINE dot #-} - --- TODO: instance (Dim n, Ix a) => Ix (V n a) - -fromVector :: forall n a. Dim n => Vector a -> Maybe (V n a) -fromVector v - | V.length v == reflectDim (Proxy :: Proxy n) = Just (V v) - | otherwise = Nothing - -#if !(MIN_VERSION_reflection(1,3,0)) && defined(MIN_VERSION_template_haskell) -data Z -- 0 -data D (n :: *) -- 2n -data SD (n :: *) -- 2n+1 -data PD (n :: *) -- 2n-1 - -instance Reifies Z Int where - reflect _ = 0 - {-# INLINE reflect #-} - -retagD :: (Proxy n -> a) -> proxy (D n) -> a -retagD f _ = f Proxy -{-# INLINE retagD #-} - -retagSD :: (Proxy n -> a) -> proxy (SD n) -> a -retagSD f _ = f Proxy -{-# INLINE retagSD #-} - -retagPD :: (Proxy n -> a) -> proxy (PD n) -> a -retagPD f _ = f Proxy -{-# INLINE retagPD #-} - -instance Reifies n Int => Reifies (D n) Int where - reflect = (\n -> n+n) <$> retagD reflect - {-# INLINE reflect #-} - -instance Reifies n Int => Reifies (SD n) Int where - reflect = (\n -> n+n+1) <$> retagSD reflect - {-# INLINE reflect #-} - -instance Reifies n Int => Reifies (PD n) Int where - reflect = (\n -> n+n-1) <$> retagPD reflect - {-# INLINE reflect #-} - --- | This can be used to generate a template haskell splice for a type level version of a given 'int'. --- --- This does not use GHC TypeLits, instead it generates a numeric type by hand similar to the ones used --- in the \"Functional Pearl: Implicit Dimurations\" paper by Oleg Kiselyov and Chung-Chieh Shan. -int :: Int -> TypeQ -int n = case quotRem n 2 of - (0, 0) -> conT ''Z - (q,-1) -> conT ''PD `appT` int q - (q, 0) -> conT ''D `appT` int q - (q, 1) -> conT ''SD `appT` int q - _ -> error "ghc is bad at math" -#endif - -instance Dim n => Representable (V n) where - type Rep (V n) = Int - tabulate = V . V.generate (reflectDim (Proxy :: Proxy n)) - {-# INLINE tabulate #-} - index (V xs) i = xs V.! i - {-# INLINE index #-} - -type instance Index (V n a) = Int -type instance IxValue (V n a) = a - -instance Ixed (V n a) where - ix i f v@(V as) - | i < 0 || i >= V.length as = pure v - | otherwise = vLens i f v - {-# INLINE ix #-} - -instance Dim n => MonadZip (V n) where - mzip (V as) (V bs) = V $ V.zip as bs - mzipWith f (V as) (V bs) = V $ V.zipWith f as bs - -instance Dim n => MonadFix (V n) where - mfix f = tabulate $ \r -> let a = Rep.index (f a) r in a - -instance Each (V n a) (V n b) a b where - each = traverse - {-# INLINE each #-} - -instance (Bounded a, Dim n) => Bounded (V n a) where - minBound = pure minBound - {-# INLINE minBound #-} - maxBound = pure maxBound - {-# INLINE maxBound #-} - -vConstr :: Constr -vConstr = mkConstr vDataType "variadic" [] Prefix -{-# NOINLINE vConstr #-} - -vDataType :: DataType -vDataType = mkDataType "Linear.V.V" [vConstr] -{-# NOINLINE vDataType #-} - -instance (Typeable (V n), Typeable (V n a), Dim n, Data a) => Data (V n a) where - gfoldl f z (V as) = z (V . V.fromList) `f` V.toList as - toConstr _ = vConstr - gunfold k z c = case constrIndex c of - 1 -> k (z (V . V.fromList)) - _ -> error "gunfold" - dataTypeOf _ = vDataType - dataCast1 f = gcast1 f - -instance Dim n => Serial1 (V n) where - serializeWith = traverse_ - deserializeWith f = sequenceA $ pure f - -instance (Dim n, Serial a) => Serial (V n a) where - serialize = traverse_ serialize - deserialize = sequenceA $ pure deserialize - -instance (Dim n, Binary a) => Binary (V n a) where - put = serializeWith Binary.put - get = deserializeWith Binary.get - -instance (Dim n, Serialize a) => Serialize (V n a) where - put = serializeWith Cereal.put - get = deserializeWith Cereal.get - -instance Eq1 (V n) where - liftEq f0 (V as0) (V bs0) = go f0 (V.toList as0) (V.toList bs0) where - go _ [] [] = True - go f (a:as) (b:bs) = f a b && go f as bs - go _ _ _ = False - -instance Ord1 (V n) where - liftCompare f0 (V as0) (V bs0) = go f0 (V.toList as0) (V.toList bs0) where - go f (a:as) (b:bs) = f a b `mappend` go f as bs - go _ [] [] = EQ - go _ _ [] = GT - go _ [] _ = LT - -instance Show1 (V n) where - liftShowsPrec _ g d (V as) = showParen (d > 10) $ showString "V " . g (V.toList as) - -instance Dim n => Read1 (V n) where - liftReadsPrec _ g d = readParen (d > 10) $ \r -> - [ (V (V.fromList as), r2) - | ("V",r1) <- lex r - , (as, r2) <- g r1 - , P.length as == reflectDim (Proxy :: Proxy n) - ] - -data instance U.Vector (V n a) = V_VN {-# UNPACK #-} !Int !(U.Vector a) -data instance U.MVector s (V n a) = MV_VN {-# UNPACK #-} !Int !(U.MVector s a) -instance (Dim n, U.Unbox a) => U.Unbox (V n a) - -instance (Dim n, U.Unbox a) => M.MVector U.MVector (V n a) where - {-# INLINE basicLength #-} - {-# INLINE basicUnsafeSlice #-} - {-# INLINE basicOverlaps #-} - {-# INLINE basicUnsafeNew #-} - {-# INLINE basicUnsafeRead #-} - {-# INLINE basicUnsafeWrite #-} - basicLength (MV_VN n _) = n - basicUnsafeSlice m n (MV_VN _ v) = MV_VN n (M.basicUnsafeSlice (d*m) (d*n) v) - where d = reflectDim (Proxy :: Proxy n) - basicOverlaps (MV_VN _ v) (MV_VN _ u) = M.basicOverlaps v u - basicUnsafeNew n = liftM (MV_VN n) (M.basicUnsafeNew (d*n)) - where d = reflectDim (Proxy :: Proxy n) - basicUnsafeRead (MV_VN _ v) i = - liftM V $ V.generateM d (\j -> M.basicUnsafeRead v (d*i+j)) - where d = reflectDim (Proxy :: Proxy n) - basicUnsafeWrite (MV_VN _ v0) i (V vn0) = let d0 = V.length vn0 in go v0 vn0 d0 (d0*i) 0 - where - go v vn d o j - | j >= d = return () - | otherwise = do - a <- liftBox $ G.basicUnsafeIndexM vn j - M.basicUnsafeWrite v o a - go v vn d (o+1) (j+1) - basicInitialize (MV_VN _ v) = M.basicInitialize v - {-# INLINE basicInitialize #-} - -liftBox :: Monad m => Box a -> m a -liftBox (Box a) = return a -{-# INLINE liftBox #-} - -instance (Dim n, U.Unbox a) => G.Vector U.Vector (V n a) where - {-# INLINE basicUnsafeFreeze #-} - {-# INLINE basicUnsafeThaw #-} - {-# INLINE basicLength #-} - {-# INLINE basicUnsafeSlice #-} - {-# INLINE basicUnsafeIndexM #-} - basicUnsafeFreeze (MV_VN n v) = liftM ( V_VN n) (G.basicUnsafeFreeze v) - basicUnsafeThaw ( V_VN n v) = liftM (MV_VN n) (G.basicUnsafeThaw v) - basicLength ( V_VN n _) = n - basicUnsafeSlice m n (V_VN _ v) = V_VN n (G.basicUnsafeSlice (d*m) (d*n) v) - where d = reflectDim (Proxy :: Proxy n) - basicUnsafeIndexM (V_VN _ v) i = - liftM V $ V.generateM d (\j -> G.basicUnsafeIndexM v (d*i+j)) - where d = reflectDim (Proxy :: Proxy n) - -vLens :: Int -> Lens' (V n a) a -vLens i = \f (V v) -> f (v V.! i) <&> \a -> V (v V.// [(i, a)]) -{-# INLINE vLens #-} - -instance ( 1 <= n) => Field1 (V n a) (V n a) a a where _1 = vLens 0 -instance ( 2 <= n) => Field2 (V n a) (V n a) a a where _2 = vLens 1 -instance ( 3 <= n) => Field3 (V n a) (V n a) a a where _3 = vLens 2 -instance ( 4 <= n) => Field4 (V n a) (V n a) a a where _4 = vLens 3 -instance ( 5 <= n) => Field5 (V n a) (V n a) a a where _5 = vLens 4 -instance ( 6 <= n) => Field6 (V n a) (V n a) a a where _6 = vLens 5 -instance ( 7 <= n) => Field7 (V n a) (V n a) a a where _7 = vLens 6 -instance ( 8 <= n) => Field8 (V n a) (V n a) a a where _8 = vLens 7 -instance ( 9 <= n) => Field9 (V n a) (V n a) a a where _9 = vLens 8 -instance (10 <= n) => Field10 (V n a) (V n a) a a where _10 = vLens 9 -instance (11 <= n) => Field11 (V n a) (V n a) a a where _11 = vLens 10 -instance (12 <= n) => Field12 (V n a) (V n a) a a where _12 = vLens 11 -instance (13 <= n) => Field13 (V n a) (V n a) a a where _13 = vLens 12 -instance (14 <= n) => Field14 (V n a) (V n a) a a where _14 = vLens 13 -instance (15 <= n) => Field15 (V n a) (V n a) a a where _15 = vLens 14 -instance (16 <= n) => Field16 (V n a) (V n a) a a where _16 = vLens 15 -instance (17 <= n) => Field17 (V n a) (V n a) a a where _17 = vLens 16 -instance (18 <= n) => Field18 (V n a) (V n a) a a where _18 = vLens 17 -instance (19 <= n) => Field19 (V n a) (V n a) a a where _19 = vLens 18 +{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE DeriveGeneric #-}++#ifndef MIN_VERSION_hashable+#define MIN_VERSION_hashable(x,y,z) 1+#endif++#ifndef MIN_VERSION_reflection+#define MIN_VERSION_reflection(x,y,z) 1+#endif++#ifndef MIN_VERSION_transformers+#define MIN_VERSION_transformers(x,y,z) 1+#endif++#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1+#endif++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2012-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- n-D Vectors+----------------------------------------------------------------------------++module Linear.V+ ( V(V,toVector)+#ifdef MIN_VERSION_template_haskell+ , int+#endif+ , dim+ , Dim(..)+ , reifyDim+ , reifyVector+ , reifyDimNat+ , reifyVectorNat+ , fromVector+ , Finite(..)+ , _V, _V'+ ) where++import Control.Applicative+import Control.DeepSeq (NFData)+import Control.Monad+import Control.Monad.Fix+import Control.Monad.Trans.State+import Control.Monad.Zip+import Control.Lens as Lens+import Data.Binary as Binary+import Data.Bytes.Serial+import Data.Complex+import Data.Data+import Data.Distributive+import Data.Foldable as Foldable+import qualified Data.Foldable.WithIndex as WithIndex+import Data.Functor.Bind+import Data.Functor.Classes+import Data.Functor.Rep as Rep+import qualified Data.Functor.WithIndex as WithIndex+import Data.Hashable+import Data.Hashable.Lifted+import Data.Kind+import Data.Reflection as R+import Data.Serialize as Cereal+import qualified Data.Traversable.WithIndex as WithIndex+import qualified Data.Vector as V+import Data.Vector (Vector)+import Data.Vector.Fusion.Util (Box(..))+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Generic.Mutable as M+import Foreign.Ptr+import Foreign.Storable+import GHC.TypeLits+import GHC.Generics (Generic, Generic1)+#if !(MIN_VERSION_reflection(1,3,0)) && defined(MIN_VERSION_template_haskell)+import Language.Haskell.TH+#endif+import Linear.Epsilon+import Linear.Metric+import Linear.Vector+import Prelude as P+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup+#endif+import System.Random (Random(..))++class Dim n where+ reflectDim :: p n -> Int++type role V nominal representational++class Finite v where+ type Size (v :: Type -> Type) :: Nat -- this should allow kind k, for Reifies k Int+ toV :: v a -> V (Size v) a+ default toV :: Foldable v => v a -> V (Size v) a+ toV = V . V.fromList . Foldable.toList+ fromV :: V (Size v) a -> v a++instance Finite Complex where+ type Size Complex = 2+ toV (a :+ b) = V (V.fromListN 2 [a, b])+ fromV (V v) = (v V.! 0) :+ (v V.! 1)++_V :: (Finite u, Finite v) => Iso (V (Size u) a) (V (Size v) b) (u a) (v b)+_V = iso fromV toV++_V' :: Finite v => Iso (V (Size v) a) (V (Size v) b) (v a) (v b)+_V' = iso fromV toV++instance Finite (V (n :: Nat)) where+ type Size (V n) = n+ toV = id+ fromV = id++newtype V n a = V { toVector :: V.Vector a } deriving (Eq,Ord,Show,Read,NFData+ ,Generic,Generic1+ )++dim :: forall n a. Dim n => V n a -> Int+dim _ = reflectDim (Proxy :: Proxy n)+{-# INLINE dim #-}++instance KnownNat n => Dim (n :: Nat) where+ reflectDim = fromInteger . natVal+ {-# INLINE reflectDim #-}++instance (Dim n, Random a) => Random (V n a) where+ random = runState (V <$> V.replicateM (reflectDim (Proxy :: Proxy n)) (state random))+ randomR (V ls,V hs) = runState (V <$> V.zipWithM (\l h -> state $ randomR (l,h)) ls hs)++data ReifiedDim (s :: Type)++retagDim :: (Proxy s -> a) -> proxy (ReifiedDim s) -> a+retagDim f _ = f Proxy+{-# INLINE retagDim #-}++instance Reifies s Int => Dim (ReifiedDim s) where+ reflectDim = retagDim reflect+ {-# INLINE reflectDim #-}++reifyDimNat :: Int -> (forall (n :: Nat). KnownNat n => Proxy n -> r) -> r+reifyDimNat i f = R.reifyNat (fromIntegral i) f+{-# INLINE reifyDimNat #-}++reifyVectorNat :: forall a r. Vector a -> (forall (n :: Nat). KnownNat n => V n a -> r) -> r+reifyVectorNat v f = reifyNat (fromIntegral $ V.length v) $ \(Proxy :: Proxy n) -> f (V v :: V n a)+{-# INLINE reifyVectorNat #-}++reifyDim :: Int -> (forall (n :: Type). Dim n => Proxy n -> r) -> r+reifyDim i f = R.reify i (go f) where+ go :: (Proxy (ReifiedDim n) -> a) -> proxy n -> a+ go g _ = g Proxy+{-# INLINE reifyDim #-}++reifyVector :: forall a r. Vector a -> (forall (n :: Type). Dim n => V n a -> r) -> r+reifyVector v f = reifyDim (V.length v) $ \(Proxy :: Proxy n) -> f (V v :: V n a)+{-# INLINE reifyVector #-}++instance Dim n => Dim (V n a) where+ reflectDim _ = reflectDim (Proxy :: Proxy n)+ {-# INLINE reflectDim #-}++instance (Dim n, Semigroup a) => Semigroup (V n a) where+ (<>) = liftA2 (<>)++instance (Dim n, Monoid a) => Monoid (V n a) where+ mempty = pure mempty+#if !(MIN_VERSION_base(4,11,0))+ mappend = liftA2 mappend+#endif++instance Functor (V n) where+ fmap f (V as) = V (fmap f as)+ {-# INLINE fmap #-}++instance WithIndex.FunctorWithIndex Int (V n) where+ imap f (V as) = V (Lens.imap f as)+ {-# INLINE imap #-}++instance Foldable (V n) where+ fold (V as) = fold as+ {-# INLINE fold #-}+ foldMap f (V as) = Foldable.foldMap f as+ {-# INLINE foldMap #-}+ foldr f z (V as) = V.foldr f z as+ {-# INLINE foldr #-}+ foldl f z (V as) = V.foldl f z as+ {-# INLINE foldl #-}+ foldr' f z (V as) = V.foldr' f z as+ {-# INLINE foldr' #-}+ foldl' f z (V as) = V.foldl' f z as+ {-# INLINE foldl' #-}+ foldr1 f (V as) = V.foldr1 f as+ {-# INLINE foldr1 #-}+ foldl1 f (V as) = V.foldl1 f as+ {-# INLINE foldl1 #-}+ length (V as) = V.length as+ {-# INLINE length #-}+ null (V as) = V.null as+ {-# INLINE null #-}+ toList (V as) = V.toList as+ {-# INLINE toList #-}+ elem a (V as) = V.elem a as+ {-# INLINE elem #-}+ maximum (V as) = V.maximum as+ {-# INLINE maximum #-}+ minimum (V as) = V.minimum as+ {-# INLINE minimum #-}+ sum (V as) = V.sum as+ {-# INLINE sum #-}+ product (V as) = V.product as+ {-# INLINE product #-}++instance WithIndex.FoldableWithIndex Int (V n) where+ ifoldMap f (V as) = ifoldMap f as+ {-# INLINE ifoldMap #-}++instance Traversable (V n) where+ traverse f (V as) = V <$> traverse f as+ {-# INLINE traverse #-}++instance WithIndex.TraversableWithIndex Int (V n) where+ itraverse f (V as) = V <$> itraverse f as+ {-# INLINE itraverse #-}++#if !MIN_VERSION_lens(5,0,0)+instance Lens.FunctorWithIndex Int (V n) where imap = WithIndex.imap+instance Lens.FoldableWithIndex Int (V n) where ifoldMap = WithIndex.ifoldMap+instance Lens.TraversableWithIndex Int (V n) where itraverse = WithIndex.itraverse+#endif++instance Apply (V n) where+ V as <.> V bs = V (V.zipWith id as bs)+ {-# INLINE (<.>) #-}++instance Dim n => Applicative (V n) where+ pure = V . V.replicate (reflectDim (Proxy :: Proxy n))+ {-# INLINE pure #-}++ V as <*> V bs = V (V.zipWith id as bs)+ {-# INLINE (<*>) #-}++instance Bind (V n) where+ V as >>- f = V $ V.generate (V.length as) $ \i ->+ toVector (f (as `V.unsafeIndex` i)) `V.unsafeIndex` i+ {-# INLINE (>>-) #-}++instance Dim n => Monad (V n) where+#if !(MIN_VERSION_base(4,11,0))+ return = V . V.replicate (reflectDim (Proxy :: Proxy n))+ {-# INLINE return #-}+#endif+ V as >>= f = V $ V.generate (reflectDim (Proxy :: Proxy n)) $ \i ->+ toVector (f (as `V.unsafeIndex` i)) `V.unsafeIndex` i+ {-# INLINE (>>=) #-}++instance Dim n => Additive (V n) where+ zero = pure 0+ {-# INLINE zero #-}+ liftU2 f (V as) (V bs) = V (V.zipWith f as bs)+ {-# INLINE liftU2 #-}+ liftI2 f (V as) (V bs) = V (V.zipWith f as bs)+ {-# INLINE liftI2 #-}++instance (Dim n, Num a) => Num (V n a) where+ V as + V bs = V $ V.zipWith (+) as bs+ {-# INLINE (+) #-}+ V as - V bs = V $ V.zipWith (-) as bs+ {-# INLINE (-) #-}+ V as * V bs = V $ V.zipWith (*) as bs+ {-# INLINE (*) #-}+ negate = fmap negate+ {-# INLINE negate #-}+ abs = fmap abs+ {-# INLINE abs #-}+ signum = fmap signum+ {-# INLINE signum #-}+ fromInteger = pure . fromInteger+ {-# INLINE fromInteger #-}++instance (Dim n, Fractional a) => Fractional (V n a) where+ recip = fmap recip+ {-# INLINE recip #-}+ V as / V bs = V $ V.zipWith (/) as bs+ {-# INLINE (/) #-}+ fromRational = pure . fromRational+ {-# INLINE fromRational #-}++instance (Dim n, Floating a) => Floating (V n a) where+ pi = pure pi+ {-# INLINE pi #-}+ exp = fmap exp+ {-# INLINE exp #-}+ sqrt = fmap sqrt+ {-# INLINE sqrt #-}+ log = fmap log+ {-# INLINE log #-}+ V as ** V bs = V $ V.zipWith (**) as bs+ {-# INLINE (**) #-}+ logBase (V as) (V bs) = V $ V.zipWith logBase as bs+ {-# INLINE logBase #-}+ sin = fmap sin+ {-# INLINE sin #-}+ tan = fmap tan+ {-# INLINE tan #-}+ cos = fmap cos+ {-# INLINE cos #-}+ asin = fmap asin+ {-# INLINE asin #-}+ atan = fmap atan+ {-# INLINE atan #-}+ acos = fmap acos+ {-# INLINE acos #-}+ sinh = fmap sinh+ {-# INLINE sinh #-}+ tanh = fmap tanh+ {-# INLINE tanh #-}+ cosh = fmap cosh+ {-# INLINE cosh #-}+ asinh = fmap asinh+ {-# INLINE asinh #-}+ atanh = fmap atanh+ {-# INLINE atanh #-}+ acosh = fmap acosh+ {-# INLINE acosh #-}++instance Dim n => Distributive (V n) where+ distribute f = V $ V.generate (reflectDim (Proxy :: Proxy n)) $ \i -> fmap (\(V v) -> V.unsafeIndex v i) f+ {-# INLINE distribute #-}++instance Hashable a => Hashable (V n a) where+ hashWithSalt s0 (V v) =+ V.foldl' (\s a -> s `hashWithSalt` a) s0 v+ `hashWithSalt` V.length v++instance Dim n => Hashable1 (V n) where+ liftHashWithSalt h s0 (V v) =+ V.foldl' (\s a -> h s a) s0 v+ `hashWithSalt` V.length v+ {-# INLINE liftHashWithSalt #-}++instance (Dim n, Storable a) => Storable (V n a) where+ sizeOf _ = reflectDim (Proxy :: Proxy n) * sizeOf (undefined:: a)+ {-# INLINE sizeOf #-}+ alignment _ = alignment (undefined :: a)+ {-# INLINE alignment #-}+ poke ptr (V xs) = Foldable.forM_ [0..reflectDim (Proxy :: Proxy n)-1] $ \i ->+ pokeElemOff ptr' i (V.unsafeIndex xs i)+ where ptr' = castPtr ptr+ {-# INLINE poke #-}+ peek ptr = V <$> V.generateM (reflectDim (Proxy :: Proxy n)) (peekElemOff ptr')+ where ptr' = castPtr ptr+ {-# INLINE peek #-}++instance (Dim n, Epsilon a) => Epsilon (V n a) where+ nearZero = nearZero . quadrance+ {-# INLINE nearZero #-}++instance Dim n => Metric (V n) where+ dot (V a) (V b) = V.sum $ V.zipWith (*) a b+ {-# INLINE dot #-}++-- TODO: instance (Dim n, Ix a) => Ix (V n a)++fromVector :: forall n a. Dim n => Vector a -> Maybe (V n a)+fromVector v+ | V.length v == reflectDim (Proxy :: Proxy n) = Just (V v)+ | otherwise = Nothing++#if !(MIN_VERSION_reflection(1,3,0)) && defined(MIN_VERSION_template_haskell)+data Z -- 0+data D (n :: *) -- 2n+data SD (n :: *) -- 2n+1+data PD (n :: *) -- 2n-1++instance Reifies Z Int where+ reflect _ = 0+ {-# INLINE reflect #-}++retagD :: (Proxy n -> a) -> proxy (D n) -> a+retagD f _ = f Proxy+{-# INLINE retagD #-}++retagSD :: (Proxy n -> a) -> proxy (SD n) -> a+retagSD f _ = f Proxy+{-# INLINE retagSD #-}++retagPD :: (Proxy n -> a) -> proxy (PD n) -> a+retagPD f _ = f Proxy+{-# INLINE retagPD #-}++instance Reifies n Int => Reifies (D n) Int where+ reflect = (\n -> n+n) <$> retagD reflect+ {-# INLINE reflect #-}++instance Reifies n Int => Reifies (SD n) Int where+ reflect = (\n -> n+n+1) <$> retagSD reflect+ {-# INLINE reflect #-}++instance Reifies n Int => Reifies (PD n) Int where+ reflect = (\n -> n+n-1) <$> retagPD reflect+ {-# INLINE reflect #-}++-- | This can be used to generate a template haskell splice for a type level version of a given 'int'.+--+-- This does not use GHC TypeLits, instead it generates a numeric type by hand similar to the ones used+-- in the \"Functional Pearl: Implicit Dimurations\" paper by Oleg Kiselyov and Chung-Chieh Shan.+int :: Int -> TypeQ+int n = case quotRem n 2 of+ (0, 0) -> conT ''Z+ (q,-1) -> conT ''PD `appT` int q+ (q, 0) -> conT ''D `appT` int q+ (q, 1) -> conT ''SD `appT` int q+ _ -> error "ghc is bad at math"+#endif++instance Dim n => Representable (V n) where+ type Rep (V n) = Int+ tabulate = V . V.generate (reflectDim (Proxy :: Proxy n))+ {-# INLINE tabulate #-}+ index (V xs) i = xs V.! i+ {-# INLINE index #-}++type instance Index (V n a) = Int+type instance IxValue (V n a) = a++instance Ixed (V n a) where+ ix i f v@(V as)+ | i < 0 || i >= V.length as = pure v+ | otherwise = vLens i f v+ {-# INLINE ix #-}++instance Dim n => MonadZip (V n) where+ mzip (V as) (V bs) = V $ V.zip as bs+ mzipWith f (V as) (V bs) = V $ V.zipWith f as bs++instance Dim n => MonadFix (V n) where+ mfix f = tabulate $ \r -> let a = Rep.index (f a) r in a++instance Each (V n a) (V n b) a b where+ each = traverse+ {-# INLINE each #-}++instance (Bounded a, Dim n) => Bounded (V n a) where+ minBound = pure minBound+ {-# INLINE minBound #-}+ maxBound = pure maxBound+ {-# INLINE maxBound #-}++vConstr :: Constr+vConstr = mkConstr vDataType "variadic" [] Prefix+{-# NOINLINE vConstr #-}++vDataType :: DataType+vDataType = mkDataType "Linear.V.V" [vConstr]+{-# NOINLINE vDataType #-}++instance (Typeable (V n), Typeable (V n a), Dim n, Data a) => Data (V n a) where+ gfoldl f z (V as) = z (V . V.fromList) `f` V.toList as+ toConstr _ = vConstr+ gunfold k z c = case constrIndex c of+ 1 -> k (z (V . V.fromList))+ _ -> error "gunfold"+ dataTypeOf _ = vDataType+ dataCast1 f = gcast1 f++instance Dim n => Serial1 (V n) where+ serializeWith = traverse_+ deserializeWith f = sequenceA $ pure f++instance (Dim n, Serial a) => Serial (V n a) where+ serialize = traverse_ serialize+ deserialize = sequenceA $ pure deserialize++instance (Dim n, Binary a) => Binary (V n a) where+ put = serializeWith Binary.put+ get = deserializeWith Binary.get++instance (Dim n, Serialize a) => Serialize (V n a) where+ put = serializeWith Cereal.put+ get = deserializeWith Cereal.get++instance Eq1 (V n) where+ liftEq f0 (V as0) (V bs0) = go f0 (V.toList as0) (V.toList bs0) where+ go _ [] [] = True+ go f (a:as) (b:bs) = f a b && go f as bs+ go _ _ _ = False++instance Ord1 (V n) where+ liftCompare f0 (V as0) (V bs0) = go f0 (V.toList as0) (V.toList bs0) where+ go f (a:as) (b:bs) = f a b `mappend` go f as bs+ go _ [] [] = EQ+ go _ _ [] = GT+ go _ [] _ = LT++instance Show1 (V n) where+ liftShowsPrec _ g d (V as) = showParen (d > 10) $ showString "V " . g (V.toList as)++instance Dim n => Read1 (V n) where+ liftReadsPrec _ g d = readParen (d > 10) $ \r ->+ [ (V (V.fromList as), r2)+ | ("V",r1) <- lex r+ , (as, r2) <- g r1+ , P.length as == reflectDim (Proxy :: Proxy n)+ ]++data instance U.Vector (V n a) = V_VN {-# UNPACK #-} !Int !(U.Vector a)+data instance U.MVector s (V n a) = MV_VN {-# UNPACK #-} !Int !(U.MVector s a)+instance (Dim n, U.Unbox a) => U.Unbox (V n a)++instance (Dim n, U.Unbox a) => M.MVector U.MVector (V n a) where+ {-# INLINE basicLength #-}+ {-# INLINE basicUnsafeSlice #-}+ {-# INLINE basicOverlaps #-}+ {-# INLINE basicUnsafeNew #-}+ {-# INLINE basicUnsafeRead #-}+ {-# INLINE basicUnsafeWrite #-}+ basicLength (MV_VN n _) = n+ basicUnsafeSlice m n (MV_VN _ v) = MV_VN n (M.basicUnsafeSlice (d*m) (d*n) v)+ where d = reflectDim (Proxy :: Proxy n)+ basicOverlaps (MV_VN _ v) (MV_VN _ u) = M.basicOverlaps v u+ basicUnsafeNew n = liftM (MV_VN n) (M.basicUnsafeNew (d*n))+ where d = reflectDim (Proxy :: Proxy n)+ basicUnsafeRead (MV_VN _ v) i =+ liftM V $ V.generateM d (\j -> M.basicUnsafeRead v (d*i+j))+ where d = reflectDim (Proxy :: Proxy n)+ basicUnsafeWrite (MV_VN _ v0) i (V vn0) = let d0 = V.length vn0 in go v0 vn0 d0 (d0*i) 0+ where+ go v vn d o j+ | j >= d = return ()+ | otherwise = do+ a <- liftBox $ G.basicUnsafeIndexM vn j+ M.basicUnsafeWrite v o a+ go v vn d (o+1) (j+1)+ basicInitialize (MV_VN _ v) = M.basicInitialize v+ {-# INLINE basicInitialize #-}++liftBox :: Monad m => Box a -> m a+liftBox (Box a) = return a+{-# INLINE liftBox #-}++instance (Dim n, U.Unbox a) => G.Vector U.Vector (V n a) where+ {-# INLINE basicUnsafeFreeze #-}+ {-# INLINE basicUnsafeThaw #-}+ {-# INLINE basicLength #-}+ {-# INLINE basicUnsafeSlice #-}+ {-# INLINE basicUnsafeIndexM #-}+ basicUnsafeFreeze (MV_VN n v) = liftM ( V_VN n) (G.basicUnsafeFreeze v)+ basicUnsafeThaw ( V_VN n v) = liftM (MV_VN n) (G.basicUnsafeThaw v)+ basicLength ( V_VN n _) = n+ basicUnsafeSlice m n (V_VN _ v) = V_VN n (G.basicUnsafeSlice (d*m) (d*n) v)+ where d = reflectDim (Proxy :: Proxy n)+ basicUnsafeIndexM (V_VN _ v) i =+ liftM V $ V.generateM d (\j -> G.basicUnsafeIndexM v (d*i+j))+ where d = reflectDim (Proxy :: Proxy n)++vLens :: Int -> Lens' (V n a) a+vLens i = \f (V v) -> f (v V.! i) <&> \a -> V (v V.// [(i, a)])+{-# INLINE vLens #-}++instance ( 1 <= n) => Field1 (V n a) (V n a) a a where _1 = vLens 0+instance ( 2 <= n) => Field2 (V n a) (V n a) a a where _2 = vLens 1+instance ( 3 <= n) => Field3 (V n a) (V n a) a a where _3 = vLens 2+instance ( 4 <= n) => Field4 (V n a) (V n a) a a where _4 = vLens 3+instance ( 5 <= n) => Field5 (V n a) (V n a) a a where _5 = vLens 4+instance ( 6 <= n) => Field6 (V n a) (V n a) a a where _6 = vLens 5+instance ( 7 <= n) => Field7 (V n a) (V n a) a a where _7 = vLens 6+instance ( 8 <= n) => Field8 (V n a) (V n a) a a where _8 = vLens 7+instance ( 9 <= n) => Field9 (V n a) (V n a) a a where _9 = vLens 8+instance (10 <= n) => Field10 (V n a) (V n a) a a where _10 = vLens 9+instance (11 <= n) => Field11 (V n a) (V n a) a a where _11 = vLens 10+instance (12 <= n) => Field12 (V n a) (V n a) a a where _12 = vLens 11+instance (13 <= n) => Field13 (V n a) (V n a) a a where _13 = vLens 12+instance (14 <= n) => Field14 (V n a) (V n a) a a where _14 = vLens 13+instance (15 <= n) => Field15 (V n a) (V n a) a a where _15 = vLens 14+instance (16 <= n) => Field16 (V n a) (V n a) a a where _16 = vLens 15+instance (17 <= n) => Field17 (V n a) (V n a) a a where _17 = vLens 16+instance (18 <= n) => Field18 (V n a) (V n a) a a where _18 = vLens 17+instance (19 <= n) => Field19 (V n a) (V n a) a a where _19 = vLens 18
src/Linear/V0.hs view
@@ -1,371 +1,371 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveLift #-} - -#ifndef MIN_VERSION_hashable -#define MIN_VERSION_hashable(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_vector -#define MIN_VERSION_vector(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_transformers -#define MIN_VERSION_transformers(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_base -#define MIN_VERSION_base(x,y,z) 1 -#endif - ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2012-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : experimental --- Portability : non-portable --- --- 0-D Vectors ----------------------------------------------------------------------------- -module Linear.V0 - ( V0(..) - ) where - -import Control.Applicative -import Control.DeepSeq (NFData(rnf)) -import Control.Lens as Lens -import Control.Monad.Fix -import Control.Monad.Zip -import Data.Binary -- binary -import Data.Bytes.Serial -- bytes -import Data.Data -import Data.Distributive -import Data.Foldable -import qualified Data.Foldable.WithIndex as WithIndex -import Data.Functor.Bind -import Data.Functor.Classes -import Data.Functor.Rep -import qualified Data.Functor.WithIndex as WithIndex -import Data.Hashable -import Data.Hashable.Lifted -import Data.Ix -#if !(MIN_VERSION_base(4,11,0)) -import Data.Semigroup -#endif -import Data.Serialize -- cereal -import qualified Data.Traversable.WithIndex as WithIndex -import qualified Data.Vector as V -import Foreign.Storable (Storable(..)) -import GHC.Generics (Generic, Generic1) -#if defined(MIN_VERSION_template_haskell) -import Language.Haskell.TH.Syntax (Lift) -#endif -import qualified Data.Vector.Generic.Mutable as M -import qualified Data.Vector.Generic as G -import qualified Data.Vector.Unboxed.Base as U -import Linear.Metric -import Linear.Epsilon -import Linear.Vector -import Linear.V -import System.Random (Random(..)) -import Prelude hiding (sum) - --- $setup --- >>> import Control.Applicative --- >>> import Control.Lens --- >>> import qualified Data.Foldable as F --- >>> let sum xs = F.sum xs - --- | A 0-dimensional vector --- --- >>> pure 1 :: V0 Int --- V0 --- --- >>> V0 + V0 --- V0 --- -data V0 a = V0 deriving (Eq,Ord,Show,Read,Ix,Enum,Data - ,Generic,Generic1 -#if defined(MIN_VERSION_template_haskell) - ,Lift -#endif - ) - -instance Finite V0 where - type Size V0 = 0 - toV _ = V V.empty - fromV _ = V0 - -instance Random (V0 a) where - random g = (V0, g) - randomR _ g = (V0, g) - randomRs _ _ = repeat V0 - randoms _ = repeat V0 - -instance Serial1 V0 where - serializeWith _ = serialize - deserializeWith _ = deserialize - -instance Serial (V0 a) where - serialize V0 = return () - deserialize = return V0 - -instance Binary (V0 a) where - put V0 = return () - get = return V0 - -instance Serialize (V0 a) where - put V0 = return () - get = return V0 - -instance Functor V0 where - fmap _ V0 = V0 - {-# INLINE fmap #-} - _ <$ _ = V0 - {-# INLINE (<$) #-} - -instance Foldable V0 where - foldMap _ V0 = mempty - {-# INLINE foldMap #-} - null _ = True - length _ = 0 - -instance Traversable V0 where - traverse _ V0 = pure V0 - {-# INLINE traverse #-} - -instance Apply V0 where - V0 <.> V0 = V0 - {-# INLINE (<.>) #-} - -instance Applicative V0 where - pure _ = V0 - {-# INLINE pure #-} - V0 <*> V0 = V0 - {-# INLINE (<*>) #-} - -instance Semigroup (V0 a) where - _ <> _ = V0 - -instance Monoid (V0 a) where - mempty = V0 -#if !(MIN_VERSION_base(4,11,0)) - mappend _ _ = V0 -#endif - -instance Additive V0 where - zero = V0 - {-# INLINE zero #-} - liftU2 _ V0 V0 = V0 - {-# INLINE liftU2 #-} - liftI2 _ V0 V0 = V0 - {-# INLINE liftI2 #-} - -instance Bind V0 where - V0 >>- _ = V0 - {-# INLINE (>>-) #-} - -instance Monad V0 where -#if !(MIN_VERSION_base(4,11,0)) - return _ = V0 - {-# INLINE return #-} -#endif - V0 >>= _ = V0 - {-# INLINE (>>=) #-} - -instance Num (V0 a) where - V0 + V0 = V0 - {-# INLINE (+) #-} - V0 - V0 = V0 - {-# INLINE (-) #-} - V0 * V0 = V0 - {-# INLINE (*) #-} - negate V0 = V0 - {-# INLINE negate #-} - abs V0 = V0 - {-# INLINE abs #-} - signum V0 = V0 - {-# INLINE signum #-} - fromInteger _ = V0 - {-# INLINE fromInteger #-} - -instance Fractional (V0 a) where - recip _ = V0 - {-# INLINE recip #-} - V0 / V0 = V0 - {-# INLINE (/) #-} - fromRational _ = V0 - {-# INLINE fromRational #-} - -instance Floating (V0 a) where - pi = V0 - {-# INLINE pi #-} - exp V0 = V0 - {-# INLINE exp #-} - sqrt V0 = V0 - {-# INLINE sqrt #-} - log V0 = V0 - {-# INLINE log #-} - V0 ** V0 = V0 - {-# INLINE (**) #-} - logBase V0 V0 = V0 - {-# INLINE logBase #-} - sin V0 = V0 - {-# INLINE sin #-} - tan V0 = V0 - {-# INLINE tan #-} - cos V0 = V0 - {-# INLINE cos #-} - asin V0 = V0 - {-# INLINE asin #-} - atan V0 = V0 - {-# INLINE atan #-} - acos V0 = V0 - {-# INLINE acos #-} - sinh V0 = V0 - {-# INLINE sinh #-} - tanh V0 = V0 - {-# INLINE tanh #-} - cosh V0 = V0 - {-# INLINE cosh #-} - asinh V0 = V0 - {-# INLINE asinh #-} - atanh V0 = V0 - {-# INLINE atanh #-} - acosh V0 = V0 - {-# INLINE acosh #-} - -instance Metric V0 where - dot V0 V0 = 0 - {-# INLINE dot #-} - -instance Distributive V0 where - distribute _ = V0 - {-# INLINE distribute #-} - -instance Hashable (V0 a) where - hash V0 = 0 - {-# INLINE hash #-} - hashWithSalt s V0 = s - {-# INLINE hashWithSalt #-} - -instance Hashable1 V0 where - liftHashWithSalt _ s V0 = s - {-# INLINE liftHashWithSalt #-} - -instance Epsilon (V0 a) where - nearZero _ = True - {-# INLINE nearZero #-} - -instance Storable (V0 a) where - sizeOf _ = 0 - {-# INLINE sizeOf #-} - alignment _ = 1 - {-# INLINE alignment #-} - poke _ V0 = return () - {-# INLINE poke #-} - peek _ = return V0 - {-# INLINE peek #-} - -instance WithIndex.FunctorWithIndex (E V0) V0 where - imap _ V0 = V0 - {-# INLINE imap #-} - -instance WithIndex.FoldableWithIndex (E V0) V0 where - ifoldMap _ V0 = mempty - {-# INLINE ifoldMap #-} - -instance WithIndex.TraversableWithIndex (E V0) V0 where - itraverse _ V0 = pure V0 - {-# INLINE itraverse #-} - -#if !MIN_VERSION_lens(5,0,0) -instance Lens.FunctorWithIndex (E V0) V0 where imap = WithIndex.imap -instance Lens.FoldableWithIndex (E V0) V0 where ifoldMap = WithIndex.ifoldMap -instance Lens.TraversableWithIndex (E V0) V0 where itraverse = WithIndex.itraverse -#endif - -instance Representable V0 where - type Rep V0 = E V0 - tabulate _ = V0 - {-# INLINE tabulate #-} - index xs (E l) = view l xs - {-# INLINE index #-} - -type instance Index (V0 a) = E V0 -type instance IxValue (V0 a) = a - -instance Ixed (V0 a) where - ix i = el i - {-# INLINE ix #-} - -instance Each (V0 a) (V0 b) a b where - each = traverse - {-# INLINE each #-} - -newtype instance U.Vector (V0 a) = V_V0 Int -newtype instance U.MVector s (V0 a) = MV_V0 Int -instance U.Unbox (V0 a) - -instance M.MVector U.MVector (V0 a) where - {-# INLINE basicLength #-} - {-# INLINE basicUnsafeSlice #-} - {-# INLINE basicOverlaps #-} - {-# INLINE basicUnsafeNew #-} - {-# INLINE basicUnsafeRead #-} - {-# INLINE basicUnsafeWrite #-} - basicLength (MV_V0 n) = n - basicUnsafeSlice _ n _ = MV_V0 n - basicOverlaps _ _ = False - basicUnsafeNew n = return (MV_V0 n) - basicUnsafeRead _ _ = return V0 - basicUnsafeWrite _ _ _ = return () - basicInitialize _ = return () - {-# INLINE basicInitialize #-} - -instance G.Vector U.Vector (V0 a) where - {-# INLINE basicUnsafeFreeze #-} - {-# INLINE basicUnsafeThaw #-} - {-# INLINE basicLength #-} - {-# INLINE basicUnsafeSlice #-} - {-# INLINE basicUnsafeIndexM #-} - basicUnsafeFreeze (MV_V0 n) = return (V_V0 n) - basicUnsafeThaw (V_V0 n) = return (MV_V0 n) - basicLength (V_V0 n) = n - basicUnsafeSlice _ n _ = V_V0 n - basicUnsafeIndexM _ _ = return V0 - -instance MonadZip V0 where - mzip V0 V0 = V0 - mzipWith _ V0 V0 = V0 - munzip V0 = (V0, V0) - -instance MonadFix V0 where - mfix _ = V0 - -instance Bounded (V0 a) where - minBound = V0 - {-# INLINE minBound #-} - maxBound = V0 - {-# INLINE maxBound #-} - -instance NFData (V0 a) where - rnf V0 = () - -instance Eq1 V0 where - liftEq _ _ _ = True -instance Ord1 V0 where - liftCompare _ _ _ = EQ -instance Show1 V0 where - liftShowsPrec _ _ = showsPrec -instance Read1 V0 where - liftReadsPrec _ _ = readsPrec +{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveLift #-}++#ifndef MIN_VERSION_hashable+#define MIN_VERSION_hashable(x,y,z) 1+#endif++#ifndef MIN_VERSION_vector+#define MIN_VERSION_vector(x,y,z) 1+#endif++#ifndef MIN_VERSION_transformers+#define MIN_VERSION_transformers(x,y,z) 1+#endif++#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1+#endif++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2012-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- 0-D Vectors+----------------------------------------------------------------------------+module Linear.V0+ ( V0(..)+ ) where++import Control.Applicative+import Control.DeepSeq (NFData(rnf))+import Control.Lens as Lens+import Control.Monad.Fix+import Control.Monad.Zip+import Data.Binary -- binary+import Data.Bytes.Serial -- bytes+import Data.Data+import Data.Distributive+import Data.Foldable+import qualified Data.Foldable.WithIndex as WithIndex+import Data.Functor.Bind+import Data.Functor.Classes+import Data.Functor.Rep+import qualified Data.Functor.WithIndex as WithIndex+import Data.Hashable+import Data.Hashable.Lifted+import Data.Ix+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup+#endif+import Data.Serialize -- cereal+import qualified Data.Traversable.WithIndex as WithIndex+import qualified Data.Vector as V+import Foreign.Storable (Storable(..))+import GHC.Generics (Generic, Generic1)+#if defined(MIN_VERSION_template_haskell)+import Language.Haskell.TH.Syntax (Lift)+#endif+import qualified Data.Vector.Generic.Mutable as M+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Unboxed.Base as U+import Linear.Metric+import Linear.Epsilon+import Linear.Vector+import Linear.V+import System.Random (Random(..))+import Prelude hiding (sum)++-- $setup+-- >>> import Control.Applicative+-- >>> import Control.Lens+-- >>> import qualified Data.Foldable as F+-- >>> let sum xs = F.sum xs++-- | A 0-dimensional vector+--+-- >>> pure 1 :: V0 Int+-- V0+--+-- >>> V0 + V0+-- V0+--+data V0 a = V0 deriving (Eq,Ord,Show,Read,Ix,Enum,Data+ ,Generic,Generic1+#if defined(MIN_VERSION_template_haskell)+ ,Lift+#endif+ )++instance Finite V0 where+ type Size V0 = 0+ toV _ = V V.empty+ fromV _ = V0++instance Random (V0 a) where+ random g = (V0, g)+ randomR _ g = (V0, g)+ randomRs _ _ = repeat V0+ randoms _ = repeat V0++instance Serial1 V0 where+ serializeWith _ = serialize+ deserializeWith _ = deserialize++instance Serial (V0 a) where+ serialize V0 = return ()+ deserialize = return V0++instance Binary (V0 a) where+ put V0 = return ()+ get = return V0++instance Serialize (V0 a) where+ put V0 = return ()+ get = return V0++instance Functor V0 where+ fmap _ V0 = V0+ {-# INLINE fmap #-}+ _ <$ _ = V0+ {-# INLINE (<$) #-}++instance Foldable V0 where+ foldMap _ V0 = mempty+ {-# INLINE foldMap #-}+ null _ = True+ length _ = 0++instance Traversable V0 where+ traverse _ V0 = pure V0+ {-# INLINE traverse #-}++instance Apply V0 where+ V0 <.> V0 = V0+ {-# INLINE (<.>) #-}++instance Applicative V0 where+ pure _ = V0+ {-# INLINE pure #-}+ V0 <*> V0 = V0+ {-# INLINE (<*>) #-}++instance Semigroup (V0 a) where+ _ <> _ = V0++instance Monoid (V0 a) where+ mempty = V0+#if !(MIN_VERSION_base(4,11,0))+ mappend _ _ = V0+#endif++instance Additive V0 where+ zero = V0+ {-# INLINE zero #-}+ liftU2 _ V0 V0 = V0+ {-# INLINE liftU2 #-}+ liftI2 _ V0 V0 = V0+ {-# INLINE liftI2 #-}++instance Bind V0 where+ V0 >>- _ = V0+ {-# INLINE (>>-) #-}++instance Monad V0 where+#if !(MIN_VERSION_base(4,11,0))+ return _ = V0+ {-# INLINE return #-}+#endif+ V0 >>= _ = V0+ {-# INLINE (>>=) #-}++instance Num (V0 a) where+ V0 + V0 = V0+ {-# INLINE (+) #-}+ V0 - V0 = V0+ {-# INLINE (-) #-}+ V0 * V0 = V0+ {-# INLINE (*) #-}+ negate V0 = V0+ {-# INLINE negate #-}+ abs V0 = V0+ {-# INLINE abs #-}+ signum V0 = V0+ {-# INLINE signum #-}+ fromInteger _ = V0+ {-# INLINE fromInteger #-}++instance Fractional (V0 a) where+ recip _ = V0+ {-# INLINE recip #-}+ V0 / V0 = V0+ {-# INLINE (/) #-}+ fromRational _ = V0+ {-# INLINE fromRational #-}++instance Floating (V0 a) where+ pi = V0+ {-# INLINE pi #-}+ exp V0 = V0+ {-# INLINE exp #-}+ sqrt V0 = V0+ {-# INLINE sqrt #-}+ log V0 = V0+ {-# INLINE log #-}+ V0 ** V0 = V0+ {-# INLINE (**) #-}+ logBase V0 V0 = V0+ {-# INLINE logBase #-}+ sin V0 = V0+ {-# INLINE sin #-}+ tan V0 = V0+ {-# INLINE tan #-}+ cos V0 = V0+ {-# INLINE cos #-}+ asin V0 = V0+ {-# INLINE asin #-}+ atan V0 = V0+ {-# INLINE atan #-}+ acos V0 = V0+ {-# INLINE acos #-}+ sinh V0 = V0+ {-# INLINE sinh #-}+ tanh V0 = V0+ {-# INLINE tanh #-}+ cosh V0 = V0+ {-# INLINE cosh #-}+ asinh V0 = V0+ {-# INLINE asinh #-}+ atanh V0 = V0+ {-# INLINE atanh #-}+ acosh V0 = V0+ {-# INLINE acosh #-}++instance Metric V0 where+ dot V0 V0 = 0+ {-# INLINE dot #-}++instance Distributive V0 where+ distribute _ = V0+ {-# INLINE distribute #-}++instance Hashable (V0 a) where+ hash V0 = 0+ {-# INLINE hash #-}+ hashWithSalt s V0 = s+ {-# INLINE hashWithSalt #-}++instance Hashable1 V0 where+ liftHashWithSalt _ s V0 = s+ {-# INLINE liftHashWithSalt #-}++instance Epsilon (V0 a) where+ nearZero _ = True+ {-# INLINE nearZero #-}++instance Storable (V0 a) where+ sizeOf _ = 0+ {-# INLINE sizeOf #-}+ alignment _ = 1+ {-# INLINE alignment #-}+ poke _ V0 = return ()+ {-# INLINE poke #-}+ peek _ = return V0+ {-# INLINE peek #-}++instance WithIndex.FunctorWithIndex (E V0) V0 where+ imap _ V0 = V0+ {-# INLINE imap #-}++instance WithIndex.FoldableWithIndex (E V0) V0 where+ ifoldMap _ V0 = mempty+ {-# INLINE ifoldMap #-}++instance WithIndex.TraversableWithIndex (E V0) V0 where+ itraverse _ V0 = pure V0+ {-# INLINE itraverse #-}++#if !MIN_VERSION_lens(5,0,0)+instance Lens.FunctorWithIndex (E V0) V0 where imap = WithIndex.imap+instance Lens.FoldableWithIndex (E V0) V0 where ifoldMap = WithIndex.ifoldMap+instance Lens.TraversableWithIndex (E V0) V0 where itraverse = WithIndex.itraverse+#endif++instance Representable V0 where+ type Rep V0 = E V0+ tabulate _ = V0+ {-# INLINE tabulate #-}+ index xs (E l) = view l xs+ {-# INLINE index #-}++type instance Index (V0 a) = E V0+type instance IxValue (V0 a) = a++instance Ixed (V0 a) where+ ix i = el i+ {-# INLINE ix #-}++instance Each (V0 a) (V0 b) a b where+ each = traverse+ {-# INLINE each #-}++newtype instance U.Vector (V0 a) = V_V0 Int+newtype instance U.MVector s (V0 a) = MV_V0 Int+instance U.Unbox (V0 a)++instance M.MVector U.MVector (V0 a) where+ {-# INLINE basicLength #-}+ {-# INLINE basicUnsafeSlice #-}+ {-# INLINE basicOverlaps #-}+ {-# INLINE basicUnsafeNew #-}+ {-# INLINE basicUnsafeRead #-}+ {-# INLINE basicUnsafeWrite #-}+ basicLength (MV_V0 n) = n+ basicUnsafeSlice _ n _ = MV_V0 n+ basicOverlaps _ _ = False+ basicUnsafeNew n = return (MV_V0 n)+ basicUnsafeRead _ _ = return V0+ basicUnsafeWrite _ _ _ = return ()+ basicInitialize _ = return ()+ {-# INLINE basicInitialize #-}++instance G.Vector U.Vector (V0 a) where+ {-# INLINE basicUnsafeFreeze #-}+ {-# INLINE basicUnsafeThaw #-}+ {-# INLINE basicLength #-}+ {-# INLINE basicUnsafeSlice #-}+ {-# INLINE basicUnsafeIndexM #-}+ basicUnsafeFreeze (MV_V0 n) = return (V_V0 n)+ basicUnsafeThaw (V_V0 n) = return (MV_V0 n)+ basicLength (V_V0 n) = n+ basicUnsafeSlice _ n _ = V_V0 n+ basicUnsafeIndexM _ _ = return V0++instance MonadZip V0 where+ mzip V0 V0 = V0+ mzipWith _ V0 V0 = V0+ munzip V0 = (V0, V0)++instance MonadFix V0 where+ mfix _ = V0++instance Bounded (V0 a) where+ minBound = V0+ {-# INLINE minBound #-}+ maxBound = V0+ {-# INLINE maxBound #-}++instance NFData (V0 a) where+ rnf V0 = ()++instance Eq1 V0 where+ liftEq _ _ _ = True+instance Ord1 V0 where+ liftCompare _ _ _ = EQ+instance Show1 V0 where+ liftShowsPrec _ _ = showsPrec+instance Read1 V0 where+ liftReadsPrec _ _ = readsPrec
src/Linear/V1.hs view
@@ -1,410 +1,410 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveLift #-} - -#ifndef MIN_VERSION_hashable -#define MIN_VERSION_hashable(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_vector -#define MIN_VERSION_vector(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_transformers -#define MIN_VERSION_transformers(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_base -#define MIN_VERSION_base(x,y,z) 1 -#endif - ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2012-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : experimental --- Portability : non-portable --- --- 1-D Vectors ----------------------------------------------------------------------------- -module Linear.V1 - ( V1(..) - , R1(..) - , ex - ) where - -import Control.Applicative -import Control.DeepSeq (NFData) -import Control.Monad (liftM) -import Control.Monad.Fix -import Control.Monad.Zip -import Control.Lens as Lens -import Data.Binary as Binary -import Data.Bytes.Serial -import Data.Serialize as Cereal -import Data.Data -import Data.Distributive -import Data.Foldable -import qualified Data.Foldable.WithIndex as WithIndex -import Data.Functor.Bind -import Data.Functor.Classes -import Data.Functor.Rep -import qualified Data.Functor.WithIndex as WithIndex -import Data.Hashable -import Data.Hashable.Lifted -import Data.Semigroup.Foldable -import qualified Data.Traversable.WithIndex as WithIndex -import qualified Data.Vector as V -import Linear.V -import Foreign.Storable (Storable) -import GHC.Arr (Ix(..)) -import GHC.Generics (Generic, Generic1) -#if defined(MIN_VERSION_template_haskell) -import Language.Haskell.TH.Syntax (Lift) -#endif -import Linear.Metric -import Linear.Epsilon -import Linear.Vector -import Prelude hiding (sum) -import System.Random (Random(..)) -#if !(MIN_VERSION_base(4,11,0)) -import Data.Semigroup -#endif - -import qualified Data.Vector.Generic.Mutable as M -import qualified Data.Vector.Generic as G -import qualified Data.Vector.Unboxed.Base as U - --- $setup --- >>> import Control.Applicative --- >>> import Control.Lens --- >>> import qualified Data.Foldable as F --- >>> let sum xs = F.sum xs - --- | A 1-dimensional vector --- --- >>> pure 1 :: V1 Int --- V1 1 --- --- >>> V1 2 + V1 3 --- V1 5 --- --- >>> V1 2 * V1 3 --- V1 6 --- --- >>> sum (V1 2) --- 2 - ---data V2 a = V2 !a !a deriving (Eq,Ord,Show,Read,Data) -newtype V1 a = V1 a - deriving (Eq,Ord,Show,Read,Data, - Functor,Traversable, - Epsilon,Storable,NFData - ,Generic,Generic1 -#if defined(MIN_VERSION_template_haskell) - ,Lift -#endif - ) - -instance Foldable V1 where - foldMap f (V1 a) = f a -#if MIN_VERSION_base(4,13,0) - foldMap' f (V1 a) = f a -#endif - null _ = False - length _ = 1 - -instance Finite V1 where - type Size V1 = 1 - toV (V1 a) = V (V.singleton a) - fromV (V v) = V1 (v V.! 0) - -instance Foldable1 V1 where - foldMap1 f (V1 a) = f a - {-# INLINE foldMap1 #-} - -instance Traversable1 V1 where - traverse1 f (V1 a) = V1 <$> f a - {-# INLINE traverse1 #-} - -instance Apply V1 where - V1 f <.> V1 x = V1 (f x) - {-# INLINE (<.>) #-} - -instance Applicative V1 where - pure = V1 - {-# INLINE pure #-} - V1 f <*> V1 x = V1 (f x) - {-# INLINE (<*>) #-} - -instance Additive V1 where - zero = pure 0 - {-# INLINE zero #-} - liftU2 = liftA2 - {-# INLINE liftU2 #-} - liftI2 = liftA2 - {-# INLINE liftI2 #-} - -instance Bind V1 where - V1 a >>- f = f a - {-# INLINE (>>-) #-} - -instance Monad V1 where -#if !(MIN_VERSION_base(4,11,0)) - return = V1 - {-# INLINE return #-} -#endif - V1 a >>= f = f a - {-# INLINE (>>=) #-} - -instance Num a => Num (V1 a) where - (+) = liftA2 (+) - {-# INLINE (+) #-} - (-) = liftA2 (-) - {-# INLINE (-) #-} - (*) = liftA2 (*) - {-# INLINE (*) #-} - negate = fmap negate - {-# INLINE negate #-} - abs = fmap abs - {-# INLINE abs #-} - signum = fmap signum - {-# INLINE signum #-} - fromInteger = pure . fromInteger - {-# INLINE fromInteger #-} - -instance Fractional a => Fractional (V1 a) where - recip = fmap recip - {-# INLINE recip #-} - (/) = liftA2 (/) - {-# INLINE (/) #-} - fromRational = pure . fromRational - {-# INLINE fromRational #-} - -instance Floating a => Floating (V1 a) where - pi = pure pi - {-# INLINE pi #-} - exp = fmap exp - {-# INLINE exp #-} - sqrt = fmap sqrt - {-# INLINE sqrt #-} - log = fmap log - {-# INLINE log #-} - (**) = liftA2 (**) - {-# INLINE (**) #-} - logBase = liftA2 logBase - {-# INLINE logBase #-} - sin = fmap sin - {-# INLINE sin #-} - tan = fmap tan - {-# INLINE tan #-} - cos = fmap cos - {-# INLINE cos #-} - asin = fmap asin - {-# INLINE asin #-} - atan = fmap atan - {-# INLINE atan #-} - acos = fmap acos - {-# INLINE acos #-} - sinh = fmap sinh - {-# INLINE sinh #-} - tanh = fmap tanh - {-# INLINE tanh #-} - cosh = fmap cosh - {-# INLINE cosh #-} - asinh = fmap asinh - {-# INLINE asinh #-} - atanh = fmap atanh - {-# INLINE atanh #-} - acosh = fmap acosh - {-# INLINE acosh #-} - -instance Hashable a => Hashable (V1 a) where - hash (V1 a) = hash a - hashWithSalt s (V1 a) = s `hashWithSalt` a - -instance Hashable1 V1 where - liftHashWithSalt h s (V1 a) = h s a - {-# INLINE liftHashWithSalt #-} - -instance Metric V1 where - dot (V1 a) (V1 b) = a * b - {-# INLINE dot #-} - --- | A space that has at least 1 basis vector '_x'. -class R1 t where - -- | - -- >>> V1 2 ^._x - -- 2 - -- - -- >>> V1 2 & _x .~ 3 - -- V1 3 - -- - _x :: Lens' (t a) a - -ex :: R1 t => E t -ex = E _x - -instance R1 V1 where - _x f (V1 a) = V1 <$> f a - {-# INLINE _x #-} - -instance R1 Identity where - _x f (Identity a) = Identity <$> f a - {-# INLINE _x #-} - -instance Distributive V1 where - distribute f = V1 (fmap (\(V1 x) -> x) f) - {-# INLINE distribute #-} - -instance Ix a => Ix (V1 a) where - {-# SPECIALISE instance Ix (V1 Int) #-} - - range (V1 l1, V1 u1) = - [ V1 i1 | i1 <- range (l1,u1) ] - {-# INLINE range #-} - - unsafeIndex (V1 l1,V1 u1) (V1 i1) = unsafeIndex (l1,u1) i1 - {-# INLINE unsafeIndex #-} - - inRange (V1 l1,V1 u1) (V1 i1) = inRange (l1,u1) i1 - {-# INLINE inRange #-} - -instance Representable V1 where - type Rep V1 = E V1 - tabulate f = V1 (f ex) - {-# INLINE tabulate #-} - index xs (E l) = view l xs - {-# INLINE index #-} - -instance WithIndex.FunctorWithIndex (E V1) V1 where - imap f (V1 a) = V1 (f ex a) - {-# INLINE imap #-} - -instance WithIndex.FoldableWithIndex (E V1) V1 where - ifoldMap f (V1 a) = f ex a - {-# INLINE ifoldMap #-} - -instance WithIndex.TraversableWithIndex (E V1) V1 where - itraverse f (V1 a) = V1 <$> f ex a - {-# INLINE itraverse #-} - -#if !MIN_VERSION_lens(5,0,0) -instance Lens.FunctorWithIndex (E V1) V1 where imap = WithIndex.imap -instance Lens.FoldableWithIndex (E V1) V1 where ifoldMap = WithIndex.ifoldMap -instance Lens.TraversableWithIndex (E V1) V1 where itraverse = WithIndex.itraverse -#endif - -type instance Index (V1 a) = E V1 -type instance IxValue (V1 a) = a - -instance Ixed (V1 a) where - ix i = el i - {-# INLINE ix #-} - -instance Each (V1 a) (V1 b) a b where - each f (V1 x) = V1 <$> f x - {-# INLINE each #-} - -newtype instance U.Vector (V1 a) = V_V1 (U.Vector a) -newtype instance U.MVector s (V1 a) = MV_V1 (U.MVector s a) -instance U.Unbox a => U.Unbox (V1 a) - -instance U.Unbox a => M.MVector U.MVector (V1 a) where - {-# INLINE basicLength #-} - {-# INLINE basicUnsafeSlice #-} - {-# INLINE basicOverlaps #-} - {-# INLINE basicUnsafeNew #-} - {-# INLINE basicUnsafeRead #-} - {-# INLINE basicUnsafeWrite #-} - basicLength (MV_V1 v) = M.basicLength v - basicUnsafeSlice m n (MV_V1 v) = MV_V1 (M.basicUnsafeSlice m n v) - basicOverlaps (MV_V1 v) (MV_V1 u) = M.basicOverlaps v u - basicUnsafeNew n = liftM MV_V1 (M.basicUnsafeNew n) - basicUnsafeRead (MV_V1 v) i = liftM V1 (M.basicUnsafeRead v i) - basicUnsafeWrite (MV_V1 v) i (V1 x) = M.basicUnsafeWrite v i x - basicInitialize (MV_V1 v) = M.basicInitialize v - {-# INLINE basicInitialize #-} - -instance U.Unbox a => G.Vector U.Vector (V1 a) where - {-# INLINE basicUnsafeFreeze #-} - {-# INLINE basicUnsafeThaw #-} - {-# INLINE basicLength #-} - {-# INLINE basicUnsafeSlice #-} - {-# INLINE basicUnsafeIndexM #-} - basicUnsafeFreeze (MV_V1 v) = liftM V_V1 (G.basicUnsafeFreeze v) - basicUnsafeThaw (V_V1 v) = liftM MV_V1 (G.basicUnsafeThaw v) - basicLength (V_V1 v) = G.basicLength v - basicUnsafeSlice m n (V_V1 v) = V_V1 (G.basicUnsafeSlice m n v) - basicUnsafeIndexM (V_V1 v) i = liftM V1 (G.basicUnsafeIndexM v i) - -instance MonadZip V1 where - mzip (V1 a) (V1 b) = V1 (a, b) - mzipWith f (V1 a) (V1 b) = V1 (f a b) - munzip (V1 (a,b)) = (V1 a, V1 b) - -instance MonadFix V1 where - mfix f = V1 (let V1 a = f a in a) - -instance Bounded a => Bounded (V1 a) where - minBound = pure minBound - {-# INLINE minBound #-} - maxBound = pure maxBound - {-# INLINE maxBound #-} - -instance Serial1 V1 where - serializeWith f (V1 a) = f a - deserializeWith m = V1 `liftM` m - -instance Serial a => Serial (V1 a) where - serialize (V1 a) = serialize a - deserialize = V1 `liftM` deserialize - -instance Binary a => Binary (V1 a) where - put = serializeWith Binary.put - get = deserializeWith Binary.get - -instance Serialize a => Serialize (V1 a) where - put = serializeWith Cereal.put - get = deserializeWith Cereal.get - -instance Random a => Random (V1 a) where - random g = case random g of (a, g') -> (V1 a, g') - randoms g = V1 <$> randoms g - randomR (V1 a, V1 b) g = case randomR (a, b) g of (a', g') -> (V1 a', g') - randomRs (V1 a, V1 b) g = V1 <$> randomRs (a, b) g - -instance Eq1 V1 where - liftEq f (V1 a) (V1 b) = f a b -instance Ord1 V1 where - liftCompare f (V1 a) (V1 b) = f a b -instance Show1 V1 where - liftShowsPrec f _ d (V1 a) = showParen (d >= 10) $ showString "V1 " . f d a -instance Read1 V1 where - liftReadsPrec f _ = readsData $ readsUnaryWith f "V1" V1 - -instance Field1 (V1 a) (V1 b) a b where - _1 f (V1 x) = V1 <$> f x - -instance Semigroup a => Semigroup (V1 a) where - (<>) = liftA2 (<>) - -instance Monoid a => Monoid (V1 a) where - mempty = pure mempty -#if !(MIN_VERSION_base(4,11,0)) - mappend = liftA2 mappend -#endif - +{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveLift #-}++#ifndef MIN_VERSION_hashable+#define MIN_VERSION_hashable(x,y,z) 1+#endif++#ifndef MIN_VERSION_vector+#define MIN_VERSION_vector(x,y,z) 1+#endif++#ifndef MIN_VERSION_transformers+#define MIN_VERSION_transformers(x,y,z) 1+#endif++#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1+#endif++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2012-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- 1-D Vectors+----------------------------------------------------------------------------+module Linear.V1+ ( V1(..)+ , R1(..)+ , ex+ ) where++import Control.Applicative+import Control.DeepSeq (NFData)+import Control.Monad (liftM)+import Control.Monad.Fix+import Control.Monad.Zip+import Control.Lens as Lens+import Data.Binary as Binary+import Data.Bytes.Serial+import Data.Serialize as Cereal+import Data.Data+import Data.Distributive+import Data.Foldable+import qualified Data.Foldable.WithIndex as WithIndex+import Data.Functor.Bind+import Data.Functor.Classes+import Data.Functor.Rep+import qualified Data.Functor.WithIndex as WithIndex+import Data.Hashable+import Data.Hashable.Lifted+import Data.Semigroup.Foldable+import qualified Data.Traversable.WithIndex as WithIndex+import qualified Data.Vector as V+import Linear.V+import Foreign.Storable (Storable)+import GHC.Arr (Ix(..))+import GHC.Generics (Generic, Generic1)+#if defined(MIN_VERSION_template_haskell)+import Language.Haskell.TH.Syntax (Lift)+#endif+import Linear.Metric+import Linear.Epsilon+import Linear.Vector+import Prelude hiding (sum)+import System.Random (Random(..))+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup+#endif++import qualified Data.Vector.Generic.Mutable as M+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Unboxed.Base as U++-- $setup+-- >>> import Control.Applicative+-- >>> import Control.Lens+-- >>> import qualified Data.Foldable as F+-- >>> let sum xs = F.sum xs++-- | A 1-dimensional vector+--+-- >>> pure 1 :: V1 Int+-- V1 1+--+-- >>> V1 2 + V1 3+-- V1 5+--+-- >>> V1 2 * V1 3+-- V1 6+--+-- >>> sum (V1 2)+-- 2++--data V2 a = V2 !a !a deriving (Eq,Ord,Show,Read,Data)+newtype V1 a = V1 a+ deriving (Eq,Ord,Show,Read,Data,+ Functor,Traversable,+ Epsilon,Storable,NFData+ ,Generic,Generic1+#if defined(MIN_VERSION_template_haskell)+ ,Lift+#endif+ )++instance Foldable V1 where+ foldMap f (V1 a) = f a+#if MIN_VERSION_base(4,13,0)+ foldMap' f (V1 a) = f a+#endif+ null _ = False+ length _ = 1++instance Finite V1 where+ type Size V1 = 1+ toV (V1 a) = V (V.singleton a)+ fromV (V v) = V1 (v V.! 0)++instance Foldable1 V1 where+ foldMap1 f (V1 a) = f a+ {-# INLINE foldMap1 #-}++instance Traversable1 V1 where+ traverse1 f (V1 a) = V1 <$> f a+ {-# INLINE traverse1 #-}++instance Apply V1 where+ V1 f <.> V1 x = V1 (f x)+ {-# INLINE (<.>) #-}++instance Applicative V1 where+ pure = V1+ {-# INLINE pure #-}+ V1 f <*> V1 x = V1 (f x)+ {-# INLINE (<*>) #-}++instance Additive V1 where+ zero = pure 0+ {-# INLINE zero #-}+ liftU2 = liftA2+ {-# INLINE liftU2 #-}+ liftI2 = liftA2+ {-# INLINE liftI2 #-}++instance Bind V1 where+ V1 a >>- f = f a+ {-# INLINE (>>-) #-}++instance Monad V1 where+#if !(MIN_VERSION_base(4,11,0))+ return = V1+ {-# INLINE return #-}+#endif+ V1 a >>= f = f a+ {-# INLINE (>>=) #-}++instance Num a => Num (V1 a) where+ (+) = liftA2 (+)+ {-# INLINE (+) #-}+ (-) = liftA2 (-)+ {-# INLINE (-) #-}+ (*) = liftA2 (*)+ {-# INLINE (*) #-}+ negate = fmap negate+ {-# INLINE negate #-}+ abs = fmap abs+ {-# INLINE abs #-}+ signum = fmap signum+ {-# INLINE signum #-}+ fromInteger = pure . fromInteger+ {-# INLINE fromInteger #-}++instance Fractional a => Fractional (V1 a) where+ recip = fmap recip+ {-# INLINE recip #-}+ (/) = liftA2 (/)+ {-# INLINE (/) #-}+ fromRational = pure . fromRational+ {-# INLINE fromRational #-}++instance Floating a => Floating (V1 a) where+ pi = pure pi+ {-# INLINE pi #-}+ exp = fmap exp+ {-# INLINE exp #-}+ sqrt = fmap sqrt+ {-# INLINE sqrt #-}+ log = fmap log+ {-# INLINE log #-}+ (**) = liftA2 (**)+ {-# INLINE (**) #-}+ logBase = liftA2 logBase+ {-# INLINE logBase #-}+ sin = fmap sin+ {-# INLINE sin #-}+ tan = fmap tan+ {-# INLINE tan #-}+ cos = fmap cos+ {-# INLINE cos #-}+ asin = fmap asin+ {-# INLINE asin #-}+ atan = fmap atan+ {-# INLINE atan #-}+ acos = fmap acos+ {-# INLINE acos #-}+ sinh = fmap sinh+ {-# INLINE sinh #-}+ tanh = fmap tanh+ {-# INLINE tanh #-}+ cosh = fmap cosh+ {-# INLINE cosh #-}+ asinh = fmap asinh+ {-# INLINE asinh #-}+ atanh = fmap atanh+ {-# INLINE atanh #-}+ acosh = fmap acosh+ {-# INLINE acosh #-}++instance Hashable a => Hashable (V1 a) where+ hash (V1 a) = hash a+ hashWithSalt s (V1 a) = s `hashWithSalt` a++instance Hashable1 V1 where+ liftHashWithSalt h s (V1 a) = h s a+ {-# INLINE liftHashWithSalt #-}++instance Metric V1 where+ dot (V1 a) (V1 b) = a * b+ {-# INLINE dot #-}++-- | A space that has at least 1 basis vector '_x'.+class R1 t where+ -- |+ -- >>> V1 2 ^._x+ -- 2+ --+ -- >>> V1 2 & _x .~ 3+ -- V1 3+ --+ _x :: Lens' (t a) a++ex :: R1 t => E t+ex = E _x++instance R1 V1 where+ _x f (V1 a) = V1 <$> f a+ {-# INLINE _x #-}++instance R1 Identity where+ _x f (Identity a) = Identity <$> f a+ {-# INLINE _x #-}++instance Distributive V1 where+ distribute f = V1 (fmap (\(V1 x) -> x) f)+ {-# INLINE distribute #-}++instance Ix a => Ix (V1 a) where+ {-# SPECIALISE instance Ix (V1 Int) #-}++ range (V1 l1, V1 u1) =+ [ V1 i1 | i1 <- range (l1,u1) ]+ {-# INLINE range #-}++ unsafeIndex (V1 l1,V1 u1) (V1 i1) = unsafeIndex (l1,u1) i1+ {-# INLINE unsafeIndex #-}++ inRange (V1 l1,V1 u1) (V1 i1) = inRange (l1,u1) i1+ {-# INLINE inRange #-}++instance Representable V1 where+ type Rep V1 = E V1+ tabulate f = V1 (f ex)+ {-# INLINE tabulate #-}+ index xs (E l) = view l xs+ {-# INLINE index #-}++instance WithIndex.FunctorWithIndex (E V1) V1 where+ imap f (V1 a) = V1 (f ex a)+ {-# INLINE imap #-}++instance WithIndex.FoldableWithIndex (E V1) V1 where+ ifoldMap f (V1 a) = f ex a+ {-# INLINE ifoldMap #-}++instance WithIndex.TraversableWithIndex (E V1) V1 where+ itraverse f (V1 a) = V1 <$> f ex a+ {-# INLINE itraverse #-}++#if !MIN_VERSION_lens(5,0,0)+instance Lens.FunctorWithIndex (E V1) V1 where imap = WithIndex.imap+instance Lens.FoldableWithIndex (E V1) V1 where ifoldMap = WithIndex.ifoldMap+instance Lens.TraversableWithIndex (E V1) V1 where itraverse = WithIndex.itraverse+#endif++type instance Index (V1 a) = E V1+type instance IxValue (V1 a) = a++instance Ixed (V1 a) where+ ix i = el i+ {-# INLINE ix #-}++instance Each (V1 a) (V1 b) a b where+ each f (V1 x) = V1 <$> f x+ {-# INLINE each #-}++newtype instance U.Vector (V1 a) = V_V1 (U.Vector a)+newtype instance U.MVector s (V1 a) = MV_V1 (U.MVector s a)+instance U.Unbox a => U.Unbox (V1 a)++instance U.Unbox a => M.MVector U.MVector (V1 a) where+ {-# INLINE basicLength #-}+ {-# INLINE basicUnsafeSlice #-}+ {-# INLINE basicOverlaps #-}+ {-# INLINE basicUnsafeNew #-}+ {-# INLINE basicUnsafeRead #-}+ {-# INLINE basicUnsafeWrite #-}+ basicLength (MV_V1 v) = M.basicLength v+ basicUnsafeSlice m n (MV_V1 v) = MV_V1 (M.basicUnsafeSlice m n v)+ basicOverlaps (MV_V1 v) (MV_V1 u) = M.basicOverlaps v u+ basicUnsafeNew n = liftM MV_V1 (M.basicUnsafeNew n)+ basicUnsafeRead (MV_V1 v) i = liftM V1 (M.basicUnsafeRead v i)+ basicUnsafeWrite (MV_V1 v) i (V1 x) = M.basicUnsafeWrite v i x+ basicInitialize (MV_V1 v) = M.basicInitialize v+ {-# INLINE basicInitialize #-}++instance U.Unbox a => G.Vector U.Vector (V1 a) where+ {-# INLINE basicUnsafeFreeze #-}+ {-# INLINE basicUnsafeThaw #-}+ {-# INLINE basicLength #-}+ {-# INLINE basicUnsafeSlice #-}+ {-# INLINE basicUnsafeIndexM #-}+ basicUnsafeFreeze (MV_V1 v) = liftM V_V1 (G.basicUnsafeFreeze v)+ basicUnsafeThaw (V_V1 v) = liftM MV_V1 (G.basicUnsafeThaw v)+ basicLength (V_V1 v) = G.basicLength v+ basicUnsafeSlice m n (V_V1 v) = V_V1 (G.basicUnsafeSlice m n v)+ basicUnsafeIndexM (V_V1 v) i = liftM V1 (G.basicUnsafeIndexM v i)++instance MonadZip V1 where+ mzip (V1 a) (V1 b) = V1 (a, b)+ mzipWith f (V1 a) (V1 b) = V1 (f a b)+ munzip (V1 (a,b)) = (V1 a, V1 b)++instance MonadFix V1 where+ mfix f = V1 (let V1 a = f a in a)++instance Bounded a => Bounded (V1 a) where+ minBound = pure minBound+ {-# INLINE minBound #-}+ maxBound = pure maxBound+ {-# INLINE maxBound #-}++instance Serial1 V1 where+ serializeWith f (V1 a) = f a+ deserializeWith m = V1 `liftM` m++instance Serial a => Serial (V1 a) where+ serialize (V1 a) = serialize a+ deserialize = V1 `liftM` deserialize++instance Binary a => Binary (V1 a) where+ put = serializeWith Binary.put+ get = deserializeWith Binary.get++instance Serialize a => Serialize (V1 a) where+ put = serializeWith Cereal.put+ get = deserializeWith Cereal.get++instance Random a => Random (V1 a) where+ random g = case random g of (a, g') -> (V1 a, g')+ randoms g = V1 <$> randoms g+ randomR (V1 a, V1 b) g = case randomR (a, b) g of (a', g') -> (V1 a', g')+ randomRs (V1 a, V1 b) g = V1 <$> randomRs (a, b) g++instance Eq1 V1 where+ liftEq f (V1 a) (V1 b) = f a b+instance Ord1 V1 where+ liftCompare f (V1 a) (V1 b) = f a b+instance Show1 V1 where+ liftShowsPrec f _ d (V1 a) = showParen (d >= 10) $ showString "V1 " . f d a+instance Read1 V1 where+ liftReadsPrec f _ = readsData $ readsUnaryWith f "V1" V1++instance Field1 (V1 a) (V1 b) a b where+ _1 f (V1 x) = V1 <$> f x++instance Semigroup a => Semigroup (V1 a) where+ (<>) = liftA2 (<>)++instance Monoid a => Monoid (V1 a) where+ mempty = pure mempty+#if !(MIN_VERSION_base(4,11,0))+ mappend = liftA2 mappend+#endif+
src/Linear/V2.hs view
@@ -1,501 +1,501 @@-{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveLift #-} - -#ifndef MIN_VERSION_hashable -#define MIN_VERSION_hashable(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_vector -#define MIN_VERSION_vector(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_transformers -#define MIN_VERSION_transformers(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_base -#define MIN_VERSION_base(x,y,z) 1 -#endif - ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2012-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : experimental --- Portability : non-portable --- --- 2-D Vectors ----------------------------------------------------------------------------- -module Linear.V2 - ( V2(..) - , R1(..) - , R2(..) - , _yx - , ex, ey - , perp - , angle - , unangle - , crossZ - ) where - -import Control.Applicative -import Control.DeepSeq (NFData(rnf)) -import Control.Monad (liftM) -import Control.Monad.Fix -import Control.Monad.Zip -import Control.Lens as Lens hiding ((<.>)) -import Data.Binary as Binary -import Data.Bytes.Serial -import Data.Data -import Data.Distributive -import Data.Foldable -import qualified Data.Foldable.WithIndex as WithIndex -import Data.Functor.Bind -import Data.Functor.Classes -import Data.Functor.Rep -import qualified Data.Functor.WithIndex as WithIndex -import Data.Hashable -import Data.Hashable.Lifted -import Data.Semigroup -import Data.Semigroup.Foldable -import Data.Serialize as Cereal -import qualified Data.Traversable.WithIndex as WithIndex -import qualified Data.Vector as V -import Foreign.Ptr (castPtr) -import Foreign.Storable (Storable(..)) -import GHC.Arr (Ix(..)) -import GHC.Generics (Generic, Generic1) -#if defined(MIN_VERSION_template_haskell) -import Language.Haskell.TH.Syntax (Lift) -#endif -import qualified Data.Vector.Generic.Mutable as M -import qualified Data.Vector.Generic as G -import qualified Data.Vector.Unboxed.Base as U -import Linear.Metric -import Linear.Epsilon -import Linear.V -import Linear.Vector -import Linear.V1 (R1(..),ex) -import Prelude hiding (sum) -import System.Random (Random(..)) - --- $setup --- >>> import Control.Applicative --- >>> import Control.Lens --- >>> import qualified Data.Foldable as F --- >>> let sum xs = F.sum xs - --- | A 2-dimensional vector --- --- >>> pure 1 :: V2 Int --- V2 1 1 --- --- >>> V2 1 2 + V2 3 4 --- V2 4 6 --- --- >>> V2 1 2 * V2 3 4 --- V2 3 8 --- --- >>> sum (V2 1 2) --- 3 - -data V2 a = V2 !a !a deriving - (Eq,Ord,Show,Read,Data - ,Generic,Generic1 -#if defined(MIN_VERSION_template_haskell) - ,Lift -#endif - ) - -instance Finite V2 where - type Size V2 = 2 - toV (V2 a b) = V (V.fromListN 2 [a,b]) - fromV (V v) = V2 (v V.! 0) (v V.! 1) - -instance Random a => Random (V2 a) where - random g = case random g of - (a, g') -> case random g' of - (b, g'') -> (V2 a b, g'') - {-# inline random #-} - randomR (V2 a b, V2 c d) g = case randomR (a, c) g of - (x, g') -> case randomR (b, d) g' of - (y, g'') -> (V2 x y, g'') - {-# inline randomR #-} - -instance Functor V2 where - fmap f (V2 a b) = V2 (f a) (f b) - {-# INLINE fmap #-} - a <$ _ = V2 a a - {-# INLINE (<$) #-} - -instance Foldable V2 where - foldMap f (V2 a b) = f a `mappend` f b - {-# INLINE foldMap #-} -#if MIN_VERSION_base(4,13,0) - foldMap' f (V2 a b) = f a `mappend` f b - {-# INLINE foldMap' #-} -#endif - null _ = False - length _ = 2 - -instance Traversable V2 where - traverse f (V2 a b) = V2 <$> f a <*> f b - {-# INLINE traverse #-} - -instance Foldable1 V2 where - foldMap1 f (V2 a b) = f a <> f b - {-# INLINE foldMap1 #-} - -instance Traversable1 V2 where - traverse1 f (V2 a b) = V2 <$> f a <.> f b - {-# INLINE traverse1 #-} - -instance Apply V2 where - V2 a b <.> V2 d e = V2 (a d) (b e) - {-# INLINE (<.>) #-} - -instance Applicative V2 where - pure a = V2 a a - {-# INLINE pure #-} - V2 a b <*> V2 d e = V2 (a d) (b e) - {-# INLINE (<*>) #-} - -instance Hashable a => Hashable (V2 a) where - hashWithSalt s (V2 a b) = s `hashWithSalt` a `hashWithSalt` b - {-# INLINE hashWithSalt #-} - -instance Hashable1 V2 where - liftHashWithSalt h s (V2 a b) = s `h` a `h` b - {-# INLINE liftHashWithSalt #-} - -instance Additive V2 where - zero = pure 0 - {-# INLINE zero #-} - liftU2 = liftA2 - {-# INLINE liftU2 #-} - liftI2 = liftA2 - {-# INLINE liftI2 #-} - -instance Bind V2 where - V2 a b >>- f = V2 a' b' where - V2 a' _ = f a - V2 _ b' = f b - {-# INLINE (>>-) #-} - -instance Monad V2 where -#if !(MIN_VERSION_base(4,11,0)) - return a = V2 a a - {-# INLINE return #-} -#endif - V2 a b >>= f = V2 a' b' where - V2 a' _ = f a - V2 _ b' = f b - {-# INLINE (>>=) #-} - -instance Num a => Num (V2 a) where - (+) = liftA2 (+) - {-# INLINE (+) #-} - (-) = liftA2 (-) - {-# INLINE (-) #-} - (*) = liftA2 (*) - {-# INLINE (*) #-} - negate = fmap negate - {-# INLINE negate #-} - abs = fmap abs - {-# INLINE abs #-} - signum = fmap signum - {-# INLINE signum #-} - fromInteger = pure . fromInteger - {-# INLINE fromInteger #-} - -instance Fractional a => Fractional (V2 a) where - recip = fmap recip - {-# INLINE recip #-} - (/) = liftA2 (/) - {-# INLINE (/) #-} - fromRational = pure . fromRational - {-# INLINE fromRational #-} - -instance Floating a => Floating (V2 a) where - pi = pure pi - {-# INLINE pi #-} - exp = fmap exp - {-# INLINE exp #-} - sqrt = fmap sqrt - {-# INLINE sqrt #-} - log = fmap log - {-# INLINE log #-} - (**) = liftA2 (**) - {-# INLINE (**) #-} - logBase = liftA2 logBase - {-# INLINE logBase #-} - sin = fmap sin - {-# INLINE sin #-} - tan = fmap tan - {-# INLINE tan #-} - cos = fmap cos - {-# INLINE cos #-} - asin = fmap asin - {-# INLINE asin #-} - atan = fmap atan - {-# INLINE atan #-} - acos = fmap acos - {-# INLINE acos #-} - sinh = fmap sinh - {-# INLINE sinh #-} - tanh = fmap tanh - {-# INLINE tanh #-} - cosh = fmap cosh - {-# INLINE cosh #-} - asinh = fmap asinh - {-# INLINE asinh #-} - atanh = fmap atanh - {-# INLINE atanh #-} - acosh = fmap acosh - {-# INLINE acosh #-} - -instance Metric V2 where - dot (V2 a b) (V2 c d) = a * c + b * d - {-# INLINE dot #-} - --- | A space that distinguishes 2 orthogonal basis vectors '_x' and '_y', but may have more. -class R1 t => R2 t where - -- | - -- >>> V2 1 2 ^._y - -- 2 - -- - -- >>> V2 1 2 & _y .~ 3 - -- V2 1 3 - -- - _y :: Lens' (t a) a - _y = _xy._y - {-# INLINE _y #-} - - _xy :: Lens' (t a) (V2 a) - --- | --- >>> V2 1 2 ^. _yx --- V2 2 1 -_yx :: R2 t => Lens' (t a) (V2 a) -_yx f = _xy $ \(V2 a b) -> f (V2 b a) <&> \(V2 b' a') -> V2 a' b' -{-# INLINE _yx #-} - -ey :: R2 t => E t -ey = E _y - -instance R1 V2 where - _x f (V2 a b) = (`V2` b) <$> f a - {-# INLINE _x #-} - -instance R2 V2 where - _y f (V2 a b) = V2 a <$> f b - {-# INLINE _y #-} - _xy = id - {-# INLINE _xy #-} - -instance Distributive V2 where - distribute f = V2 (fmap (\(V2 x _) -> x) f) (fmap (\(V2 _ y) -> y) f) - {-# INLINE distribute #-} - --- | the counter-clockwise perpendicular vector --- --- >>> perp $ V2 10 20 --- V2 (-20) 10 -perp :: Num a => V2 a -> V2 a -perp (V2 a b) = V2 (negate b) a -{-# INLINE perp #-} - -instance Epsilon a => Epsilon (V2 a) where - nearZero = nearZero . quadrance - {-# INLINE nearZero #-} - -instance Storable a => Storable (V2 a) where - sizeOf _ = 2 * sizeOf (undefined::a) - {-# INLINE sizeOf #-} - alignment _ = alignment (undefined::a) - {-# INLINE alignment #-} - poke ptr (V2 x y) = poke ptr' x >> pokeElemOff ptr' 1 y - where ptr' = castPtr ptr - {-# INLINE poke #-} - peek ptr = V2 <$> peek ptr' <*> peekElemOff ptr' 1 - where ptr' = castPtr ptr - {-# INLINE peek #-} - -instance Ix a => Ix (V2 a) where - {-# SPECIALISE instance Ix (V2 Int) #-} - - range (V2 l1 l2,V2 u1 u2) = - [ V2 i1 i2 | i1 <- range (l1,u1), i2 <- range (l2,u2) ] - {-# INLINE range #-} - - unsafeIndex (V2 l1 l2,V2 u1 u2) (V2 i1 i2) = - unsafeIndex (l1,u1) i1 * unsafeRangeSize (l2,u2) + unsafeIndex (l2,u2) i2 - {-# INLINE unsafeIndex #-} - - inRange (V2 l1 l2,V2 u1 u2) (V2 i1 i2) = - inRange (l1,u1) i1 && inRange (l2,u2) i2 - {-# INLINE inRange #-} - -instance Representable V2 where - type Rep V2 = E V2 - tabulate f = V2 (f ex) (f ey) - {-# INLINE tabulate #-} - index xs (E l) = view l xs - {-# INLINE index #-} - -instance WithIndex.FunctorWithIndex (E V2) V2 where - imap f (V2 a b) = V2 (f ex a) (f ey b) - {-# INLINE imap #-} - -instance WithIndex.FoldableWithIndex (E V2) V2 where - ifoldMap f (V2 a b) = f ex a `mappend` f ey b - {-# INLINE ifoldMap #-} - -instance WithIndex.TraversableWithIndex (E V2) V2 where - itraverse f (V2 a b) = V2 <$> f ex a <*> f ey b - {-# INLINE itraverse #-} - -#if !MIN_VERSION_lens(5,0,0) -instance Lens.FunctorWithIndex (E V2) V2 where imap = WithIndex.imap -instance Lens.FoldableWithIndex (E V2) V2 where ifoldMap = WithIndex.ifoldMap -instance Lens.TraversableWithIndex (E V2) V2 where itraverse = WithIndex.itraverse -#endif - -type instance Index (V2 a) = E V2 -type instance IxValue (V2 a) = a - -instance Ixed (V2 a) where - ix i = el i - {-# INLINE ix #-} - -instance Each (V2 a) (V2 b) a b where - each = traverse - {-# INLINE each #-} - -data instance U.Vector (V2 a) = V_V2 {-# UNPACK #-} !Int !(U.Vector a) -data instance U.MVector s (V2 a) = MV_V2 {-# UNPACK #-} !Int !(U.MVector s a) -instance U.Unbox a => U.Unbox (V2 a) - -instance U.Unbox a => M.MVector U.MVector (V2 a) where - {-# INLINE basicLength #-} - {-# INLINE basicUnsafeSlice #-} - {-# INLINE basicOverlaps #-} - {-# INLINE basicUnsafeNew #-} - {-# INLINE basicUnsafeRead #-} - {-# INLINE basicUnsafeWrite #-} - basicLength (MV_V2 n _) = n - basicUnsafeSlice m n (MV_V2 _ v) = MV_V2 n (M.basicUnsafeSlice (2*m) (2*n) v) - basicOverlaps (MV_V2 _ v) (MV_V2 _ u) = M.basicOverlaps v u - basicUnsafeNew n = liftM (MV_V2 n) (M.basicUnsafeNew (2*n)) - basicUnsafeRead (MV_V2 _ v) i = - do let o = 2*i - x <- M.basicUnsafeRead v o - y <- M.basicUnsafeRead v (o+1) - return (V2 x y) - basicUnsafeWrite (MV_V2 _ v) i (V2 x y) = - do let o = 2*i - M.basicUnsafeWrite v o x - M.basicUnsafeWrite v (o+1) y - basicInitialize (MV_V2 _ v) = M.basicInitialize v - {-# INLINE basicInitialize #-} - -instance U.Unbox a => G.Vector U.Vector (V2 a) where - {-# INLINE basicUnsafeFreeze #-} - {-# INLINE basicUnsafeThaw #-} - {-# INLINE basicLength #-} - {-# INLINE basicUnsafeSlice #-} - {-# INLINE basicUnsafeIndexM #-} - basicUnsafeFreeze (MV_V2 n v) = liftM ( V_V2 n) (G.basicUnsafeFreeze v) - basicUnsafeThaw ( V_V2 n v) = liftM (MV_V2 n) (G.basicUnsafeThaw v) - basicLength ( V_V2 n _) = n - basicUnsafeSlice m n (V_V2 _ v) = V_V2 n (G.basicUnsafeSlice (2*m) (2*n) v) - basicUnsafeIndexM (V_V2 _ v) i = - do let o = 2*i - x <- G.basicUnsafeIndexM v o - y <- G.basicUnsafeIndexM v (o+1) - return (V2 x y) - -instance MonadZip V2 where - mzipWith = liftA2 - -instance MonadFix V2 where - mfix f = V2 (let V2 a _ = f a in a) - (let V2 _ a = f a in a) - -angle :: Floating a => a -> V2 a -angle a = V2 (cos a) (sin a) - -unangle :: (Floating a, Ord a) => V2 a -> a -unangle a@(V2 ax ay) = - let alpha = asin $ ay / norm a - in if ax < 0 - then pi - alpha - else alpha - --- | The Z-component of the cross product of two vectors in the XY-plane. --- --- >>> crossZ (V2 1 0) (V2 0 1) --- 1 -crossZ :: Num a => V2 a -> V2 a -> a -crossZ (V2 x1 y1) (V2 x2 y2) = x1*y2 - y1*x2 -{-# INLINE crossZ #-} - -instance Bounded a => Bounded (V2 a) where - minBound = pure minBound - {-# INLINE minBound #-} - maxBound = pure maxBound - {-# INLINE maxBound #-} - -instance NFData a => NFData (V2 a) where - rnf (V2 a b) = rnf a `seq` rnf b - -instance Serial1 V2 where - serializeWith = traverse_ - deserializeWith k = V2 <$> k <*> k - -instance Serial a => Serial (V2 a) where - serialize = serializeWith serialize - deserialize = deserializeWith deserialize - -instance Binary a => Binary (V2 a) where - put = serializeWith Binary.put - get = deserializeWith Binary.get - -instance Serialize a => Serialize (V2 a) where - put = serializeWith Cereal.put - get = deserializeWith Cereal.get - -instance Eq1 V2 where - liftEq f (V2 a b) (V2 c d) = f a c && f b d -instance Ord1 V2 where - liftCompare f (V2 a b) (V2 c d) = f a c `mappend` f b d -instance Read1 V2 where - liftReadsPrec f _ = readsData $ readsBinaryWith f f "V2" V2 -instance Show1 V2 where - liftShowsPrec f _ d (V2 a b) = showsBinaryWith f f "V2" d a b - -instance Field1 (V2 a) (V2 a) a a where - _1 f (V2 x y) = f x <&> \x' -> V2 x' y - -instance Field2 (V2 a) (V2 a) a a where - _2 f (V2 x y) = f y <&> \y' -> V2 x y' - -instance Semigroup a => Semigroup (V2 a) where - (<>) = liftA2 (<>) - -instance Monoid a => Monoid (V2 a) where - mempty = pure mempty -#if !(MIN_VERSION_base(4,11,0)) - mappend = liftA2 mappend -#endif +{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveLift #-}++#ifndef MIN_VERSION_hashable+#define MIN_VERSION_hashable(x,y,z) 1+#endif++#ifndef MIN_VERSION_vector+#define MIN_VERSION_vector(x,y,z) 1+#endif++#ifndef MIN_VERSION_transformers+#define MIN_VERSION_transformers(x,y,z) 1+#endif++#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1+#endif++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2012-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- 2-D Vectors+----------------------------------------------------------------------------+module Linear.V2+ ( V2(..)+ , R1(..)+ , R2(..)+ , _yx+ , ex, ey+ , perp+ , angle+ , unangle+ , crossZ+ ) where++import Control.Applicative+import Control.DeepSeq (NFData(rnf))+import Control.Monad (liftM)+import Control.Monad.Fix+import Control.Monad.Zip+import Control.Lens as Lens hiding ((<.>))+import Data.Binary as Binary+import Data.Bytes.Serial+import Data.Data+import Data.Distributive+import Data.Foldable+import qualified Data.Foldable.WithIndex as WithIndex+import Data.Functor.Bind+import Data.Functor.Classes+import Data.Functor.Rep+import qualified Data.Functor.WithIndex as WithIndex+import Data.Hashable+import Data.Hashable.Lifted+import Data.Semigroup+import Data.Semigroup.Foldable+import Data.Serialize as Cereal+import qualified Data.Traversable.WithIndex as WithIndex+import qualified Data.Vector as V+import Foreign.Ptr (castPtr)+import Foreign.Storable (Storable(..))+import GHC.Arr (Ix(..))+import GHC.Generics (Generic, Generic1)+#if defined(MIN_VERSION_template_haskell)+import Language.Haskell.TH.Syntax (Lift)+#endif+import qualified Data.Vector.Generic.Mutable as M+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Unboxed.Base as U+import Linear.Metric+import Linear.Epsilon+import Linear.V+import Linear.Vector+import Linear.V1 (R1(..),ex)+import Prelude hiding (sum)+import System.Random (Random(..))++-- $setup+-- >>> import Control.Applicative+-- >>> import Control.Lens+-- >>> import qualified Data.Foldable as F+-- >>> let sum xs = F.sum xs++-- | A 2-dimensional vector+--+-- >>> pure 1 :: V2 Int+-- V2 1 1+--+-- >>> V2 1 2 + V2 3 4+-- V2 4 6+--+-- >>> V2 1 2 * V2 3 4+-- V2 3 8+--+-- >>> sum (V2 1 2)+-- 3++data V2 a = V2 !a !a deriving+ (Eq,Ord,Show,Read,Data+ ,Generic,Generic1+#if defined(MIN_VERSION_template_haskell)+ ,Lift+#endif+ )++instance Finite V2 where+ type Size V2 = 2+ toV (V2 a b) = V (V.fromListN 2 [a,b])+ fromV (V v) = V2 (v V.! 0) (v V.! 1)++instance Random a => Random (V2 a) where+ random g = case random g of+ (a, g') -> case random g' of+ (b, g'') -> (V2 a b, g'')+ {-# inline random #-}+ randomR (V2 a b, V2 c d) g = case randomR (a, c) g of+ (x, g') -> case randomR (b, d) g' of+ (y, g'') -> (V2 x y, g'')+ {-# inline randomR #-}++instance Functor V2 where+ fmap f (V2 a b) = V2 (f a) (f b)+ {-# INLINE fmap #-}+ a <$ _ = V2 a a+ {-# INLINE (<$) #-}++instance Foldable V2 where+ foldMap f (V2 a b) = f a `mappend` f b+ {-# INLINE foldMap #-}+#if MIN_VERSION_base(4,13,0)+ foldMap' f (V2 a b) = f a `mappend` f b+ {-# INLINE foldMap' #-}+#endif+ null _ = False+ length _ = 2++instance Traversable V2 where+ traverse f (V2 a b) = V2 <$> f a <*> f b+ {-# INLINE traverse #-}++instance Foldable1 V2 where+ foldMap1 f (V2 a b) = f a <> f b+ {-# INLINE foldMap1 #-}++instance Traversable1 V2 where+ traverse1 f (V2 a b) = V2 <$> f a <.> f b+ {-# INLINE traverse1 #-}++instance Apply V2 where+ V2 a b <.> V2 d e = V2 (a d) (b e)+ {-# INLINE (<.>) #-}++instance Applicative V2 where+ pure a = V2 a a+ {-# INLINE pure #-}+ V2 a b <*> V2 d e = V2 (a d) (b e)+ {-# INLINE (<*>) #-}++instance Hashable a => Hashable (V2 a) where+ hashWithSalt s (V2 a b) = s `hashWithSalt` a `hashWithSalt` b+ {-# INLINE hashWithSalt #-}++instance Hashable1 V2 where+ liftHashWithSalt h s (V2 a b) = s `h` a `h` b+ {-# INLINE liftHashWithSalt #-}++instance Additive V2 where+ zero = pure 0+ {-# INLINE zero #-}+ liftU2 = liftA2+ {-# INLINE liftU2 #-}+ liftI2 = liftA2+ {-# INLINE liftI2 #-}++instance Bind V2 where+ V2 a b >>- f = V2 a' b' where+ V2 a' _ = f a+ V2 _ b' = f b+ {-# INLINE (>>-) #-}++instance Monad V2 where+#if !(MIN_VERSION_base(4,11,0))+ return a = V2 a a+ {-# INLINE return #-}+#endif+ V2 a b >>= f = V2 a' b' where+ V2 a' _ = f a+ V2 _ b' = f b+ {-# INLINE (>>=) #-}++instance Num a => Num (V2 a) where+ (+) = liftA2 (+)+ {-# INLINE (+) #-}+ (-) = liftA2 (-)+ {-# INLINE (-) #-}+ (*) = liftA2 (*)+ {-# INLINE (*) #-}+ negate = fmap negate+ {-# INLINE negate #-}+ abs = fmap abs+ {-# INLINE abs #-}+ signum = fmap signum+ {-# INLINE signum #-}+ fromInteger = pure . fromInteger+ {-# INLINE fromInteger #-}++instance Fractional a => Fractional (V2 a) where+ recip = fmap recip+ {-# INLINE recip #-}+ (/) = liftA2 (/)+ {-# INLINE (/) #-}+ fromRational = pure . fromRational+ {-# INLINE fromRational #-}++instance Floating a => Floating (V2 a) where+ pi = pure pi+ {-# INLINE pi #-}+ exp = fmap exp+ {-# INLINE exp #-}+ sqrt = fmap sqrt+ {-# INLINE sqrt #-}+ log = fmap log+ {-# INLINE log #-}+ (**) = liftA2 (**)+ {-# INLINE (**) #-}+ logBase = liftA2 logBase+ {-# INLINE logBase #-}+ sin = fmap sin+ {-# INLINE sin #-}+ tan = fmap tan+ {-# INLINE tan #-}+ cos = fmap cos+ {-# INLINE cos #-}+ asin = fmap asin+ {-# INLINE asin #-}+ atan = fmap atan+ {-# INLINE atan #-}+ acos = fmap acos+ {-# INLINE acos #-}+ sinh = fmap sinh+ {-# INLINE sinh #-}+ tanh = fmap tanh+ {-# INLINE tanh #-}+ cosh = fmap cosh+ {-# INLINE cosh #-}+ asinh = fmap asinh+ {-# INLINE asinh #-}+ atanh = fmap atanh+ {-# INLINE atanh #-}+ acosh = fmap acosh+ {-# INLINE acosh #-}++instance Metric V2 where+ dot (V2 a b) (V2 c d) = a * c + b * d+ {-# INLINE dot #-}++-- | A space that distinguishes 2 orthogonal basis vectors '_x' and '_y', but may have more.+class R1 t => R2 t where+ -- |+ -- >>> V2 1 2 ^._y+ -- 2+ --+ -- >>> V2 1 2 & _y .~ 3+ -- V2 1 3+ --+ _y :: Lens' (t a) a+ _y = _xy._y+ {-# INLINE _y #-}++ _xy :: Lens' (t a) (V2 a)++-- |+-- >>> V2 1 2 ^. _yx+-- V2 2 1+_yx :: R2 t => Lens' (t a) (V2 a)+_yx f = _xy $ \(V2 a b) -> f (V2 b a) <&> \(V2 b' a') -> V2 a' b'+{-# INLINE _yx #-}++ey :: R2 t => E t+ey = E _y++instance R1 V2 where+ _x f (V2 a b) = (`V2` b) <$> f a+ {-# INLINE _x #-}++instance R2 V2 where+ _y f (V2 a b) = V2 a <$> f b+ {-# INLINE _y #-}+ _xy = id+ {-# INLINE _xy #-}++instance Distributive V2 where+ distribute f = V2 (fmap (\(V2 x _) -> x) f) (fmap (\(V2 _ y) -> y) f)+ {-# INLINE distribute #-}++-- | the counter-clockwise perpendicular vector+--+-- >>> perp $ V2 10 20+-- V2 (-20) 10+perp :: Num a => V2 a -> V2 a+perp (V2 a b) = V2 (negate b) a+{-# INLINE perp #-}++instance Epsilon a => Epsilon (V2 a) where+ nearZero = nearZero . quadrance+ {-# INLINE nearZero #-}++instance Storable a => Storable (V2 a) where+ sizeOf _ = 2 * sizeOf (undefined::a)+ {-# INLINE sizeOf #-}+ alignment _ = alignment (undefined::a)+ {-# INLINE alignment #-}+ poke ptr (V2 x y) = poke ptr' x >> pokeElemOff ptr' 1 y+ where ptr' = castPtr ptr+ {-# INLINE poke #-}+ peek ptr = V2 <$> peek ptr' <*> peekElemOff ptr' 1+ where ptr' = castPtr ptr+ {-# INLINE peek #-}++instance Ix a => Ix (V2 a) where+ {-# SPECIALISE instance Ix (V2 Int) #-}++ range (V2 l1 l2,V2 u1 u2) =+ [ V2 i1 i2 | i1 <- range (l1,u1), i2 <- range (l2,u2) ]+ {-# INLINE range #-}++ unsafeIndex (V2 l1 l2,V2 u1 u2) (V2 i1 i2) =+ unsafeIndex (l1,u1) i1 * unsafeRangeSize (l2,u2) + unsafeIndex (l2,u2) i2+ {-# INLINE unsafeIndex #-}++ inRange (V2 l1 l2,V2 u1 u2) (V2 i1 i2) =+ inRange (l1,u1) i1 && inRange (l2,u2) i2+ {-# INLINE inRange #-}++instance Representable V2 where+ type Rep V2 = E V2+ tabulate f = V2 (f ex) (f ey)+ {-# INLINE tabulate #-}+ index xs (E l) = view l xs+ {-# INLINE index #-}++instance WithIndex.FunctorWithIndex (E V2) V2 where+ imap f (V2 a b) = V2 (f ex a) (f ey b)+ {-# INLINE imap #-}++instance WithIndex.FoldableWithIndex (E V2) V2 where+ ifoldMap f (V2 a b) = f ex a `mappend` f ey b+ {-# INLINE ifoldMap #-}++instance WithIndex.TraversableWithIndex (E V2) V2 where+ itraverse f (V2 a b) = V2 <$> f ex a <*> f ey b+ {-# INLINE itraverse #-}++#if !MIN_VERSION_lens(5,0,0)+instance Lens.FunctorWithIndex (E V2) V2 where imap = WithIndex.imap+instance Lens.FoldableWithIndex (E V2) V2 where ifoldMap = WithIndex.ifoldMap+instance Lens.TraversableWithIndex (E V2) V2 where itraverse = WithIndex.itraverse+#endif++type instance Index (V2 a) = E V2+type instance IxValue (V2 a) = a++instance Ixed (V2 a) where+ ix i = el i+ {-# INLINE ix #-}++instance Each (V2 a) (V2 b) a b where+ each = traverse+ {-# INLINE each #-}++data instance U.Vector (V2 a) = V_V2 {-# UNPACK #-} !Int !(U.Vector a)+data instance U.MVector s (V2 a) = MV_V2 {-# UNPACK #-} !Int !(U.MVector s a)+instance U.Unbox a => U.Unbox (V2 a)++instance U.Unbox a => M.MVector U.MVector (V2 a) where+ {-# INLINE basicLength #-}+ {-# INLINE basicUnsafeSlice #-}+ {-# INLINE basicOverlaps #-}+ {-# INLINE basicUnsafeNew #-}+ {-# INLINE basicUnsafeRead #-}+ {-# INLINE basicUnsafeWrite #-}+ basicLength (MV_V2 n _) = n+ basicUnsafeSlice m n (MV_V2 _ v) = MV_V2 n (M.basicUnsafeSlice (2*m) (2*n) v)+ basicOverlaps (MV_V2 _ v) (MV_V2 _ u) = M.basicOverlaps v u+ basicUnsafeNew n = liftM (MV_V2 n) (M.basicUnsafeNew (2*n))+ basicUnsafeRead (MV_V2 _ v) i =+ do let o = 2*i+ x <- M.basicUnsafeRead v o+ y <- M.basicUnsafeRead v (o+1)+ return (V2 x y)+ basicUnsafeWrite (MV_V2 _ v) i (V2 x y) =+ do let o = 2*i+ M.basicUnsafeWrite v o x+ M.basicUnsafeWrite v (o+1) y+ basicInitialize (MV_V2 _ v) = M.basicInitialize v+ {-# INLINE basicInitialize #-}++instance U.Unbox a => G.Vector U.Vector (V2 a) where+ {-# INLINE basicUnsafeFreeze #-}+ {-# INLINE basicUnsafeThaw #-}+ {-# INLINE basicLength #-}+ {-# INLINE basicUnsafeSlice #-}+ {-# INLINE basicUnsafeIndexM #-}+ basicUnsafeFreeze (MV_V2 n v) = liftM ( V_V2 n) (G.basicUnsafeFreeze v)+ basicUnsafeThaw ( V_V2 n v) = liftM (MV_V2 n) (G.basicUnsafeThaw v)+ basicLength ( V_V2 n _) = n+ basicUnsafeSlice m n (V_V2 _ v) = V_V2 n (G.basicUnsafeSlice (2*m) (2*n) v)+ basicUnsafeIndexM (V_V2 _ v) i =+ do let o = 2*i+ x <- G.basicUnsafeIndexM v o+ y <- G.basicUnsafeIndexM v (o+1)+ return (V2 x y)++instance MonadZip V2 where+ mzipWith = liftA2++instance MonadFix V2 where+ mfix f = V2 (let V2 a _ = f a in a)+ (let V2 _ a = f a in a)++angle :: Floating a => a -> V2 a+angle a = V2 (cos a) (sin a)++unangle :: (Floating a, Ord a) => V2 a -> a+unangle a@(V2 ax ay) =+ let alpha = asin $ ay / norm a+ in if ax < 0+ then pi - alpha+ else alpha++-- | The Z-component of the cross product of two vectors in the XY-plane.+--+-- >>> crossZ (V2 1 0) (V2 0 1)+-- 1+crossZ :: Num a => V2 a -> V2 a -> a+crossZ (V2 x1 y1) (V2 x2 y2) = x1*y2 - y1*x2+{-# INLINE crossZ #-}++instance Bounded a => Bounded (V2 a) where+ minBound = pure minBound+ {-# INLINE minBound #-}+ maxBound = pure maxBound+ {-# INLINE maxBound #-}++instance NFData a => NFData (V2 a) where+ rnf (V2 a b) = rnf a `seq` rnf b++instance Serial1 V2 where+ serializeWith = traverse_+ deserializeWith k = V2 <$> k <*> k++instance Serial a => Serial (V2 a) where+ serialize = serializeWith serialize+ deserialize = deserializeWith deserialize++instance Binary a => Binary (V2 a) where+ put = serializeWith Binary.put+ get = deserializeWith Binary.get++instance Serialize a => Serialize (V2 a) where+ put = serializeWith Cereal.put+ get = deserializeWith Cereal.get++instance Eq1 V2 where+ liftEq f (V2 a b) (V2 c d) = f a c && f b d+instance Ord1 V2 where+ liftCompare f (V2 a b) (V2 c d) = f a c `mappend` f b d+instance Read1 V2 where+ liftReadsPrec f _ = readsData $ readsBinaryWith f f "V2" V2+instance Show1 V2 where+ liftShowsPrec f _ d (V2 a b) = showsBinaryWith f f "V2" d a b++instance Field1 (V2 a) (V2 a) a a where+ _1 f (V2 x y) = f x <&> \x' -> V2 x' y++instance Field2 (V2 a) (V2 a) a a where+ _2 f (V2 x y) = f y <&> \y' -> V2 x y'++instance Semigroup a => Semigroup (V2 a) where+ (<>) = liftA2 (<>)++instance Monoid a => Monoid (V2 a) where+ mempty = pure mempty+#if !(MIN_VERSION_base(4,11,0))+ mappend = liftA2 mappend+#endif
src/Linear/V3.hs view
@@ -1,514 +1,516 @@-{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveLift #-} - -#ifndef MIN_VERSION_hashable -#define MIN_VERSION_hashable(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_vector -#define MIN_VERSION_vector(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_transformers -#define MIN_VERSION_transformers(x,y,z) 1 -#endif - ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2012-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : experimental --- Portability : non-portable --- --- 3-D Vectors ----------------------------------------------------------------------------- -module Linear.V3 - ( V3(..) - , cross, triple - , R1(..) - , R2(..) - , _yx - , R3(..) - , _xz, _yz, _zx, _zy - , _xzy, _yxz, _yzx, _zxy, _zyx - , ex, ey, ez - ) where - -import Control.Applicative -import Control.DeepSeq (NFData(rnf)) -import Control.Monad (liftM) -import Control.Monad.Fix -import Control.Monad.Zip -import Control.Lens as Lens hiding ((<.>)) -import Data.Binary as Binary -- binary -import Data.Bytes.Serial -- bytes -import Data.Data -import Data.Distributive -import Data.Foldable -import qualified Data.Foldable.WithIndex as WithIndex -import Data.Functor.Bind -import Data.Functor.Classes -import Data.Functor.Rep -import qualified Data.Functor.WithIndex as WithIndex -import Data.Hashable -import Data.Hashable.Lifted -#if !(MIN_VERSION_base(4,11,0)) -import Data.Semigroup -#endif -import Data.Semigroup.Foldable -import Data.Serialize as Cereal -- cereal -import qualified Data.Traversable.WithIndex as WithIndex -import qualified Data.Vector as V -import qualified Data.Vector.Generic.Mutable as M -import qualified Data.Vector.Generic as G -import qualified Data.Vector.Unboxed.Base as U -import Foreign.Ptr (castPtr) -import Foreign.Storable (Storable(..)) -import GHC.Arr (Ix(..)) -import GHC.Generics (Generic, Generic1) -#if defined(MIN_VERSION_template_haskell) -import Language.Haskell.TH.Syntax (Lift) -#endif -import Linear.Epsilon -import Linear.Metric -import Linear.V -import Linear.V2 -import Linear.Vector -import System.Random (Random(..)) - --- $setup --- >>> import Control.Lens hiding (index) - --- | A 3-dimensional vector -data V3 a = V3 !a !a !a deriving (Eq,Ord,Show,Read,Data - ,Generic,Generic1 -#if defined(MIN_VERSION_template_haskell) - ,Lift -#endif - ) - -instance Finite V3 where - type Size V3 = 3 - toV (V3 a b c) = V (V.fromListN 3 [a,b,c]) - fromV (V v) = V3 (v V.! 0) (v V.! 1) (v V.! 2) - -instance Functor V3 where - fmap f (V3 a b c) = V3 (f a) (f b) (f c) - {-# INLINE fmap #-} - a <$ _ = V3 a a a - {-# INLINE (<$) #-} - -instance Foldable V3 where - foldMap f (V3 a b c) = f a `mappend` f b `mappend` f c - {-# INLINE foldMap #-} -#if MIN_VERSION_base(4,13,0) - foldMap' f (V3 a b c) = (f a `mappend` f b) `mappend` f c - {-# INLINE foldMap' #-} -#endif - null _ = False - length _ = 3 - -instance Random a => Random (V3 a) where - random g = case random g of - (a, g') -> case random g' of - (b, g'') -> case random g'' of - (c, g''') -> (V3 a b c, g''') - randomR (V3 a b c, V3 a' b' c') g = case randomR (a,a') g of - (a'', g') -> case randomR (b,b') g' of - (b'', g'') -> case randomR (c,c') g'' of - (c'', g''') -> (V3 a'' b'' c'', g''') - -instance Traversable V3 where - traverse f (V3 a b c) = V3 <$> f a <*> f b <*> f c - {-# INLINE traverse #-} - -instance Foldable1 V3 where - foldMap1 f (V3 a b c) = f a <> f b <> f c - {-# INLINE foldMap1 #-} - -instance Traversable1 V3 where - traverse1 f (V3 a b c) = V3 <$> f a <.> f b <.> f c - {-# INLINE traverse1 #-} - -instance Apply V3 where - V3 a b c <.> V3 d e f = V3 (a d) (b e) (c f) - {-# INLINE (<.>) #-} - -instance Applicative V3 where - pure a = V3 a a a - {-# INLINE pure #-} - V3 a b c <*> V3 d e f = V3 (a d) (b e) (c f) - {-# INLINE (<*>) #-} - -instance Additive V3 where - zero = pure 0 - {-# INLINE zero #-} - liftU2 = liftA2 - {-# INLINE liftU2 #-} - liftI2 = liftA2 - {-# INLINE liftI2 #-} - -instance Bind V3 where - V3 a b c >>- f = V3 a' b' c' where - V3 a' _ _ = f a - V3 _ b' _ = f b - V3 _ _ c' = f c - {-# INLINE (>>-) #-} - -instance Monad V3 where -#if !(MIN_VERSION_base(4,11,0)) - return a = V3 a a a - {-# INLINE return #-} -#endif - V3 a b c >>= f = V3 a' b' c' where - V3 a' _ _ = f a - V3 _ b' _ = f b - V3 _ _ c' = f c - {-# INLINE (>>=) #-} - -instance Num a => Num (V3 a) where - (+) = liftA2 (+) - {-# INLINE (+) #-} - (-) = liftA2 (-) - {-# INLINE (-) #-} - (*) = liftA2 (*) - {-# INLINE (*) #-} - negate = fmap negate - {-# INLINE negate #-} - abs = fmap abs - {-# INLINE abs #-} - signum = fmap signum - {-# INLINE signum #-} - fromInteger = pure . fromInteger - {-# INLINE fromInteger #-} - -instance Fractional a => Fractional (V3 a) where - recip = fmap recip - {-# INLINE recip #-} - (/) = liftA2 (/) - {-# INLINE (/) #-} - fromRational = pure . fromRational - {-# INLINE fromRational #-} - -instance Floating a => Floating (V3 a) where - pi = pure pi - {-# INLINE pi #-} - exp = fmap exp - {-# INLINE exp #-} - sqrt = fmap sqrt - {-# INLINE sqrt #-} - log = fmap log - {-# INLINE log #-} - (**) = liftA2 (**) - {-# INLINE (**) #-} - logBase = liftA2 logBase - {-# INLINE logBase #-} - sin = fmap sin - {-# INLINE sin #-} - tan = fmap tan - {-# INLINE tan #-} - cos = fmap cos - {-# INLINE cos #-} - asin = fmap asin - {-# INLINE asin #-} - atan = fmap atan - {-# INLINE atan #-} - acos = fmap acos - {-# INLINE acos #-} - sinh = fmap sinh - {-# INLINE sinh #-} - tanh = fmap tanh - {-# INLINE tanh #-} - cosh = fmap cosh - {-# INLINE cosh #-} - asinh = fmap asinh - {-# INLINE asinh #-} - atanh = fmap atanh - {-# INLINE atanh #-} - acosh = fmap acosh - {-# INLINE acosh #-} - -instance Hashable a => Hashable (V3 a) where - hashWithSalt s (V3 a b c) = s `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c - {-# INLINE hashWithSalt #-} - -instance Hashable1 V3 where - liftHashWithSalt h s (V3 a b c) = s `h` a `h` b `h` c - {-# INLINE liftHashWithSalt #-} - -instance Metric V3 where - dot (V3 a b c) (V3 d e f) = a * d + b * e + c * f - {-# INLINABLE dot #-} - -instance Distributive V3 where - distribute f = V3 (fmap (\(V3 x _ _) -> x) f) (fmap (\(V3 _ y _) -> y) f) (fmap (\(V3 _ _ z) -> z) f) - {-# INLINE distribute #-} - --- | A space that distinguishes 3 orthogonal basis vectors: '_x', '_y', and '_z'. (It may have more) -class R2 t => R3 t where - -- | - -- >>> V3 1 2 3 ^. _z - -- 3 - _z :: Lens' (t a) a - - _xyz :: Lens' (t a) (V3 a) - -_xz, _yz, _zx, _zy :: R3 t => Lens' (t a) (V2 a) - -_xz f = _xyz $ \(V3 a b c) -> f (V2 a c) <&> \(V2 a' c') -> V3 a' b c' -{-# INLINE _xz #-} - -_yz f = _xyz $ \(V3 a b c) -> f (V2 b c) <&> \(V2 b' c') -> V3 a b' c' -{-# INLINE _yz #-} - -_zx f = _xyz $ \(V3 a b c) -> f (V2 c a) <&> \(V2 c' a') -> V3 a' b c' -{-# INLINE _zx #-} - -_zy f = _xyz $ \(V3 a b c) -> f (V2 c b) <&> \(V2 c' b') -> V3 a b' c' -{-# INLINE _zy #-} - -_xzy, _yxz, _yzx, _zxy, _zyx :: R3 t => Lens' (t a) (V3 a) - -_xzy f = _xyz $ \(V3 a b c) -> f (V3 a c b) <&> \(V3 a' c' b') -> V3 a' b' c' -{-# INLINE _xzy #-} - -_yxz f = _xyz $ \(V3 a b c) -> f (V3 b a c) <&> \(V3 b' a' c') -> V3 a' b' c' -{-# INLINE _yxz #-} - -_yzx f = _xyz $ \(V3 a b c) -> f (V3 b c a) <&> \(V3 b' c' a') -> V3 a' b' c' -{-# INLINE _yzx #-} - -_zxy f = _xyz $ \(V3 a b c) -> f (V3 c a b) <&> \(V3 c' a' b') -> V3 a' b' c' -{-# INLINE _zxy #-} - -_zyx f = _xyz $ \(V3 a b c) -> f (V3 c b a) <&> \(V3 c' b' a') -> V3 a' b' c' -{-# INLINE _zyx #-} - -ez :: R3 t => E t -ez = E _z - -instance R1 V3 where - _x f (V3 a b c) = (\a' -> V3 a' b c) <$> f a - {-# INLINE _x #-} - -instance R2 V3 where - _y f (V3 a b c) = (\b' -> V3 a b' c) <$> f b - {-# INLINE _y #-} - _xy f (V3 a b c) = (\(V2 a' b') -> V3 a' b' c) <$> f (V2 a b) - {-# INLINE _xy #-} - -instance R3 V3 where - _z f (V3 a b c) = V3 a b <$> f c - {-# INLINE _z #-} - _xyz = id - {-# INLINE _xyz #-} - -instance Storable a => Storable (V3 a) where - sizeOf _ = 3 * sizeOf (undefined::a) - {-# INLINE sizeOf #-} - alignment _ = alignment (undefined::a) - {-# INLINE alignment #-} - poke ptr (V3 x y z) = do poke ptr' x - pokeElemOff ptr' 1 y - pokeElemOff ptr' 2 z - where ptr' = castPtr ptr - {-# INLINE poke #-} - peek ptr = V3 <$> peek ptr' <*> peekElemOff ptr' 1 <*> peekElemOff ptr' 2 - where ptr' = castPtr ptr - {-# INLINE peek #-} - --- | cross product -cross :: Num a => V3 a -> V3 a -> V3 a -cross (V3 a b c) (V3 d e f) = V3 (b*f-c*e) (c*d-a*f) (a*e-b*d) -{-# INLINABLE cross #-} - --- | scalar triple product -triple :: Num a => V3 a -> V3 a -> V3 a -> a -triple a b c = dot a (cross b c) -{-# INLINE triple #-} - -instance Epsilon a => Epsilon (V3 a) where - nearZero = nearZero . quadrance - {-# INLINE nearZero #-} - -instance Ix a => Ix (V3 a) where - {-# SPECIALISE instance Ix (V3 Int) #-} - - range (V3 l1 l2 l3,V3 u1 u2 u3) = - [V3 i1 i2 i3 | i1 <- range (l1,u1) - , i2 <- range (l2,u2) - , i3 <- range (l3,u3) - ] - {-# INLINE range #-} - - unsafeIndex (V3 l1 l2 l3,V3 u1 u2 u3) (V3 i1 i2 i3) = - unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * ( - unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * - unsafeIndex (l1,u1) i1) - {-# INLINE unsafeIndex #-} - - inRange (V3 l1 l2 l3,V3 u1 u2 u3) (V3 i1 i2 i3) = - inRange (l1,u1) i1 && inRange (l2,u2) i2 && - inRange (l3,u3) i3 - {-# INLINE inRange #-} - -instance Representable V3 where - type Rep V3 = E V3 - tabulate f = V3 (f ex) (f ey) (f ez) - {-# INLINE tabulate #-} - index xs (E l) = view l xs - {-# INLINE index #-} - -instance WithIndex.FunctorWithIndex (E V3) V3 where - imap f (V3 a b c) = V3 (f ex a) (f ey b) (f ez c) - {-# INLINE imap #-} - -instance WithIndex.FoldableWithIndex (E V3) V3 where - ifoldMap f (V3 a b c) = f ex a `mappend` f ey b `mappend` f ez c - {-# INLINE ifoldMap #-} - -instance WithIndex.TraversableWithIndex (E V3) V3 where - itraverse f (V3 a b c) = V3 <$> f ex a <*> f ey b <*> f ez c - {-# INLINE itraverse #-} - -#if !MIN_VERSION_lens(5,0,0) -instance Lens.FunctorWithIndex (E V3) V3 where imap = WithIndex.imap -instance Lens.FoldableWithIndex (E V3) V3 where ifoldMap = WithIndex.ifoldMap -instance Lens.TraversableWithIndex (E V3) V3 where itraverse = WithIndex.itraverse -#endif - -type instance Index (V3 a) = E V3 -type instance IxValue (V3 a) = a - -instance Ixed (V3 a) where - ix i = el i - {-# INLINE ix #-} - -instance Each (V3 a) (V3 b) a b where - each = traverse - {-# INLINE each #-} - -data instance U.Vector (V3 a) = V_V3 {-# UNPACK #-} !Int !(U.Vector a) -data instance U.MVector s (V3 a) = MV_V3 {-# UNPACK #-} !Int !(U.MVector s a) -instance U.Unbox a => U.Unbox (V3 a) - -instance U.Unbox a => M.MVector U.MVector (V3 a) where - {-# INLINE basicLength #-} - {-# INLINE basicUnsafeSlice #-} - {-# INLINE basicOverlaps #-} - {-# INLINE basicUnsafeNew #-} - {-# INLINE basicUnsafeRead #-} - {-# INLINE basicUnsafeWrite #-} - basicLength (MV_V3 n _) = n - basicUnsafeSlice m n (MV_V3 _ v) = MV_V3 n (M.basicUnsafeSlice (3*m) (3*n) v) - basicOverlaps (MV_V3 _ v) (MV_V3 _ u) = M.basicOverlaps v u - basicUnsafeNew n = liftM (MV_V3 n) (M.basicUnsafeNew (3*n)) - basicUnsafeRead (MV_V3 _ v) i = - do let o = 3*i - x <- M.basicUnsafeRead v o - y <- M.basicUnsafeRead v (o+1) - z <- M.basicUnsafeRead v (o+2) - return (V3 x y z) - basicUnsafeWrite (MV_V3 _ v) i (V3 x y z) = - do let o = 3*i - M.basicUnsafeWrite v o x - M.basicUnsafeWrite v (o+1) y - M.basicUnsafeWrite v (o+2) z - basicInitialize (MV_V3 _ v) = M.basicInitialize v - {-# INLINE basicInitialize #-} - -instance U.Unbox a => G.Vector U.Vector (V3 a) where - {-# INLINE basicUnsafeFreeze #-} - {-# INLINE basicUnsafeThaw #-} - {-# INLINE basicLength #-} - {-# INLINE basicUnsafeSlice #-} - {-# INLINE basicUnsafeIndexM #-} - basicUnsafeFreeze (MV_V3 n v) = liftM ( V_V3 n) (G.basicUnsafeFreeze v) - basicUnsafeThaw ( V_V3 n v) = liftM (MV_V3 n) (G.basicUnsafeThaw v) - basicLength ( V_V3 n _) = n - basicUnsafeSlice m n (V_V3 _ v) = V_V3 n (G.basicUnsafeSlice (3*m) (3*n) v) - basicUnsafeIndexM (V_V3 _ v) i = - do let o = 3*i - x <- G.basicUnsafeIndexM v o - y <- G.basicUnsafeIndexM v (o+1) - z <- G.basicUnsafeIndexM v (o+2) - return (V3 x y z) - -instance MonadZip V3 where - mzipWith = liftA2 - -instance MonadFix V3 where - mfix f = V3 (let V3 a _ _ = f a in a) - (let V3 _ a _ = f a in a) - (let V3 _ _ a = f a in a) - -instance Bounded a => Bounded (V3 a) where - minBound = pure minBound - {-# INLINE minBound #-} - maxBound = pure maxBound - {-# INLINE maxBound #-} - -instance NFData a => NFData (V3 a) where - rnf (V3 a b c) = rnf a `seq` rnf b `seq` rnf c - -instance Serial1 V3 where - serializeWith = traverse_ - deserializeWith k = V3 <$> k <*> k <*> k - -instance Serial a => Serial (V3 a) where - serialize = serializeWith serialize - deserialize = deserializeWith deserialize - -instance Binary a => Binary (V3 a) where - put = serializeWith Binary.put - get = deserializeWith Binary.get - -instance Serialize a => Serialize (V3 a) where - put = serializeWith Cereal.put - get = deserializeWith Cereal.get - -instance Eq1 V3 where - liftEq k (V3 a b c) (V3 d e f) = k a d && k b e && k c f -instance Ord1 V3 where - liftCompare k (V3 a b c) (V3 d e f) = k a d `mappend` k b e `mappend` k c f -instance Read1 V3 where - liftReadsPrec k _ d = readParen (d > 10) $ \r -> - [ (V3 a b c, r4) - | ("V3",r1) <- lex r - , (a,r2) <- k 11 r1 - , (b,r3) <- k 11 r2 - , (c,r4) <- k 11 r3 - ] -instance Show1 V3 where - liftShowsPrec f _ d (V3 a b c) = showParen (d > 10) $ - showString "V3 " . f 11 a . showChar ' ' . f 11 b . showChar ' ' . f 11 c - -instance Field1 (V3 a) (V3 a) a a where - _1 f (V3 x y z) = f x <&> \x' -> V3 x' y z - -instance Field2 (V3 a) (V3 a) a a where - _2 f (V3 x y z) = f y <&> \y' -> V3 x y' z - -instance Field3 (V3 a) (V3 a) a a where - _3 f (V3 x y z) = f z <&> \z' -> V3 x y z' - -instance Semigroup a => Semigroup (V3 a) where - (<>) = liftA2 (<>) - -instance Monoid a => Monoid (V3 a) where - mempty = pure mempty -#if !(MIN_VERSION_base(4,11,0)) - mappend = liftA2 mappend -#endif - +{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveLift #-}++#ifndef MIN_VERSION_hashable+#define MIN_VERSION_hashable(x,y,z) 1+#endif++#ifndef MIN_VERSION_vector+#define MIN_VERSION_vector(x,y,z) 1+#endif++#ifndef MIN_VERSION_transformers+#define MIN_VERSION_transformers(x,y,z) 1+#endif++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2012-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- 3-D Vectors+----------------------------------------------------------------------------+module Linear.V3+ ( V3(..)+ , cross, triple+ , R1(..)+ , R2(..)+ , _yx+ , R3(..)+ , _xz, _yz, _zx, _zy+ , _xzy, _yxz, _yzx, _zxy, _zyx+ , ex, ey, ez+ ) where++#if !MIN_VERSION_base(4,18,0)+import Control.Applicative+#endif+import Control.DeepSeq (NFData(rnf))+import Control.Monad (liftM)+import Control.Monad.Fix+import Control.Monad.Zip+import Control.Lens as Lens hiding ((<.>))+import Data.Binary as Binary -- binary+import Data.Bytes.Serial -- bytes+import Data.Data+import Data.Distributive+import Data.Foldable+import qualified Data.Foldable.WithIndex as WithIndex+import Data.Functor.Bind+import Data.Functor.Classes+import Data.Functor.Rep+import qualified Data.Functor.WithIndex as WithIndex+import Data.Hashable+import Data.Hashable.Lifted+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup+#endif+import Data.Semigroup.Foldable+import Data.Serialize as Cereal -- cereal+import qualified Data.Traversable.WithIndex as WithIndex+import qualified Data.Vector as V+import qualified Data.Vector.Generic.Mutable as M+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Unboxed.Base as U+import Foreign.Ptr (castPtr)+import Foreign.Storable (Storable(..))+import GHC.Arr (Ix(..))+import GHC.Generics (Generic, Generic1)+#if defined(MIN_VERSION_template_haskell)+import Language.Haskell.TH.Syntax (Lift)+#endif+import Linear.Epsilon+import Linear.Metric+import Linear.V+import Linear.V2+import Linear.Vector+import System.Random (Random(..))++-- $setup+-- >>> import Control.Lens hiding (index)++-- | A 3-dimensional vector+data V3 a = V3 !a !a !a deriving (Eq,Ord,Show,Read,Data+ ,Generic,Generic1+#if defined(MIN_VERSION_template_haskell)+ ,Lift+#endif+ )++instance Finite V3 where+ type Size V3 = 3+ toV (V3 a b c) = V (V.fromListN 3 [a,b,c])+ fromV (V v) = V3 (v V.! 0) (v V.! 1) (v V.! 2)++instance Functor V3 where+ fmap f (V3 a b c) = V3 (f a) (f b) (f c)+ {-# INLINE fmap #-}+ a <$ _ = V3 a a a+ {-# INLINE (<$) #-}++instance Foldable V3 where+ foldMap f (V3 a b c) = f a `mappend` f b `mappend` f c+ {-# INLINE foldMap #-}+#if MIN_VERSION_base(4,13,0)+ foldMap' f (V3 a b c) = (f a `mappend` f b) `mappend` f c+ {-# INLINE foldMap' #-}+#endif+ null _ = False+ length _ = 3++instance Random a => Random (V3 a) where+ random g = case random g of+ (a, g') -> case random g' of+ (b, g'') -> case random g'' of+ (c, g''') -> (V3 a b c, g''')+ randomR (V3 a b c, V3 a' b' c') g = case randomR (a,a') g of+ (a'', g') -> case randomR (b,b') g' of+ (b'', g'') -> case randomR (c,c') g'' of+ (c'', g''') -> (V3 a'' b'' c'', g''')++instance Traversable V3 where+ traverse f (V3 a b c) = V3 <$> f a <*> f b <*> f c+ {-# INLINE traverse #-}++instance Foldable1 V3 where+ foldMap1 f (V3 a b c) = f a <> f b <> f c+ {-# INLINE foldMap1 #-}++instance Traversable1 V3 where+ traverse1 f (V3 a b c) = V3 <$> f a <.> f b <.> f c+ {-# INLINE traverse1 #-}++instance Apply V3 where+ V3 a b c <.> V3 d e f = V3 (a d) (b e) (c f)+ {-# INLINE (<.>) #-}++instance Applicative V3 where+ pure a = V3 a a a+ {-# INLINE pure #-}+ V3 a b c <*> V3 d e f = V3 (a d) (b e) (c f)+ {-# INLINE (<*>) #-}++instance Additive V3 where+ zero = pure 0+ {-# INLINE zero #-}+ liftU2 = liftA2+ {-# INLINE liftU2 #-}+ liftI2 = liftA2+ {-# INLINE liftI2 #-}++instance Bind V3 where+ V3 a b c >>- f = V3 a' b' c' where+ V3 a' _ _ = f a+ V3 _ b' _ = f b+ V3 _ _ c' = f c+ {-# INLINE (>>-) #-}++instance Monad V3 where+#if !(MIN_VERSION_base(4,11,0))+ return a = V3 a a a+ {-# INLINE return #-}+#endif+ V3 a b c >>= f = V3 a' b' c' where+ V3 a' _ _ = f a+ V3 _ b' _ = f b+ V3 _ _ c' = f c+ {-# INLINE (>>=) #-}++instance Num a => Num (V3 a) where+ (+) = liftA2 (+)+ {-# INLINE (+) #-}+ (-) = liftA2 (-)+ {-# INLINE (-) #-}+ (*) = liftA2 (*)+ {-# INLINE (*) #-}+ negate = fmap negate+ {-# INLINE negate #-}+ abs = fmap abs+ {-# INLINE abs #-}+ signum = fmap signum+ {-# INLINE signum #-}+ fromInteger = pure . fromInteger+ {-# INLINE fromInteger #-}++instance Fractional a => Fractional (V3 a) where+ recip = fmap recip+ {-# INLINE recip #-}+ (/) = liftA2 (/)+ {-# INLINE (/) #-}+ fromRational = pure . fromRational+ {-# INLINE fromRational #-}++instance Floating a => Floating (V3 a) where+ pi = pure pi+ {-# INLINE pi #-}+ exp = fmap exp+ {-# INLINE exp #-}+ sqrt = fmap sqrt+ {-# INLINE sqrt #-}+ log = fmap log+ {-# INLINE log #-}+ (**) = liftA2 (**)+ {-# INLINE (**) #-}+ logBase = liftA2 logBase+ {-# INLINE logBase #-}+ sin = fmap sin+ {-# INLINE sin #-}+ tan = fmap tan+ {-# INLINE tan #-}+ cos = fmap cos+ {-# INLINE cos #-}+ asin = fmap asin+ {-# INLINE asin #-}+ atan = fmap atan+ {-# INLINE atan #-}+ acos = fmap acos+ {-# INLINE acos #-}+ sinh = fmap sinh+ {-# INLINE sinh #-}+ tanh = fmap tanh+ {-# INLINE tanh #-}+ cosh = fmap cosh+ {-# INLINE cosh #-}+ asinh = fmap asinh+ {-# INLINE asinh #-}+ atanh = fmap atanh+ {-# INLINE atanh #-}+ acosh = fmap acosh+ {-# INLINE acosh #-}++instance Hashable a => Hashable (V3 a) where+ hashWithSalt s (V3 a b c) = s `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c+ {-# INLINE hashWithSalt #-}++instance Hashable1 V3 where+ liftHashWithSalt h s (V3 a b c) = s `h` a `h` b `h` c+ {-# INLINE liftHashWithSalt #-}++instance Metric V3 where+ dot (V3 a b c) (V3 d e f) = a * d + b * e + c * f+ {-# INLINABLE dot #-}++instance Distributive V3 where+ distribute f = V3 (fmap (\(V3 x _ _) -> x) f) (fmap (\(V3 _ y _) -> y) f) (fmap (\(V3 _ _ z) -> z) f)+ {-# INLINE distribute #-}++-- | A space that distinguishes 3 orthogonal basis vectors: '_x', '_y', and '_z'. (It may have more)+class R2 t => R3 t where+ -- |+ -- >>> V3 1 2 3 ^. _z+ -- 3+ _z :: Lens' (t a) a++ _xyz :: Lens' (t a) (V3 a)++_xz, _yz, _zx, _zy :: R3 t => Lens' (t a) (V2 a)++_xz f = _xyz $ \(V3 a b c) -> f (V2 a c) <&> \(V2 a' c') -> V3 a' b c'+{-# INLINE _xz #-}++_yz f = _xyz $ \(V3 a b c) -> f (V2 b c) <&> \(V2 b' c') -> V3 a b' c'+{-# INLINE _yz #-}++_zx f = _xyz $ \(V3 a b c) -> f (V2 c a) <&> \(V2 c' a') -> V3 a' b c'+{-# INLINE _zx #-}++_zy f = _xyz $ \(V3 a b c) -> f (V2 c b) <&> \(V2 c' b') -> V3 a b' c'+{-# INLINE _zy #-}++_xzy, _yxz, _yzx, _zxy, _zyx :: R3 t => Lens' (t a) (V3 a)++_xzy f = _xyz $ \(V3 a b c) -> f (V3 a c b) <&> \(V3 a' c' b') -> V3 a' b' c'+{-# INLINE _xzy #-}++_yxz f = _xyz $ \(V3 a b c) -> f (V3 b a c) <&> \(V3 b' a' c') -> V3 a' b' c'+{-# INLINE _yxz #-}++_yzx f = _xyz $ \(V3 a b c) -> f (V3 b c a) <&> \(V3 b' c' a') -> V3 a' b' c'+{-# INLINE _yzx #-}++_zxy f = _xyz $ \(V3 a b c) -> f (V3 c a b) <&> \(V3 c' a' b') -> V3 a' b' c'+{-# INLINE _zxy #-}++_zyx f = _xyz $ \(V3 a b c) -> f (V3 c b a) <&> \(V3 c' b' a') -> V3 a' b' c'+{-# INLINE _zyx #-}++ez :: R3 t => E t+ez = E _z++instance R1 V3 where+ _x f (V3 a b c) = (\a' -> V3 a' b c) <$> f a+ {-# INLINE _x #-}++instance R2 V3 where+ _y f (V3 a b c) = (\b' -> V3 a b' c) <$> f b+ {-# INLINE _y #-}+ _xy f (V3 a b c) = (\(V2 a' b') -> V3 a' b' c) <$> f (V2 a b)+ {-# INLINE _xy #-}++instance R3 V3 where+ _z f (V3 a b c) = V3 a b <$> f c+ {-# INLINE _z #-}+ _xyz = id+ {-# INLINE _xyz #-}++instance Storable a => Storable (V3 a) where+ sizeOf _ = 3 * sizeOf (undefined::a)+ {-# INLINE sizeOf #-}+ alignment _ = alignment (undefined::a)+ {-# INLINE alignment #-}+ poke ptr (V3 x y z) = do poke ptr' x+ pokeElemOff ptr' 1 y+ pokeElemOff ptr' 2 z+ where ptr' = castPtr ptr+ {-# INLINE poke #-}+ peek ptr = V3 <$> peek ptr' <*> peekElemOff ptr' 1 <*> peekElemOff ptr' 2+ where ptr' = castPtr ptr+ {-# INLINE peek #-}++-- | cross product+cross :: Num a => V3 a -> V3 a -> V3 a+cross (V3 a b c) (V3 d e f) = V3 (b*f-c*e) (c*d-a*f) (a*e-b*d)+{-# INLINABLE cross #-}++-- | scalar triple product+triple :: Num a => V3 a -> V3 a -> V3 a -> a+triple a b c = dot a (cross b c)+{-# INLINE triple #-}++instance Epsilon a => Epsilon (V3 a) where+ nearZero = nearZero . quadrance+ {-# INLINE nearZero #-}++instance Ix a => Ix (V3 a) where+ {-# SPECIALISE instance Ix (V3 Int) #-}++ range (V3 l1 l2 l3,V3 u1 u2 u3) =+ [V3 i1 i2 i3 | i1 <- range (l1,u1)+ , i2 <- range (l2,u2)+ , i3 <- range (l3,u3)+ ]+ {-# INLINE range #-}++ unsafeIndex (V3 l1 l2 l3,V3 u1 u2 u3) (V3 i1 i2 i3) =+ unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * (+ unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) *+ unsafeIndex (l1,u1) i1)+ {-# INLINE unsafeIndex #-}++ inRange (V3 l1 l2 l3,V3 u1 u2 u3) (V3 i1 i2 i3) =+ inRange (l1,u1) i1 && inRange (l2,u2) i2 &&+ inRange (l3,u3) i3+ {-# INLINE inRange #-}++instance Representable V3 where+ type Rep V3 = E V3+ tabulate f = V3 (f ex) (f ey) (f ez)+ {-# INLINE tabulate #-}+ index xs (E l) = view l xs+ {-# INLINE index #-}++instance WithIndex.FunctorWithIndex (E V3) V3 where+ imap f (V3 a b c) = V3 (f ex a) (f ey b) (f ez c)+ {-# INLINE imap #-}++instance WithIndex.FoldableWithIndex (E V3) V3 where+ ifoldMap f (V3 a b c) = f ex a `mappend` f ey b `mappend` f ez c+ {-# INLINE ifoldMap #-}++instance WithIndex.TraversableWithIndex (E V3) V3 where+ itraverse f (V3 a b c) = V3 <$> f ex a <*> f ey b <*> f ez c+ {-# INLINE itraverse #-}++#if !MIN_VERSION_lens(5,0,0)+instance Lens.FunctorWithIndex (E V3) V3 where imap = WithIndex.imap+instance Lens.FoldableWithIndex (E V3) V3 where ifoldMap = WithIndex.ifoldMap+instance Lens.TraversableWithIndex (E V3) V3 where itraverse = WithIndex.itraverse+#endif++type instance Index (V3 a) = E V3+type instance IxValue (V3 a) = a++instance Ixed (V3 a) where+ ix i = el i+ {-# INLINE ix #-}++instance Each (V3 a) (V3 b) a b where+ each = traverse+ {-# INLINE each #-}++data instance U.Vector (V3 a) = V_V3 {-# UNPACK #-} !Int !(U.Vector a)+data instance U.MVector s (V3 a) = MV_V3 {-# UNPACK #-} !Int !(U.MVector s a)+instance U.Unbox a => U.Unbox (V3 a)++instance U.Unbox a => M.MVector U.MVector (V3 a) where+ {-# INLINE basicLength #-}+ {-# INLINE basicUnsafeSlice #-}+ {-# INLINE basicOverlaps #-}+ {-# INLINE basicUnsafeNew #-}+ {-# INLINE basicUnsafeRead #-}+ {-# INLINE basicUnsafeWrite #-}+ basicLength (MV_V3 n _) = n+ basicUnsafeSlice m n (MV_V3 _ v) = MV_V3 n (M.basicUnsafeSlice (3*m) (3*n) v)+ basicOverlaps (MV_V3 _ v) (MV_V3 _ u) = M.basicOverlaps v u+ basicUnsafeNew n = liftM (MV_V3 n) (M.basicUnsafeNew (3*n))+ basicUnsafeRead (MV_V3 _ v) i =+ do let o = 3*i+ x <- M.basicUnsafeRead v o+ y <- M.basicUnsafeRead v (o+1)+ z <- M.basicUnsafeRead v (o+2)+ return (V3 x y z)+ basicUnsafeWrite (MV_V3 _ v) i (V3 x y z) =+ do let o = 3*i+ M.basicUnsafeWrite v o x+ M.basicUnsafeWrite v (o+1) y+ M.basicUnsafeWrite v (o+2) z+ basicInitialize (MV_V3 _ v) = M.basicInitialize v+ {-# INLINE basicInitialize #-}++instance U.Unbox a => G.Vector U.Vector (V3 a) where+ {-# INLINE basicUnsafeFreeze #-}+ {-# INLINE basicUnsafeThaw #-}+ {-# INLINE basicLength #-}+ {-# INLINE basicUnsafeSlice #-}+ {-# INLINE basicUnsafeIndexM #-}+ basicUnsafeFreeze (MV_V3 n v) = liftM ( V_V3 n) (G.basicUnsafeFreeze v)+ basicUnsafeThaw ( V_V3 n v) = liftM (MV_V3 n) (G.basicUnsafeThaw v)+ basicLength ( V_V3 n _) = n+ basicUnsafeSlice m n (V_V3 _ v) = V_V3 n (G.basicUnsafeSlice (3*m) (3*n) v)+ basicUnsafeIndexM (V_V3 _ v) i =+ do let o = 3*i+ x <- G.basicUnsafeIndexM v o+ y <- G.basicUnsafeIndexM v (o+1)+ z <- G.basicUnsafeIndexM v (o+2)+ return (V3 x y z)++instance MonadZip V3 where+ mzipWith = liftA2++instance MonadFix V3 where+ mfix f = V3 (let V3 a _ _ = f a in a)+ (let V3 _ a _ = f a in a)+ (let V3 _ _ a = f a in a)++instance Bounded a => Bounded (V3 a) where+ minBound = pure minBound+ {-# INLINE minBound #-}+ maxBound = pure maxBound+ {-# INLINE maxBound #-}++instance NFData a => NFData (V3 a) where+ rnf (V3 a b c) = rnf a `seq` rnf b `seq` rnf c++instance Serial1 V3 where+ serializeWith = traverse_+ deserializeWith k = V3 <$> k <*> k <*> k++instance Serial a => Serial (V3 a) where+ serialize = serializeWith serialize+ deserialize = deserializeWith deserialize++instance Binary a => Binary (V3 a) where+ put = serializeWith Binary.put+ get = deserializeWith Binary.get++instance Serialize a => Serialize (V3 a) where+ put = serializeWith Cereal.put+ get = deserializeWith Cereal.get++instance Eq1 V3 where+ liftEq k (V3 a b c) (V3 d e f) = k a d && k b e && k c f+instance Ord1 V3 where+ liftCompare k (V3 a b c) (V3 d e f) = k a d `mappend` k b e `mappend` k c f+instance Read1 V3 where+ liftReadsPrec k _ d = readParen (d > 10) $ \r ->+ [ (V3 a b c, r4)+ | ("V3",r1) <- lex r+ , (a,r2) <- k 11 r1+ , (b,r3) <- k 11 r2+ , (c,r4) <- k 11 r3+ ]+instance Show1 V3 where+ liftShowsPrec f _ d (V3 a b c) = showParen (d > 10) $+ showString "V3 " . f 11 a . showChar ' ' . f 11 b . showChar ' ' . f 11 c++instance Field1 (V3 a) (V3 a) a a where+ _1 f (V3 x y z) = f x <&> \x' -> V3 x' y z++instance Field2 (V3 a) (V3 a) a a where+ _2 f (V3 x y z) = f y <&> \y' -> V3 x y' z++instance Field3 (V3 a) (V3 a) a a where+ _3 f (V3 x y z) = f z <&> \z' -> V3 x y z'++instance Semigroup a => Semigroup (V3 a) where+ (<>) = liftA2 (<>)++instance Monoid a => Monoid (V3 a) where+ mempty = pure mempty+#if !(MIN_VERSION_base(4,11,0))+ mappend = liftA2 mappend+#endif+
src/Linear/V4.hs view
@@ -1,657 +1,659 @@-{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveLift #-} - -#ifndef MIN_VERSION_hashable -#define MIN_VERSION_hashable(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_vector -#define MIN_VERSION_vector(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_transformers -#define MIN_VERSION_transformers(x,y,z) 1 -#endif ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2012-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : experimental --- Portability : non-portable --- --- 4-D Vectors ----------------------------------------------------------------------------- -module Linear.V4 - ( V4(..) - , vector, point, normalizePoint - , R1(..) - , R2(..) - , _yx - , R3(..) - , _xz, _yz, _zx, _zy - , _xzy, _yxz, _yzx, _zxy, _zyx - , R4(..) - , _xw, _yw, _zw, _wx, _wy, _wz - , _xyw, _xzw, _xwy, _xwz, _yxw, _yzw, _ywx, _ywz, _zxw, _zyw, _zwx, _zwy - , _wxy, _wxz, _wyx, _wyz, _wzx, _wzy - , _xywz, _xzyw, _xzwy, _xwyz, _xwzy, _yxzw , _yxwz, _yzxw, _yzwx, _ywxz - , _ywzx, _zxyw, _zxwy, _zyxw, _zywx, _zwxy, _zwyx, _wxyz, _wxzy, _wyxz - , _wyzx, _wzxy, _wzyx - , ex, ey, ez, ew - ) where - -import Control.Applicative -import Control.DeepSeq (NFData(rnf)) -import Control.Monad (liftM) -import Control.Monad.Fix -import Control.Monad.Zip -import Control.Lens as Lens hiding ((<.>)) -import Data.Binary as Binary -import Data.Bytes.Serial -import Data.Data -import Data.Distributive -import Data.Foldable -import qualified Data.Foldable.WithIndex as WithIndex -import Data.Functor.Bind -import Data.Functor.Classes -import Data.Functor.Rep -import qualified Data.Functor.WithIndex as WithIndex -import Data.Hashable -import Data.Hashable.Lifted -#if !(MIN_VERSION_base(4,11,0)) -import Data.Semigroup -#endif -import Data.Semigroup.Foldable -import Data.Serialize as Cereal -import qualified Data.Traversable.WithIndex as WithIndex -import qualified Data.Vector as V -import qualified Data.Vector.Generic.Mutable as M -import qualified Data.Vector.Generic as G -import qualified Data.Vector.Unboxed.Base as U -import Foreign.Ptr (castPtr) -import Foreign.Storable (Storable(..)) -import GHC.Arr (Ix(..)) -import GHC.Generics (Generic, Generic1) -#if defined(MIN_VERSION_template_haskell) -import Language.Haskell.TH.Syntax (Lift) -#endif -import Linear.Epsilon -import Linear.Metric -import Linear.V -import Linear.V2 -import Linear.V3 -import Linear.Vector -import System.Random (Random(..)) - --- $setup --- >>> import Control.Lens hiding (index) - --- | A 4-dimensional vector. -data V4 a = V4 !a !a !a !a deriving (Eq,Ord,Show,Read,Data - ,Generic,Generic1 -#if defined(MIN_VERSION_template_haskell) - ,Lift -#endif - ) - -instance Finite V4 where - type Size V4 = 4 - toV (V4 a b c d) = V (V.fromListN 4 [a,b,c,d]) - fromV (V v) = V4 (v V.! 0) (v V.! 1) (v V.! 2) (v V.! 3) - -instance Functor V4 where - fmap f (V4 a b c d) = V4 (f a) (f b) (f c) (f d) - {-# INLINE fmap #-} - a <$ _ = V4 a a a a - {-# INLINE (<$) #-} - -instance Foldable V4 where - foldMap f (V4 a b c d) = f a `mappend` f b `mappend` f c `mappend` f d - {-# INLINE foldMap #-} -#if MIN_VERSION_base(4,13,0) - foldMap' f (V4 a b c d) = ((f a `mappend` f b) `mappend` f c) `mappend` f d - {-# INLINE foldMap' #-} -#endif - null _ = False - length _ = 4 - -instance Random a => Random (V4 a) where - random g = case random g of - (a, g') -> case random g' of - (b, g'') -> case random g'' of - (c, g''') -> case random g''' of - (d, g'''') -> (V4 a b c d, g'''') - randomR (V4 a b c d, V4 a' b' c' d') g = case randomR (a,a') g of - (a'', g') -> case randomR (b,b') g' of - (b'', g'') -> case randomR (c,c') g'' of - (c'', g''') -> case randomR (d,d') g''' of - (d'', g'''') -> (V4 a'' b'' c'' d'', g'''') - -instance Traversable V4 where - traverse f (V4 a b c d) = V4 <$> f a <*> f b <*> f c <*> f d - {-# INLINE traverse #-} - -instance Foldable1 V4 where - foldMap1 f (V4 a b c d) = f a <> f b <> f c <> f d - {-# INLINE foldMap1 #-} - -instance Traversable1 V4 where - traverse1 f (V4 a b c d) = V4 <$> f a <.> f b <.> f c <.> f d - {-# INLINE traverse1 #-} - -instance Applicative V4 where - pure a = V4 a a a a - {-# INLINE pure #-} - V4 a b c d <*> V4 e f g h = V4 (a e) (b f) (c g) (d h) - {-# INLINE (<*>) #-} - -instance Apply V4 where - V4 a b c d <.> V4 e f g h = V4 (a e) (b f) (c g) (d h) - {-# INLINE (<.>) #-} - -instance Additive V4 where - zero = pure 0 - {-# INLINE zero #-} - liftU2 = liftA2 - {-# INLINE liftU2 #-} - liftI2 = liftA2 - {-# INLINE liftI2 #-} - -instance Bind V4 where - V4 a b c d >>- f = V4 a' b' c' d' where - V4 a' _ _ _ = f a - V4 _ b' _ _ = f b - V4 _ _ c' _ = f c - V4 _ _ _ d' = f d - {-# INLINE (>>-) #-} - -instance Monad V4 where -#if !(MIN_VERSION_base(4,11,0)) - return a = V4 a a a a - {-# INLINE return #-} -#endif - V4 a b c d >>= f = V4 a' b' c' d' where - V4 a' _ _ _ = f a - V4 _ b' _ _ = f b - V4 _ _ c' _ = f c - V4 _ _ _ d' = f d - {-# INLINE (>>=) #-} - -instance Num a => Num (V4 a) where - (+) = liftA2 (+) - {-# INLINE (+) #-} - (*) = liftA2 (*) - {-# INLINE (-) #-} - (-) = liftA2 (-) - {-# INLINE (*) #-} - negate = fmap negate - {-# INLINE negate #-} - abs = fmap abs - {-# INLINE abs #-} - signum = fmap signum - {-# INLINE signum #-} - fromInteger = pure . fromInteger - {-# INLINE fromInteger #-} - -instance Fractional a => Fractional (V4 a) where - recip = fmap recip - {-# INLINE recip #-} - (/) = liftA2 (/) - {-# INLINE (/) #-} - fromRational = pure . fromRational - {-# INLINE fromRational #-} - -instance Floating a => Floating (V4 a) where - pi = pure pi - {-# INLINE pi #-} - exp = fmap exp - {-# INLINE exp #-} - sqrt = fmap sqrt - {-# INLINE sqrt #-} - log = fmap log - {-# INLINE log #-} - (**) = liftA2 (**) - {-# INLINE (**) #-} - logBase = liftA2 logBase - {-# INLINE logBase #-} - sin = fmap sin - {-# INLINE sin #-} - tan = fmap tan - {-# INLINE tan #-} - cos = fmap cos - {-# INLINE cos #-} - asin = fmap asin - {-# INLINE asin #-} - atan = fmap atan - {-# INLINE atan #-} - acos = fmap acos - {-# INLINE acos #-} - sinh = fmap sinh - {-# INLINE sinh #-} - tanh = fmap tanh - {-# INLINE tanh #-} - cosh = fmap cosh - {-# INLINE cosh #-} - asinh = fmap asinh - {-# INLINE asinh #-} - atanh = fmap atanh - {-# INLINE atanh #-} - acosh = fmap acosh - {-# INLINE acosh #-} - -instance Metric V4 where - dot (V4 a b c d) (V4 e f g h) = a * e + b * f + c * g + d * h - {-# INLINE dot #-} - -instance Distributive V4 where - distribute f = V4 (fmap (\(V4 x _ _ _) -> x) f) - (fmap (\(V4 _ y _ _) -> y) f) - (fmap (\(V4 _ _ z _) -> z) f) - (fmap (\(V4 _ _ _ w) -> w) f) - {-# INLINE distribute #-} - -instance Hashable a => Hashable (V4 a) where - hashWithSalt s (V4 a b c d) = s `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c `hashWithSalt` d - {-# INLINE hashWithSalt #-} - -instance Hashable1 V4 where - liftHashWithSalt h s (V4 a b c d) = s `h` a `h` b `h` c `h` d - {-# INLINE liftHashWithSalt #-} - --- | A space that distinguishes orthogonal basis vectors '_x', '_y', '_z', '_w'. (It may have more.) -class R3 t => R4 t where - -- | - -- >>> V4 1 2 3 4 ^._w - -- 4 - _w :: Lens' (t a) a - _xyzw :: Lens' (t a) (V4 a) - -_xw, _yw, _zw, _wx, _wy, _wz :: R4 t => Lens' (t a) (V2 a) -_xw f = _xyzw $ \(V4 a b c d) -> f (V2 a d) <&> \(V2 a' d') -> V4 a' b c d' -{-# INLINE _xw #-} - -_yw f = _xyzw $ \(V4 a b c d) -> f (V2 b d) <&> \(V2 b' d') -> V4 a b' c d' -{-# INLINE _yw #-} - -_zw f = _xyzw $ \(V4 a b c d) -> f (V2 c d) <&> \(V2 c' d') -> V4 a b c' d' -{-# INLINE _zw #-} - -_wx f = _xyzw $ \(V4 a b c d) -> f (V2 d a) <&> \(V2 d' a') -> V4 a' b c d' -{-# INLINE _wx #-} - -_wy f = _xyzw $ \(V4 a b c d) -> f (V2 d b) <&> \(V2 d' b') -> V4 a b' c d' -{-# INLINE _wy #-} - -_wz f = _xyzw $ \(V4 a b c d) -> f (V2 d c) <&> \(V2 d' c') -> V4 a b c' d' -{-# INLINE _wz #-} - -_xyw, _xzw, _xwy, _xwz, _yxw, _yzw, _ywx, _ywz, _zxw, _zyw, _zwx, _zwy, _wxy, _wxz, _wyx, _wyz, _wzx, _wzy :: R4 t => Lens' (t a) (V3 a) -_xyw f = _xyzw $ \(V4 a b c d) -> f (V3 a b d) <&> \(V3 a' b' d') -> V4 a' b' c d' -{-# INLINE _xyw #-} - -_xzw f = _xyzw $ \(V4 a b c d) -> f (V3 a c d) <&> \(V3 a' c' d') -> V4 a' b c' d' -{-# INLINE _xzw #-} - -_xwy f = _xyzw $ \(V4 a b c d) -> f (V3 a d b) <&> \(V3 a' d' b') -> V4 a' b' c d' -{-# INLINE _xwy #-} - -_xwz f = _xyzw $ \(V4 a b c d) -> f (V3 a d c) <&> \(V3 a' d' c') -> V4 a' b c' d' -{-# INLINE _xwz #-} - -_yxw f = _xyzw $ \(V4 a b c d) -> f (V3 b a d) <&> \(V3 b' a' d') -> V4 a' b' c d' -{-# INLINE _yxw #-} - -_yzw f = _xyzw $ \(V4 a b c d) -> f (V3 b c d) <&> \(V3 b' c' d') -> V4 a b' c' d' -{-# INLINE _yzw #-} - -_ywx f = _xyzw $ \(V4 a b c d) -> f (V3 b d a) <&> \(V3 b' d' a') -> V4 a' b' c d' -{-# INLINE _ywx #-} - -_ywz f = _xyzw $ \(V4 a b c d) -> f (V3 b d c) <&> \(V3 b' d' c') -> V4 a b' c' d' -{-# INLINE _ywz #-} - -_zxw f = _xyzw $ \(V4 a b c d) -> f (V3 c a d) <&> \(V3 c' a' d') -> V4 a' b c' d' -{-# INLINE _zxw #-} - -_zyw f = _xyzw $ \(V4 a b c d) -> f (V3 c b d) <&> \(V3 c' b' d') -> V4 a b' c' d' -{-# INLINE _zyw #-} - -_zwx f = _xyzw $ \(V4 a b c d) -> f (V3 c d a) <&> \(V3 c' d' a') -> V4 a' b c' d' -{-# INLINE _zwx #-} - -_zwy f = _xyzw $ \(V4 a b c d) -> f (V3 c d b) <&> \(V3 c' d' b') -> V4 a b' c' d' -{-# INLINE _zwy #-} - -_wxy f = _xyzw $ \(V4 a b c d) -> f (V3 d a b) <&> \(V3 d' a' b') -> V4 a' b' c d' -{-# INLINE _wxy #-} - -_wxz f = _xyzw $ \(V4 a b c d) -> f (V3 d a c) <&> \(V3 d' a' c') -> V4 a' b c' d' -{-# INLINE _wxz #-} - -_wyx f = _xyzw $ \(V4 a b c d) -> f (V3 d b a) <&> \(V3 d' b' a') -> V4 a' b' c d' -{-# INLINE _wyx #-} - -_wyz f = _xyzw $ \(V4 a b c d) -> f (V3 d b c) <&> \(V3 d' b' c') -> V4 a b' c' d' -{-# INLINE _wyz #-} - -_wzx f = _xyzw $ \(V4 a b c d) -> f (V3 d c a) <&> \(V3 d' c' a') -> V4 a' b c' d' -{-# INLINE _wzx #-} - -_wzy f = _xyzw $ \(V4 a b c d) -> f (V3 d c b) <&> \(V3 d' c' b') -> V4 a b' c' d' -{-# INLINE _wzy #-} - -_xywz, _xzyw, _xzwy, _xwyz, _xwzy, _yxzw , _yxwz, _yzxw, _yzwx, _ywxz - , _ywzx, _zxyw, _zxwy, _zyxw, _zywx, _zwxy, _zwyx, _wxyz, _wxzy, _wyxz - , _wyzx, _wzxy, _wzyx :: R4 t => Lens' (t a) (V4 a) -_xywz f = _xyzw $ \(V4 a b c d) -> f (V4 a b d c) <&> \(V4 a' b' d' c') -> V4 a' b' c' d' -{-# INLINE _xywz #-} - -_xzyw f = _xyzw $ \(V4 a b c d) -> f (V4 a c b d) <&> \(V4 a' c' b' d') -> V4 a' b' c' d' -{-# INLINE _xzyw #-} - -_xzwy f = _xyzw $ \(V4 a b c d) -> f (V4 a c d b) <&> \(V4 a' c' d' b') -> V4 a' b' c' d' -{-# INLINE _xzwy #-} - -_xwyz f = _xyzw $ \(V4 a b c d) -> f (V4 a d b c) <&> \(V4 a' d' b' c') -> V4 a' b' c' d' -{-# INLINE _xwyz #-} - -_xwzy f = _xyzw $ \(V4 a b c d) -> f (V4 a d c b) <&> \(V4 a' d' c' b') -> V4 a' b' c' d' -{-# INLINE _xwzy #-} - -_yxzw f = _xyzw $ \(V4 a b c d) -> f (V4 b a c d) <&> \(V4 b' a' c' d') -> V4 a' b' c' d' -{-# INLINE _yxzw #-} - -_yxwz f = _xyzw $ \(V4 a b c d) -> f (V4 b a d c) <&> \(V4 b' a' d' c') -> V4 a' b' c' d' -{-# INLINE _yxwz #-} - -_yzxw f = _xyzw $ \(V4 a b c d) -> f (V4 b c a d) <&> \(V4 b' c' a' d') -> V4 a' b' c' d' -{-# INLINE _yzxw #-} - -_yzwx f = _xyzw $ \(V4 a b c d) -> f (V4 b c d a) <&> \(V4 b' c' d' a') -> V4 a' b' c' d' -{-# INLINE _yzwx #-} - -_ywxz f = _xyzw $ \(V4 a b c d) -> f (V4 b d a c) <&> \(V4 b' d' a' c') -> V4 a' b' c' d' -{-# INLINE _ywxz #-} - -_ywzx f = _xyzw $ \(V4 a b c d) -> f (V4 b d c a) <&> \(V4 b' d' c' a') -> V4 a' b' c' d' -{-# INLINE _ywzx #-} - -_zxyw f = _xyzw $ \(V4 a b c d) -> f (V4 c a b d) <&> \(V4 c' a' b' d') -> V4 a' b' c' d' -{-# INLINE _zxyw #-} - -_zxwy f = _xyzw $ \(V4 a b c d) -> f (V4 c a d b) <&> \(V4 c' a' d' b') -> V4 a' b' c' d' -{-# INLINE _zxwy #-} - -_zyxw f = _xyzw $ \(V4 a b c d) -> f (V4 c b a d) <&> \(V4 c' b' a' d') -> V4 a' b' c' d' -{-# INLINE _zyxw #-} - -_zywx f = _xyzw $ \(V4 a b c d) -> f (V4 c b d a) <&> \(V4 c' b' d' a') -> V4 a' b' c' d' -{-# INLINE _zywx #-} - -_zwxy f = _xyzw $ \(V4 a b c d) -> f (V4 c d a b) <&> \(V4 c' d' a' b') -> V4 a' b' c' d' -{-# INLINE _zwxy #-} - -_zwyx f = _xyzw $ \(V4 a b c d) -> f (V4 c d b a) <&> \(V4 c' d' b' a') -> V4 a' b' c' d' -{-# INLINE _zwyx #-} - -_wxyz f = _xyzw $ \(V4 a b c d) -> f (V4 d a b c) <&> \(V4 d' a' b' c') -> V4 a' b' c' d' -{-# INLINE _wxyz #-} - -_wxzy f = _xyzw $ \(V4 a b c d) -> f (V4 d a c b) <&> \(V4 d' a' c' b') -> V4 a' b' c' d' -{-# INLINE _wxzy #-} - -_wyxz f = _xyzw $ \(V4 a b c d) -> f (V4 d b a c) <&> \(V4 d' b' a' c') -> V4 a' b' c' d' -{-# INLINE _wyxz #-} - -_wyzx f = _xyzw $ \(V4 a b c d) -> f (V4 d b c a) <&> \(V4 d' b' c' a') -> V4 a' b' c' d' -{-# INLINE _wyzx #-} - -_wzxy f = _xyzw $ \(V4 a b c d) -> f (V4 d c a b) <&> \(V4 d' c' a' b') -> V4 a' b' c' d' -{-# INLINE _wzxy #-} - -_wzyx f = _xyzw $ \(V4 a b c d) -> f (V4 d c b a) <&> \(V4 d' c' b' a') -> V4 a' b' c' d' -{-# INLINE _wzyx #-} - -ew :: R4 t => E t -ew = E _w - -instance R1 V4 where - _x f (V4 a b c d) = (\a' -> V4 a' b c d) <$> f a - {-# INLINE _x #-} - -instance R2 V4 where - _y f (V4 a b c d) = (\b' -> V4 a b' c d) <$> f b - {-# INLINE _y #-} - _xy f (V4 a b c d) = (\(V2 a' b') -> V4 a' b' c d) <$> f (V2 a b) - {-# INLINE _xy #-} - -instance R3 V4 where - _z f (V4 a b c d) = (\c' -> V4 a b c' d) <$> f c - {-# INLINE _z #-} - _xyz f (V4 a b c d) = (\(V3 a' b' c') -> V4 a' b' c' d) <$> f (V3 a b c) - {-# INLINE _xyz #-} - -instance R4 V4 where - _w f (V4 a b c d) = V4 a b c <$> f d - {-# INLINE _w #-} - _xyzw = id - {-# INLINE _xyzw #-} - -instance Storable a => Storable (V4 a) where - sizeOf _ = 4 * sizeOf (undefined::a) - {-# INLINE sizeOf #-} - alignment _ = alignment (undefined::a) - {-# INLINE alignment #-} - poke ptr (V4 x y z w) = do poke ptr' x - pokeElemOff ptr' 1 y - pokeElemOff ptr' 2 z - pokeElemOff ptr' 3 w - where ptr' = castPtr ptr - {-# INLINE poke #-} - peek ptr = V4 <$> peek ptr' <*> peekElemOff ptr' 1 - <*> peekElemOff ptr' 2 <*> peekElemOff ptr' 3 - where ptr' = castPtr ptr - {-# INLINE peek #-} - --- | Convert a 3-dimensional affine vector into a 4-dimensional homogeneous vector, --- i.e. sets the @w@ coordinate to 0. -vector :: Num a => V3 a -> V4 a -vector (V3 a b c) = V4 a b c 0 -{-# INLINE vector #-} - --- | Convert a 3-dimensional affine point into a 4-dimensional homogeneous vector, --- i.e. sets the @w@ coordinate to 1. -point :: Num a => V3 a -> V4 a -point (V3 a b c) = V4 a b c 1 -{-# INLINE point #-} - --- | Convert 4-dimensional projective coordinates to a 3-dimensional --- point. This operation may be denoted, @euclidean [x:y:z:w] = (x\/w, --- y\/w, z\/w)@ where the projective, homogenous, coordinate --- @[x:y:z:w]@ is one of many associated with a single point @(x\/w, --- y\/w, z\/w)@. -normalizePoint :: Fractional a => V4 a -> V3 a -normalizePoint (V4 a b c w) = (1/w) *^ V3 a b c -{-# INLINE normalizePoint #-} - -instance Epsilon a => Epsilon (V4 a) where - nearZero = nearZero . quadrance - {-# INLINE nearZero #-} - -instance Ix a => Ix (V4 a) where - {-# SPECIALISE instance Ix (V4 Int) #-} - - range (V4 l1 l2 l3 l4,V4 u1 u2 u3 u4) = - [V4 i1 i2 i3 i4 | i1 <- range (l1,u1) - , i2 <- range (l2,u2) - , i3 <- range (l3,u3) - , i4 <- range (l4,u4) - ] - {-# INLINE range #-} - - unsafeIndex (V4 l1 l2 l3 l4,V4 u1 u2 u3 u4) (V4 i1 i2 i3 i4) = - unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * ( - unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * ( - unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * - unsafeIndex (l1,u1) i1)) - {-# INLINE unsafeIndex #-} - - inRange (V4 l1 l2 l3 l4,V4 u1 u2 u3 u4) (V4 i1 i2 i3 i4) = - inRange (l1,u1) i1 && inRange (l2,u2) i2 && - inRange (l3,u3) i3 && inRange (l4,u4) i4 - {-# INLINE inRange #-} - -instance Representable V4 where - type Rep V4 = E V4 - tabulate f = V4 (f ex) (f ey) (f ez) (f ew) - {-# INLINE tabulate #-} - index xs (E l) = view l xs - {-# INLINE index #-} - -instance WithIndex.FunctorWithIndex (E V4) V4 where - imap f (V4 a b c d) = V4 (f ex a) (f ey b) (f ez c) (f ew d) - {-# INLINE imap #-} - -instance WithIndex.FoldableWithIndex (E V4) V4 where - ifoldMap f (V4 a b c d) = f ex a `mappend` f ey b `mappend` f ez c `mappend` f ew d - {-# INLINE ifoldMap #-} - -instance WithIndex.TraversableWithIndex (E V4) V4 where - itraverse f (V4 a b c d) = V4 <$> f ex a <*> f ey b <*> f ez c <*> f ew d - {-# INLINE itraverse #-} - -#if !MIN_VERSION_lens(5,0,0) -instance Lens.FunctorWithIndex (E V4) V4 where imap = WithIndex.imap -instance Lens.FoldableWithIndex (E V4) V4 where ifoldMap = WithIndex.ifoldMap -instance Lens.TraversableWithIndex (E V4) V4 where itraverse = WithIndex.itraverse -#endif - -type instance Index (V4 a) = E V4 -type instance IxValue (V4 a) = a - -instance Ixed (V4 a) where - ix i = el i - -instance Each (V4 a) (V4 b) a b where - each = traverse - -data instance U.Vector (V4 a) = V_V4 {-# UNPACK #-} !Int !(U.Vector a) -data instance U.MVector s (V4 a) = MV_V4 {-# UNPACK #-} !Int !(U.MVector s a) -instance U.Unbox a => U.Unbox (V4 a) - -instance U.Unbox a => M.MVector U.MVector (V4 a) where - basicLength (MV_V4 n _) = n - basicUnsafeSlice m n (MV_V4 _ v) = MV_V4 n (M.basicUnsafeSlice (4*m) (4*n) v) - basicOverlaps (MV_V4 _ v) (MV_V4 _ u) = M.basicOverlaps v u - basicUnsafeNew n = liftM (MV_V4 n) (M.basicUnsafeNew (4*n)) - basicUnsafeRead (MV_V4 _ v) i = - do let o = 4*i - x <- M.basicUnsafeRead v o - y <- M.basicUnsafeRead v (o+1) - z <- M.basicUnsafeRead v (o+2) - w <- M.basicUnsafeRead v (o+3) - return (V4 x y z w) - basicUnsafeWrite (MV_V4 _ v) i (V4 x y z w) = - do let o = 4*i - M.basicUnsafeWrite v o x - M.basicUnsafeWrite v (o+1) y - M.basicUnsafeWrite v (o+2) z - M.basicUnsafeWrite v (o+3) w - basicInitialize (MV_V4 _ v) = M.basicInitialize v - -instance U.Unbox a => G.Vector U.Vector (V4 a) where - basicUnsafeFreeze (MV_V4 n v) = liftM ( V_V4 n) (G.basicUnsafeFreeze v) - basicUnsafeThaw ( V_V4 n v) = liftM (MV_V4 n) (G.basicUnsafeThaw v) - basicLength ( V_V4 n _) = n - basicUnsafeSlice m n (V_V4 _ v) = V_V4 n (G.basicUnsafeSlice (4*m) (4*n) v) - basicUnsafeIndexM (V_V4 _ v) i = - do let o = 4*i - x <- G.basicUnsafeIndexM v o - y <- G.basicUnsafeIndexM v (o+1) - z <- G.basicUnsafeIndexM v (o+2) - w <- G.basicUnsafeIndexM v (o+3) - return (V4 x y z w) - -instance MonadZip V4 where - mzipWith = liftA2 - -instance MonadFix V4 where - mfix f = V4 (let V4 a _ _ _ = f a in a) - (let V4 _ a _ _ = f a in a) - (let V4 _ _ a _ = f a in a) - (let V4 _ _ _ a = f a in a) - -instance Bounded a => Bounded (V4 a) where - minBound = pure minBound - {-# INLINE minBound #-} - maxBound = pure maxBound - {-# INLINE maxBound #-} - -instance NFData a => NFData (V4 a) where - rnf (V4 a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d - -instance Serial1 V4 where - serializeWith = traverse_ - deserializeWith k = V4 <$> k <*> k <*> k <*> k - -instance Serial a => Serial (V4 a) where - serialize = serializeWith serialize - deserialize = deserializeWith deserialize - -instance Binary a => Binary (V4 a) where - put = serializeWith Binary.put - get = deserializeWith Binary.get - -instance Serialize a => Serialize (V4 a) where - put = serializeWith Cereal.put - get = deserializeWith Cereal.get - -instance Eq1 V4 where - liftEq k (V4 a b c d) (V4 e f g h) = k a e && k b f && k c g && k d h -instance Ord1 V4 where - liftCompare k (V4 a b c d) (V4 e f g h) = k a e `mappend` k b f `mappend` k c g `mappend` k d h -instance Read1 V4 where - liftReadsPrec k _ z = readParen (z > 10) $ \r -> - [ (V4 a b c d, r5) - | ("V4",r1) <- lex r - , (a,r2) <- k 11 r1 - , (b,r3) <- k 11 r2 - , (c,r4) <- k 11 r3 - , (d,r5) <- k 11 r4 - ] -instance Show1 V4 where - liftShowsPrec f _ z (V4 a b c d) = showParen (z > 10) $ - showString "V4 " . f 11 a . showChar ' ' . f 11 b . showChar ' ' . f 11 c . showChar ' ' . f 11 d - -instance Field1 (V4 a) (V4 a) a a where - _1 f (V4 x y z w) = f x <&> \x' -> V4 x' y z w - -instance Field2 (V4 a) (V4 a) a a where - _2 f (V4 x y z w) = f y <&> \y' -> V4 x y' z w - -instance Field3 (V4 a) (V4 a) a a where - _3 f (V4 x y z w) = f z <&> \z' -> V4 x y z' w - -instance Field4 (V4 a) (V4 a) a a where - _4 f (V4 x y z w) = f w <&> \w' -> V4 x y z w' - -instance Semigroup a => Semigroup (V4 a) where - (<>) = liftA2 (<>) - -instance Monoid a => Monoid (V4 a) where - mempty = pure mempty -#if !(MIN_VERSION_base(4,11,0)) - mappend = liftA2 mappend -#endif - +{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveLift #-}++#ifndef MIN_VERSION_hashable+#define MIN_VERSION_hashable(x,y,z) 1+#endif++#ifndef MIN_VERSION_vector+#define MIN_VERSION_vector(x,y,z) 1+#endif++#ifndef MIN_VERSION_transformers+#define MIN_VERSION_transformers(x,y,z) 1+#endif+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2012-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- 4-D Vectors+----------------------------------------------------------------------------+module Linear.V4+ ( V4(..)+ , vector, point, normalizePoint+ , R1(..)+ , R2(..)+ , _yx+ , R3(..)+ , _xz, _yz, _zx, _zy+ , _xzy, _yxz, _yzx, _zxy, _zyx+ , R4(..)+ , _xw, _yw, _zw, _wx, _wy, _wz+ , _xyw, _xzw, _xwy, _xwz, _yxw, _yzw, _ywx, _ywz, _zxw, _zyw, _zwx, _zwy+ , _wxy, _wxz, _wyx, _wyz, _wzx, _wzy+ , _xywz, _xzyw, _xzwy, _xwyz, _xwzy, _yxzw , _yxwz, _yzxw, _yzwx, _ywxz+ , _ywzx, _zxyw, _zxwy, _zyxw, _zywx, _zwxy, _zwyx, _wxyz, _wxzy, _wyxz+ , _wyzx, _wzxy, _wzyx+ , ex, ey, ez, ew+ ) where++#if !MIN_VERSION_base(4,18,0)+import Control.Applicative+#endif+import Control.DeepSeq (NFData(rnf))+import Control.Monad (liftM)+import Control.Monad.Fix+import Control.Monad.Zip+import Control.Lens as Lens hiding ((<.>))+import Data.Binary as Binary+import Data.Bytes.Serial+import Data.Data+import Data.Distributive+import Data.Foldable+import qualified Data.Foldable.WithIndex as WithIndex+import Data.Functor.Bind+import Data.Functor.Classes+import Data.Functor.Rep+import qualified Data.Functor.WithIndex as WithIndex+import Data.Hashable+import Data.Hashable.Lifted+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup+#endif+import Data.Semigroup.Foldable+import Data.Serialize as Cereal+import qualified Data.Traversable.WithIndex as WithIndex+import qualified Data.Vector as V+import qualified Data.Vector.Generic.Mutable as M+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Unboxed.Base as U+import Foreign.Ptr (castPtr)+import Foreign.Storable (Storable(..))+import GHC.Arr (Ix(..))+import GHC.Generics (Generic, Generic1)+#if defined(MIN_VERSION_template_haskell)+import Language.Haskell.TH.Syntax (Lift)+#endif+import Linear.Epsilon+import Linear.Metric+import Linear.V+import Linear.V2+import Linear.V3+import Linear.Vector+import System.Random (Random(..))++-- $setup+-- >>> import Control.Lens hiding (index)++-- | A 4-dimensional vector.+data V4 a = V4 !a !a !a !a deriving (Eq,Ord,Show,Read,Data+ ,Generic,Generic1+#if defined(MIN_VERSION_template_haskell)+ ,Lift+#endif+ )++instance Finite V4 where+ type Size V4 = 4+ toV (V4 a b c d) = V (V.fromListN 4 [a,b,c,d])+ fromV (V v) = V4 (v V.! 0) (v V.! 1) (v V.! 2) (v V.! 3)++instance Functor V4 where+ fmap f (V4 a b c d) = V4 (f a) (f b) (f c) (f d)+ {-# INLINE fmap #-}+ a <$ _ = V4 a a a a+ {-# INLINE (<$) #-}++instance Foldable V4 where+ foldMap f (V4 a b c d) = f a `mappend` f b `mappend` f c `mappend` f d+ {-# INLINE foldMap #-}+#if MIN_VERSION_base(4,13,0)+ foldMap' f (V4 a b c d) = ((f a `mappend` f b) `mappend` f c) `mappend` f d+ {-# INLINE foldMap' #-}+#endif+ null _ = False+ length _ = 4++instance Random a => Random (V4 a) where+ random g = case random g of+ (a, g') -> case random g' of+ (b, g'') -> case random g'' of+ (c, g''') -> case random g''' of+ (d, g'''') -> (V4 a b c d, g'''')+ randomR (V4 a b c d, V4 a' b' c' d') g = case randomR (a,a') g of+ (a'', g') -> case randomR (b,b') g' of+ (b'', g'') -> case randomR (c,c') g'' of+ (c'', g''') -> case randomR (d,d') g''' of+ (d'', g'''') -> (V4 a'' b'' c'' d'', g'''')++instance Traversable V4 where+ traverse f (V4 a b c d) = V4 <$> f a <*> f b <*> f c <*> f d+ {-# INLINE traverse #-}++instance Foldable1 V4 where+ foldMap1 f (V4 a b c d) = f a <> f b <> f c <> f d+ {-# INLINE foldMap1 #-}++instance Traversable1 V4 where+ traverse1 f (V4 a b c d) = V4 <$> f a <.> f b <.> f c <.> f d+ {-# INLINE traverse1 #-}++instance Applicative V4 where+ pure a = V4 a a a a+ {-# INLINE pure #-}+ V4 a b c d <*> V4 e f g h = V4 (a e) (b f) (c g) (d h)+ {-# INLINE (<*>) #-}++instance Apply V4 where+ V4 a b c d <.> V4 e f g h = V4 (a e) (b f) (c g) (d h)+ {-# INLINE (<.>) #-}++instance Additive V4 where+ zero = pure 0+ {-# INLINE zero #-}+ liftU2 = liftA2+ {-# INLINE liftU2 #-}+ liftI2 = liftA2+ {-# INLINE liftI2 #-}++instance Bind V4 where+ V4 a b c d >>- f = V4 a' b' c' d' where+ V4 a' _ _ _ = f a+ V4 _ b' _ _ = f b+ V4 _ _ c' _ = f c+ V4 _ _ _ d' = f d+ {-# INLINE (>>-) #-}++instance Monad V4 where+#if !(MIN_VERSION_base(4,11,0))+ return a = V4 a a a a+ {-# INLINE return #-}+#endif+ V4 a b c d >>= f = V4 a' b' c' d' where+ V4 a' _ _ _ = f a+ V4 _ b' _ _ = f b+ V4 _ _ c' _ = f c+ V4 _ _ _ d' = f d+ {-# INLINE (>>=) #-}++instance Num a => Num (V4 a) where+ (+) = liftA2 (+)+ {-# INLINE (+) #-}+ (*) = liftA2 (*)+ {-# INLINE (-) #-}+ (-) = liftA2 (-)+ {-# INLINE (*) #-}+ negate = fmap negate+ {-# INLINE negate #-}+ abs = fmap abs+ {-# INLINE abs #-}+ signum = fmap signum+ {-# INLINE signum #-}+ fromInteger = pure . fromInteger+ {-# INLINE fromInteger #-}++instance Fractional a => Fractional (V4 a) where+ recip = fmap recip+ {-# INLINE recip #-}+ (/) = liftA2 (/)+ {-# INLINE (/) #-}+ fromRational = pure . fromRational+ {-# INLINE fromRational #-}++instance Floating a => Floating (V4 a) where+ pi = pure pi+ {-# INLINE pi #-}+ exp = fmap exp+ {-# INLINE exp #-}+ sqrt = fmap sqrt+ {-# INLINE sqrt #-}+ log = fmap log+ {-# INLINE log #-}+ (**) = liftA2 (**)+ {-# INLINE (**) #-}+ logBase = liftA2 logBase+ {-# INLINE logBase #-}+ sin = fmap sin+ {-# INLINE sin #-}+ tan = fmap tan+ {-# INLINE tan #-}+ cos = fmap cos+ {-# INLINE cos #-}+ asin = fmap asin+ {-# INLINE asin #-}+ atan = fmap atan+ {-# INLINE atan #-}+ acos = fmap acos+ {-# INLINE acos #-}+ sinh = fmap sinh+ {-# INLINE sinh #-}+ tanh = fmap tanh+ {-# INLINE tanh #-}+ cosh = fmap cosh+ {-# INLINE cosh #-}+ asinh = fmap asinh+ {-# INLINE asinh #-}+ atanh = fmap atanh+ {-# INLINE atanh #-}+ acosh = fmap acosh+ {-# INLINE acosh #-}++instance Metric V4 where+ dot (V4 a b c d) (V4 e f g h) = a * e + b * f + c * g + d * h+ {-# INLINE dot #-}++instance Distributive V4 where+ distribute f = V4 (fmap (\(V4 x _ _ _) -> x) f)+ (fmap (\(V4 _ y _ _) -> y) f)+ (fmap (\(V4 _ _ z _) -> z) f)+ (fmap (\(V4 _ _ _ w) -> w) f)+ {-# INLINE distribute #-}++instance Hashable a => Hashable (V4 a) where+ hashWithSalt s (V4 a b c d) = s `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c `hashWithSalt` d+ {-# INLINE hashWithSalt #-}++instance Hashable1 V4 where+ liftHashWithSalt h s (V4 a b c d) = s `h` a `h` b `h` c `h` d+ {-# INLINE liftHashWithSalt #-}++-- | A space that distinguishes orthogonal basis vectors '_x', '_y', '_z', '_w'. (It may have more.)+class R3 t => R4 t where+ -- |+ -- >>> V4 1 2 3 4 ^._w+ -- 4+ _w :: Lens' (t a) a+ _xyzw :: Lens' (t a) (V4 a)++_xw, _yw, _zw, _wx, _wy, _wz :: R4 t => Lens' (t a) (V2 a)+_xw f = _xyzw $ \(V4 a b c d) -> f (V2 a d) <&> \(V2 a' d') -> V4 a' b c d'+{-# INLINE _xw #-}++_yw f = _xyzw $ \(V4 a b c d) -> f (V2 b d) <&> \(V2 b' d') -> V4 a b' c d'+{-# INLINE _yw #-}++_zw f = _xyzw $ \(V4 a b c d) -> f (V2 c d) <&> \(V2 c' d') -> V4 a b c' d'+{-# INLINE _zw #-}++_wx f = _xyzw $ \(V4 a b c d) -> f (V2 d a) <&> \(V2 d' a') -> V4 a' b c d'+{-# INLINE _wx #-}++_wy f = _xyzw $ \(V4 a b c d) -> f (V2 d b) <&> \(V2 d' b') -> V4 a b' c d'+{-# INLINE _wy #-}++_wz f = _xyzw $ \(V4 a b c d) -> f (V2 d c) <&> \(V2 d' c') -> V4 a b c' d'+{-# INLINE _wz #-}++_xyw, _xzw, _xwy, _xwz, _yxw, _yzw, _ywx, _ywz, _zxw, _zyw, _zwx, _zwy, _wxy, _wxz, _wyx, _wyz, _wzx, _wzy :: R4 t => Lens' (t a) (V3 a)+_xyw f = _xyzw $ \(V4 a b c d) -> f (V3 a b d) <&> \(V3 a' b' d') -> V4 a' b' c d'+{-# INLINE _xyw #-}++_xzw f = _xyzw $ \(V4 a b c d) -> f (V3 a c d) <&> \(V3 a' c' d') -> V4 a' b c' d'+{-# INLINE _xzw #-}++_xwy f = _xyzw $ \(V4 a b c d) -> f (V3 a d b) <&> \(V3 a' d' b') -> V4 a' b' c d'+{-# INLINE _xwy #-}++_xwz f = _xyzw $ \(V4 a b c d) -> f (V3 a d c) <&> \(V3 a' d' c') -> V4 a' b c' d'+{-# INLINE _xwz #-}++_yxw f = _xyzw $ \(V4 a b c d) -> f (V3 b a d) <&> \(V3 b' a' d') -> V4 a' b' c d'+{-# INLINE _yxw #-}++_yzw f = _xyzw $ \(V4 a b c d) -> f (V3 b c d) <&> \(V3 b' c' d') -> V4 a b' c' d'+{-# INLINE _yzw #-}++_ywx f = _xyzw $ \(V4 a b c d) -> f (V3 b d a) <&> \(V3 b' d' a') -> V4 a' b' c d'+{-# INLINE _ywx #-}++_ywz f = _xyzw $ \(V4 a b c d) -> f (V3 b d c) <&> \(V3 b' d' c') -> V4 a b' c' d'+{-# INLINE _ywz #-}++_zxw f = _xyzw $ \(V4 a b c d) -> f (V3 c a d) <&> \(V3 c' a' d') -> V4 a' b c' d'+{-# INLINE _zxw #-}++_zyw f = _xyzw $ \(V4 a b c d) -> f (V3 c b d) <&> \(V3 c' b' d') -> V4 a b' c' d'+{-# INLINE _zyw #-}++_zwx f = _xyzw $ \(V4 a b c d) -> f (V3 c d a) <&> \(V3 c' d' a') -> V4 a' b c' d'+{-# INLINE _zwx #-}++_zwy f = _xyzw $ \(V4 a b c d) -> f (V3 c d b) <&> \(V3 c' d' b') -> V4 a b' c' d'+{-# INLINE _zwy #-}++_wxy f = _xyzw $ \(V4 a b c d) -> f (V3 d a b) <&> \(V3 d' a' b') -> V4 a' b' c d'+{-# INLINE _wxy #-}++_wxz f = _xyzw $ \(V4 a b c d) -> f (V3 d a c) <&> \(V3 d' a' c') -> V4 a' b c' d'+{-# INLINE _wxz #-}++_wyx f = _xyzw $ \(V4 a b c d) -> f (V3 d b a) <&> \(V3 d' b' a') -> V4 a' b' c d'+{-# INLINE _wyx #-}++_wyz f = _xyzw $ \(V4 a b c d) -> f (V3 d b c) <&> \(V3 d' b' c') -> V4 a b' c' d'+{-# INLINE _wyz #-}++_wzx f = _xyzw $ \(V4 a b c d) -> f (V3 d c a) <&> \(V3 d' c' a') -> V4 a' b c' d'+{-# INLINE _wzx #-}++_wzy f = _xyzw $ \(V4 a b c d) -> f (V3 d c b) <&> \(V3 d' c' b') -> V4 a b' c' d'+{-# INLINE _wzy #-}++_xywz, _xzyw, _xzwy, _xwyz, _xwzy, _yxzw , _yxwz, _yzxw, _yzwx, _ywxz+ , _ywzx, _zxyw, _zxwy, _zyxw, _zywx, _zwxy, _zwyx, _wxyz, _wxzy, _wyxz+ , _wyzx, _wzxy, _wzyx :: R4 t => Lens' (t a) (V4 a)+_xywz f = _xyzw $ \(V4 a b c d) -> f (V4 a b d c) <&> \(V4 a' b' d' c') -> V4 a' b' c' d'+{-# INLINE _xywz #-}++_xzyw f = _xyzw $ \(V4 a b c d) -> f (V4 a c b d) <&> \(V4 a' c' b' d') -> V4 a' b' c' d'+{-# INLINE _xzyw #-}++_xzwy f = _xyzw $ \(V4 a b c d) -> f (V4 a c d b) <&> \(V4 a' c' d' b') -> V4 a' b' c' d'+{-# INLINE _xzwy #-}++_xwyz f = _xyzw $ \(V4 a b c d) -> f (V4 a d b c) <&> \(V4 a' d' b' c') -> V4 a' b' c' d'+{-# INLINE _xwyz #-}++_xwzy f = _xyzw $ \(V4 a b c d) -> f (V4 a d c b) <&> \(V4 a' d' c' b') -> V4 a' b' c' d'+{-# INLINE _xwzy #-}++_yxzw f = _xyzw $ \(V4 a b c d) -> f (V4 b a c d) <&> \(V4 b' a' c' d') -> V4 a' b' c' d'+{-# INLINE _yxzw #-}++_yxwz f = _xyzw $ \(V4 a b c d) -> f (V4 b a d c) <&> \(V4 b' a' d' c') -> V4 a' b' c' d'+{-# INLINE _yxwz #-}++_yzxw f = _xyzw $ \(V4 a b c d) -> f (V4 b c a d) <&> \(V4 b' c' a' d') -> V4 a' b' c' d'+{-# INLINE _yzxw #-}++_yzwx f = _xyzw $ \(V4 a b c d) -> f (V4 b c d a) <&> \(V4 b' c' d' a') -> V4 a' b' c' d'+{-# INLINE _yzwx #-}++_ywxz f = _xyzw $ \(V4 a b c d) -> f (V4 b d a c) <&> \(V4 b' d' a' c') -> V4 a' b' c' d'+{-# INLINE _ywxz #-}++_ywzx f = _xyzw $ \(V4 a b c d) -> f (V4 b d c a) <&> \(V4 b' d' c' a') -> V4 a' b' c' d'+{-# INLINE _ywzx #-}++_zxyw f = _xyzw $ \(V4 a b c d) -> f (V4 c a b d) <&> \(V4 c' a' b' d') -> V4 a' b' c' d'+{-# INLINE _zxyw #-}++_zxwy f = _xyzw $ \(V4 a b c d) -> f (V4 c a d b) <&> \(V4 c' a' d' b') -> V4 a' b' c' d'+{-# INLINE _zxwy #-}++_zyxw f = _xyzw $ \(V4 a b c d) -> f (V4 c b a d) <&> \(V4 c' b' a' d') -> V4 a' b' c' d'+{-# INLINE _zyxw #-}++_zywx f = _xyzw $ \(V4 a b c d) -> f (V4 c b d a) <&> \(V4 c' b' d' a') -> V4 a' b' c' d'+{-# INLINE _zywx #-}++_zwxy f = _xyzw $ \(V4 a b c d) -> f (V4 c d a b) <&> \(V4 c' d' a' b') -> V4 a' b' c' d'+{-# INLINE _zwxy #-}++_zwyx f = _xyzw $ \(V4 a b c d) -> f (V4 c d b a) <&> \(V4 c' d' b' a') -> V4 a' b' c' d'+{-# INLINE _zwyx #-}++_wxyz f = _xyzw $ \(V4 a b c d) -> f (V4 d a b c) <&> \(V4 d' a' b' c') -> V4 a' b' c' d'+{-# INLINE _wxyz #-}++_wxzy f = _xyzw $ \(V4 a b c d) -> f (V4 d a c b) <&> \(V4 d' a' c' b') -> V4 a' b' c' d'+{-# INLINE _wxzy #-}++_wyxz f = _xyzw $ \(V4 a b c d) -> f (V4 d b a c) <&> \(V4 d' b' a' c') -> V4 a' b' c' d'+{-# INLINE _wyxz #-}++_wyzx f = _xyzw $ \(V4 a b c d) -> f (V4 d b c a) <&> \(V4 d' b' c' a') -> V4 a' b' c' d'+{-# INLINE _wyzx #-}++_wzxy f = _xyzw $ \(V4 a b c d) -> f (V4 d c a b) <&> \(V4 d' c' a' b') -> V4 a' b' c' d'+{-# INLINE _wzxy #-}++_wzyx f = _xyzw $ \(V4 a b c d) -> f (V4 d c b a) <&> \(V4 d' c' b' a') -> V4 a' b' c' d'+{-# INLINE _wzyx #-}++ew :: R4 t => E t+ew = E _w++instance R1 V4 where+ _x f (V4 a b c d) = (\a' -> V4 a' b c d) <$> f a+ {-# INLINE _x #-}++instance R2 V4 where+ _y f (V4 a b c d) = (\b' -> V4 a b' c d) <$> f b+ {-# INLINE _y #-}+ _xy f (V4 a b c d) = (\(V2 a' b') -> V4 a' b' c d) <$> f (V2 a b)+ {-# INLINE _xy #-}++instance R3 V4 where+ _z f (V4 a b c d) = (\c' -> V4 a b c' d) <$> f c+ {-# INLINE _z #-}+ _xyz f (V4 a b c d) = (\(V3 a' b' c') -> V4 a' b' c' d) <$> f (V3 a b c)+ {-# INLINE _xyz #-}++instance R4 V4 where+ _w f (V4 a b c d) = V4 a b c <$> f d+ {-# INLINE _w #-}+ _xyzw = id+ {-# INLINE _xyzw #-}++instance Storable a => Storable (V4 a) where+ sizeOf _ = 4 * sizeOf (undefined::a)+ {-# INLINE sizeOf #-}+ alignment _ = alignment (undefined::a)+ {-# INLINE alignment #-}+ poke ptr (V4 x y z w) = do poke ptr' x+ pokeElemOff ptr' 1 y+ pokeElemOff ptr' 2 z+ pokeElemOff ptr' 3 w+ where ptr' = castPtr ptr+ {-# INLINE poke #-}+ peek ptr = V4 <$> peek ptr' <*> peekElemOff ptr' 1+ <*> peekElemOff ptr' 2 <*> peekElemOff ptr' 3+ where ptr' = castPtr ptr+ {-# INLINE peek #-}++-- | Convert a 3-dimensional affine vector into a 4-dimensional homogeneous vector,+-- i.e. sets the @w@ coordinate to 0.+vector :: Num a => V3 a -> V4 a+vector (V3 a b c) = V4 a b c 0+{-# INLINE vector #-}++-- | Convert a 3-dimensional affine point into a 4-dimensional homogeneous vector,+-- i.e. sets the @w@ coordinate to 1.+point :: Num a => V3 a -> V4 a+point (V3 a b c) = V4 a b c 1+{-# INLINE point #-}++-- | Convert 4-dimensional projective coordinates to a 3-dimensional+-- point. This operation may be denoted, @euclidean [x:y:z:w] = (x\/w,+-- y\/w, z\/w)@ where the projective, homogenous, coordinate+-- @[x:y:z:w]@ is one of many associated with a single point @(x\/w,+-- y\/w, z\/w)@.+normalizePoint :: Fractional a => V4 a -> V3 a+normalizePoint (V4 a b c w) = (1/w) *^ V3 a b c+{-# INLINE normalizePoint #-}++instance Epsilon a => Epsilon (V4 a) where+ nearZero = nearZero . quadrance+ {-# INLINE nearZero #-}++instance Ix a => Ix (V4 a) where+ {-# SPECIALISE instance Ix (V4 Int) #-}++ range (V4 l1 l2 l3 l4,V4 u1 u2 u3 u4) =+ [V4 i1 i2 i3 i4 | i1 <- range (l1,u1)+ , i2 <- range (l2,u2)+ , i3 <- range (l3,u3)+ , i4 <- range (l4,u4)+ ]+ {-# INLINE range #-}++ unsafeIndex (V4 l1 l2 l3 l4,V4 u1 u2 u3 u4) (V4 i1 i2 i3 i4) =+ unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * (+ unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * (+ unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) *+ unsafeIndex (l1,u1) i1))+ {-# INLINE unsafeIndex #-}++ inRange (V4 l1 l2 l3 l4,V4 u1 u2 u3 u4) (V4 i1 i2 i3 i4) =+ inRange (l1,u1) i1 && inRange (l2,u2) i2 &&+ inRange (l3,u3) i3 && inRange (l4,u4) i4+ {-# INLINE inRange #-}++instance Representable V4 where+ type Rep V4 = E V4+ tabulate f = V4 (f ex) (f ey) (f ez) (f ew)+ {-# INLINE tabulate #-}+ index xs (E l) = view l xs+ {-# INLINE index #-}++instance WithIndex.FunctorWithIndex (E V4) V4 where+ imap f (V4 a b c d) = V4 (f ex a) (f ey b) (f ez c) (f ew d)+ {-# INLINE imap #-}++instance WithIndex.FoldableWithIndex (E V4) V4 where+ ifoldMap f (V4 a b c d) = f ex a `mappend` f ey b `mappend` f ez c `mappend` f ew d+ {-# INLINE ifoldMap #-}++instance WithIndex.TraversableWithIndex (E V4) V4 where+ itraverse f (V4 a b c d) = V4 <$> f ex a <*> f ey b <*> f ez c <*> f ew d+ {-# INLINE itraverse #-}++#if !MIN_VERSION_lens(5,0,0)+instance Lens.FunctorWithIndex (E V4) V4 where imap = WithIndex.imap+instance Lens.FoldableWithIndex (E V4) V4 where ifoldMap = WithIndex.ifoldMap+instance Lens.TraversableWithIndex (E V4) V4 where itraverse = WithIndex.itraverse+#endif++type instance Index (V4 a) = E V4+type instance IxValue (V4 a) = a++instance Ixed (V4 a) where+ ix i = el i++instance Each (V4 a) (V4 b) a b where+ each = traverse++data instance U.Vector (V4 a) = V_V4 {-# UNPACK #-} !Int !(U.Vector a)+data instance U.MVector s (V4 a) = MV_V4 {-# UNPACK #-} !Int !(U.MVector s a)+instance U.Unbox a => U.Unbox (V4 a)++instance U.Unbox a => M.MVector U.MVector (V4 a) where+ basicLength (MV_V4 n _) = n+ basicUnsafeSlice m n (MV_V4 _ v) = MV_V4 n (M.basicUnsafeSlice (4*m) (4*n) v)+ basicOverlaps (MV_V4 _ v) (MV_V4 _ u) = M.basicOverlaps v u+ basicUnsafeNew n = liftM (MV_V4 n) (M.basicUnsafeNew (4*n))+ basicUnsafeRead (MV_V4 _ v) i =+ do let o = 4*i+ x <- M.basicUnsafeRead v o+ y <- M.basicUnsafeRead v (o+1)+ z <- M.basicUnsafeRead v (o+2)+ w <- M.basicUnsafeRead v (o+3)+ return (V4 x y z w)+ basicUnsafeWrite (MV_V4 _ v) i (V4 x y z w) =+ do let o = 4*i+ M.basicUnsafeWrite v o x+ M.basicUnsafeWrite v (o+1) y+ M.basicUnsafeWrite v (o+2) z+ M.basicUnsafeWrite v (o+3) w+ basicInitialize (MV_V4 _ v) = M.basicInitialize v++instance U.Unbox a => G.Vector U.Vector (V4 a) where+ basicUnsafeFreeze (MV_V4 n v) = liftM ( V_V4 n) (G.basicUnsafeFreeze v)+ basicUnsafeThaw ( V_V4 n v) = liftM (MV_V4 n) (G.basicUnsafeThaw v)+ basicLength ( V_V4 n _) = n+ basicUnsafeSlice m n (V_V4 _ v) = V_V4 n (G.basicUnsafeSlice (4*m) (4*n) v)+ basicUnsafeIndexM (V_V4 _ v) i =+ do let o = 4*i+ x <- G.basicUnsafeIndexM v o+ y <- G.basicUnsafeIndexM v (o+1)+ z <- G.basicUnsafeIndexM v (o+2)+ w <- G.basicUnsafeIndexM v (o+3)+ return (V4 x y z w)++instance MonadZip V4 where+ mzipWith = liftA2++instance MonadFix V4 where+ mfix f = V4 (let V4 a _ _ _ = f a in a)+ (let V4 _ a _ _ = f a in a)+ (let V4 _ _ a _ = f a in a)+ (let V4 _ _ _ a = f a in a)++instance Bounded a => Bounded (V4 a) where+ minBound = pure minBound+ {-# INLINE minBound #-}+ maxBound = pure maxBound+ {-# INLINE maxBound #-}++instance NFData a => NFData (V4 a) where+ rnf (V4 a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d++instance Serial1 V4 where+ serializeWith = traverse_+ deserializeWith k = V4 <$> k <*> k <*> k <*> k++instance Serial a => Serial (V4 a) where+ serialize = serializeWith serialize+ deserialize = deserializeWith deserialize++instance Binary a => Binary (V4 a) where+ put = serializeWith Binary.put+ get = deserializeWith Binary.get++instance Serialize a => Serialize (V4 a) where+ put = serializeWith Cereal.put+ get = deserializeWith Cereal.get++instance Eq1 V4 where+ liftEq k (V4 a b c d) (V4 e f g h) = k a e && k b f && k c g && k d h+instance Ord1 V4 where+ liftCompare k (V4 a b c d) (V4 e f g h) = k a e `mappend` k b f `mappend` k c g `mappend` k d h+instance Read1 V4 where+ liftReadsPrec k _ z = readParen (z > 10) $ \r ->+ [ (V4 a b c d, r5)+ | ("V4",r1) <- lex r+ , (a,r2) <- k 11 r1+ , (b,r3) <- k 11 r2+ , (c,r4) <- k 11 r3+ , (d,r5) <- k 11 r4+ ]+instance Show1 V4 where+ liftShowsPrec f _ z (V4 a b c d) = showParen (z > 10) $+ showString "V4 " . f 11 a . showChar ' ' . f 11 b . showChar ' ' . f 11 c . showChar ' ' . f 11 d++instance Field1 (V4 a) (V4 a) a a where+ _1 f (V4 x y z w) = f x <&> \x' -> V4 x' y z w++instance Field2 (V4 a) (V4 a) a a where+ _2 f (V4 x y z w) = f y <&> \y' -> V4 x y' z w++instance Field3 (V4 a) (V4 a) a a where+ _3 f (V4 x y z w) = f z <&> \z' -> V4 x y z' w++instance Field4 (V4 a) (V4 a) a a where+ _4 f (V4 x y z w) = f w <&> \w' -> V4 x y z w'++instance Semigroup a => Semigroup (V4 a) where+ (<>) = liftA2 (<>)++instance Monoid a => Monoid (V4 a) where+ mempty = pure mempty+#if !(MIN_VERSION_base(4,11,0))+ mappend = liftA2 mappend+#endif+
src/Linear/Vector.hs view
@@ -1,349 +1,354 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE DefaultSignatures #-} ------------------------------------------------------------------------------ --- | --- Copyright : (C) 2012-2015 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : provisional --- Portability : portable --- --- Operations on free vector spaces. ------------------------------------------------------------------------------ -module Linear.Vector - ( Additive(..) - , E(..) - , negated - , (^*) - , (*^) - , (^/) - , sumV - , basis - , basisFor - , scaled - , outer - , unit - ) where - -import Control.Applicative -import Control.Lens -import Data.Complex -import Data.Foldable as Foldable (forM_, foldl') -import Data.Functor.Compose -import Data.Functor.Product -import Data.HashMap.Lazy as HashMap -import Data.Hashable -import Data.IntMap as IntMap -import Data.Map as Map -import qualified Data.Vector as Vector -import Data.Vector (Vector) -import qualified Data.Vector.Mutable as Mutable -import GHC.Generics -import Linear.Instances () - --- $setup --- >>> import Linear.V2 - --- | Basis element -newtype E t = E { el :: forall x. Lens' (t x) x } - -infixl 6 ^+^, ^-^ -infixl 7 ^*, *^, ^/ - -class GAdditive f where - gzero :: Num a => f a - gliftU2 :: (a -> a -> a) -> f a -> f a -> f a - gliftI2 :: (a -> b -> c) -> f a -> f b -> f c - -instance GAdditive U1 where - gzero = U1 - {-# INLINE gzero #-} - gliftU2 _ U1 U1 = U1 - {-# INLINE gliftU2 #-} - gliftI2 _ U1 U1 = U1 - {-# INLINE gliftI2 #-} - -instance (GAdditive f, GAdditive g) => GAdditive (f :*: g) where - gzero = gzero :*: gzero - {-# INLINE gzero #-} - gliftU2 f (a :*: b) (c :*: d) = gliftU2 f a c :*: gliftU2 f b d - {-# INLINE gliftU2 #-} - gliftI2 f (a :*: b) (c :*: d) = gliftI2 f a c :*: gliftI2 f b d - {-# INLINE gliftI2 #-} - -instance (Additive f, GAdditive g) => GAdditive (f :.: g) where - gzero = Comp1 $ gzero <$ (zero :: f Int) - {-# INLINE gzero #-} - gliftU2 f (Comp1 a) (Comp1 b) = Comp1 $ liftU2 (gliftU2 f) a b - {-# INLINE gliftU2 #-} - gliftI2 f (Comp1 a) (Comp1 b) = Comp1 $ liftI2 (gliftI2 f) a b - {-# INLINE gliftI2 #-} - -instance Additive f => GAdditive (Rec1 f) where - gzero = Rec1 zero - {-# INLINE gzero #-} - gliftU2 f (Rec1 g) (Rec1 h) = Rec1 (liftU2 f g h) - {-# INLINE gliftU2 #-} - gliftI2 f (Rec1 g) (Rec1 h) = Rec1 (liftI2 f g h) - {-# INLINE gliftI2 #-} - -instance GAdditive f => GAdditive (M1 i c f) where - gzero = M1 gzero - {-# INLINE gzero #-} - gliftU2 f (M1 g) (M1 h) = M1 (gliftU2 f g h) - {-# INLINE gliftU2 #-} - gliftI2 f (M1 g) (M1 h) = M1 (gliftI2 f g h) - {-# INLINE gliftI2 #-} - -instance GAdditive Par1 where - gzero = Par1 0 - gliftU2 f (Par1 a) (Par1 b) = Par1 (f a b) - {-# INLINE gliftU2 #-} - gliftI2 f (Par1 a) (Par1 b) = Par1 (f a b) - {-# INLINE gliftI2 #-} - --- | A vector is an additive group with additional structure. -class Functor f => Additive f where - -- | The zero vector - zero :: Num a => f a -#ifndef HLINT - default zero :: (GAdditive (Rep1 f), Generic1 f, Num a) => f a - zero = to1 gzero -#endif - - -- | Compute the sum of two vectors - -- - -- >>> V2 1 2 ^+^ V2 3 4 - -- V2 4 6 - (^+^) :: Num a => f a -> f a -> f a - (^+^) = liftU2 (+) - {-# INLINE (^+^) #-} - - -- | Compute the difference between two vectors - -- - -- >>> V2 4 5 ^-^ V2 3 1 - -- V2 1 4 - (^-^) :: Num a => f a -> f a -> f a - x ^-^ y = x ^+^ negated y - - -- | Linearly interpolate between two vectors. - lerp :: Num a => a -> f a -> f a -> f a - lerp alpha u v = alpha *^ u ^+^ (1 - alpha) *^ v - {-# INLINE lerp #-} - - -- | Apply a function to merge the 'non-zero' components of two vectors, unioning the rest of the values. - -- - -- * For a dense vector this is equivalent to 'liftA2'. - -- - -- * For a sparse vector this is equivalent to 'unionWith'. - liftU2 :: (a -> a -> a) -> f a -> f a -> f a -#ifndef HLINT - default liftU2 :: Applicative f => (a -> a -> a) -> f a -> f a -> f a - liftU2 = liftA2 - {-# INLINE liftU2 #-} -#endif - - -- | Apply a function to the components of two vectors. - -- - -- * For a dense vector this is equivalent to 'liftA2'. - -- - -- * For a sparse vector this is equivalent to 'intersectionWith'. - liftI2 :: (a -> b -> c) -> f a -> f b -> f c -#ifndef HLINT - default liftI2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c - liftI2 = liftA2 - {-# INLINE liftI2 #-} -#endif - -instance (Additive f, Additive g) => Additive (Product f g) where - zero = Pair zero zero - liftU2 f (Pair a b) (Pair c d) = Pair (liftU2 f a c) (liftU2 f b d) - liftI2 f (Pair a b) (Pair c d) = Pair (liftI2 f a c) (liftI2 f b d) - Pair a b ^+^ Pair c d = Pair (a ^+^ c) (b ^+^ d) - Pair a b ^-^ Pair c d = Pair (a ^-^ c) (b ^-^ d) - lerp alpha (Pair a b) (Pair c d) = Pair (lerp alpha a c) (lerp alpha b d) - -instance (Additive f, Additive g) => Additive (Compose f g) where - zero = Compose $ zero <$ (zero :: f Int) - {-# INLINE zero #-} - Compose a ^+^ Compose b = Compose $ liftU2 (^+^) a b - {-# INLINE (^+^) #-} - Compose a ^-^ Compose b = Compose $ liftU2 (^-^) a b - {-# INLINE (^-^) #-} - liftU2 f (Compose a) (Compose b) = Compose $ liftU2 (liftU2 f) a b - {-# INLINE liftU2 #-} - liftI2 f (Compose a) (Compose b) = Compose $ liftI2 (liftI2 f) a b - {-# INLINE liftI2 #-} - -instance Additive ZipList where - zero = ZipList [] - {-# INLINE zero #-} - liftU2 f (ZipList xs) (ZipList ys) = ZipList (liftU2 f xs ys) - {-# INLINE liftU2 #-} - liftI2 = liftA2 - {-# INLINE liftI2 #-} - -instance Additive Vector where - zero = mempty - {-# INLINE zero #-} - liftU2 f u v = case compare lu lv of - LT | lu == 0 -> v - | otherwise -> Vector.modify (\ w -> Foldable.forM_ [0..lu-1] $ \i -> Mutable.unsafeWrite w i $ f (Vector.unsafeIndex u i) (Vector.unsafeIndex v i)) v - EQ -> Vector.zipWith f u v - GT | lv == 0 -> u - | otherwise -> Vector.modify (\ w -> Foldable.forM_ [0..lv-1] $ \i -> Mutable.unsafeWrite w i $ f (Vector.unsafeIndex u i) (Vector.unsafeIndex v i)) u - where - lu = Vector.length u - lv = Vector.length v - {-# INLINE liftU2 #-} - liftI2 = Vector.zipWith - {-# INLINE liftI2 #-} - -instance Additive Maybe where - zero = Nothing - {-# INLINE zero #-} - liftU2 f (Just a) (Just b) = Just (f a b) - liftU2 _ Nothing ys = ys - liftU2 _ xs Nothing = xs - {-# INLINE liftU2 #-} - liftI2 = liftA2 - {-# INLINE liftI2 #-} - -instance Additive [] where - zero = [] - {-# INLINE zero #-} - liftU2 f = go where - go (x:xs) (y:ys) = f x y : go xs ys - go [] ys = ys - go xs [] = xs - {-# INLINE liftU2 #-} - liftI2 = Prelude.zipWith - {-# INLINE liftI2 #-} - -instance Additive IntMap where - zero = IntMap.empty - {-# INLINE zero #-} - liftU2 = IntMap.unionWith - {-# INLINE liftU2 #-} - liftI2 = IntMap.intersectionWith - {-# INLINE liftI2 #-} - -instance Ord k => Additive (Map k) where - zero = Map.empty - {-# INLINE zero #-} - liftU2 = Map.unionWith - {-# INLINE liftU2 #-} - liftI2 = Map.intersectionWith - {-# INLINE liftI2 #-} - -instance (Eq k, Hashable k) => Additive (HashMap k) where - zero = HashMap.empty - {-# INLINE zero #-} - liftU2 = HashMap.unionWith - {-# INLINE liftU2 #-} - liftI2 = HashMap.intersectionWith - {-# INLINE liftI2 #-} - -instance Additive ((->) b) where - zero = const 0 - {-# INLINE zero #-} - liftU2 = liftA2 - {-# INLINE liftU2 #-} - liftI2 = liftA2 - {-# INLINE liftI2 #-} - -instance Additive Complex where - zero = 0 :+ 0 - {-# INLINE zero #-} - liftU2 f (a :+ b) (c :+ d) = f a c :+ f b d - {-# INLINE liftU2 #-} - liftI2 f (a :+ b) (c :+ d) = f a c :+ f b d - {-# INLINE liftI2 #-} - -instance Additive Identity where - zero = Identity 0 - {-# INLINE zero #-} - liftU2 = liftA2 - {-# INLINE liftU2 #-} - liftI2 = liftA2 - {-# INLINE liftI2 #-} - --- | Compute the negation of a vector --- --- >>> negated (V2 2 4) --- V2 (-2) (-4) -negated :: (Functor f, Num a) => f a -> f a -negated = fmap negate -{-# INLINE negated #-} - --- | Sum over multiple vectors --- --- >>> sumV [V2 1 1, V2 3 4] --- V2 4 5 -sumV :: (Foldable f, Additive v, Num a) => f (v a) -> v a -sumV = Foldable.foldl' (^+^) zero -{-# INLINE sumV #-} - --- | Compute the left scalar product --- --- >>> 2 *^ V2 3 4 --- V2 6 8 -(*^) :: (Functor f, Num a) => a -> f a -> f a -(*^) a = fmap (a*) -{-# INLINE (*^) #-} - --- | Compute the right scalar product --- --- >>> V2 3 4 ^* 2 --- V2 6 8 -(^*) :: (Functor f, Num a) => f a -> a -> f a -f ^* a = fmap (*a) f -{-# INLINE (^*) #-} - --- | Compute division by a scalar on the right. -(^/) :: (Functor f, Fractional a) => f a -> a -> f a -f ^/ a = fmap (/a) f -{-# INLINE (^/) #-} - --- | Produce a default basis for a vector space. If the dimensionality --- of the vector space is not statically known, see 'basisFor'. -basis :: (Additive t, Traversable t, Num a) => [t a] -basis = basisFor (zero :: Additive v => v Int) - --- | Produce a default basis for a vector space from which the --- argument is drawn. -basisFor :: (Traversable t, Num a) => t b -> [t a] -basisFor = \t -> - ifoldMapOf traversed ?? t $ \i _ -> - return $ - iover traversed ?? t $ \j _ -> - if i == j then 1 else 0 -{-# INLINABLE basisFor #-} - --- | Produce a diagonal (scale) matrix from a vector. --- --- >>> scaled (V2 2 3) --- V2 (V2 2 0) (V2 0 3) -scaled :: (Traversable t, Num a) => t a -> t (t a) -scaled = \t -> iter t (\i x -> iter t (\j _ -> if i == j then x else 0)) - where - iter :: Traversable t => t a -> (Int -> a -> b) -> t b - iter x f = iover traversed f x -{-# INLINE scaled #-} - --- | Create a unit vector. --- --- >>> unit _x :: V2 Int --- V2 1 0 -unit :: (Additive t, Num a) => ASetter' (t a) a -> t a -unit l = set' l 1 zero - --- | Outer (tensor) product of two vectors -outer :: (Functor f, Functor g, Num a) => f a -> g a -> f (g a) -outer a b = fmap (\x->fmap (*x) b) a +{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE DefaultSignatures #-}+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2012-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- Operations on free vector spaces.+-----------------------------------------------------------------------------+module Linear.Vector+ ( Additive(..)+ , E(..)+ , negated+ , (^*)+ , (*^)+ , (^/)+ , sumV+ , basis+ , basisFor+ , scaled+ , outer+ , unit+ ) where++import Control.Applicative+import Control.Lens+import Data.Complex+import Data.Foldable as Foldable (forM_, foldl')+import Data.Functor.Compose+import Data.Functor.Product+import Data.HashMap.Lazy as HashMap+import Data.Hashable+import Data.IntMap as IntMap+import Data.Map as Map+import qualified Data.Vector as Vector+import Data.Vector (Vector)+import qualified Data.Vector.Mutable as Mutable+import GHC.Generics+import Linear.Instances ()++-- $setup+-- >>> import Linear.V2++-- | Basis element+newtype E t = E { el :: forall x. Lens' (t x) x }++infixl 6 ^+^, ^-^+infixl 7 ^*, *^, ^/++class GAdditive f where+ gzero :: Num a => f a+ gliftU2 :: (a -> a -> a) -> f a -> f a -> f a+ gliftI2 :: (a -> b -> c) -> f a -> f b -> f c++instance GAdditive U1 where+ gzero = U1+ {-# INLINE gzero #-}+ gliftU2 _ U1 U1 = U1+ {-# INLINE gliftU2 #-}+ gliftI2 _ U1 U1 = U1+ {-# INLINE gliftI2 #-}++instance (GAdditive f, GAdditive g) => GAdditive (f :*: g) where+ gzero = gzero :*: gzero+ {-# INLINE gzero #-}+ gliftU2 f (a :*: b) (c :*: d) = gliftU2 f a c :*: gliftU2 f b d+ {-# INLINE gliftU2 #-}+ gliftI2 f (a :*: b) (c :*: d) = gliftI2 f a c :*: gliftI2 f b d+ {-# INLINE gliftI2 #-}++instance (Additive f, GAdditive g) => GAdditive (f :.: g) where+ gzero = Comp1 $ gzero <$ (zero :: f Int)+ {-# INLINE gzero #-}+ gliftU2 f (Comp1 a) (Comp1 b) = Comp1 $ liftU2 (gliftU2 f) a b+ {-# INLINE gliftU2 #-}+ gliftI2 f (Comp1 a) (Comp1 b) = Comp1 $ liftI2 (gliftI2 f) a b+ {-# INLINE gliftI2 #-}++instance Additive f => GAdditive (Rec1 f) where+ gzero = Rec1 zero+ {-# INLINE gzero #-}+ gliftU2 f (Rec1 g) (Rec1 h) = Rec1 (liftU2 f g h)+ {-# INLINE gliftU2 #-}+ gliftI2 f (Rec1 g) (Rec1 h) = Rec1 (liftI2 f g h)+ {-# INLINE gliftI2 #-}++instance GAdditive f => GAdditive (M1 i c f) where+ gzero = M1 gzero+ {-# INLINE gzero #-}+ gliftU2 f (M1 g) (M1 h) = M1 (gliftU2 f g h)+ {-# INLINE gliftU2 #-}+ gliftI2 f (M1 g) (M1 h) = M1 (gliftI2 f g h)+ {-# INLINE gliftI2 #-}++instance GAdditive Par1 where+ gzero = Par1 0+ gliftU2 f (Par1 a) (Par1 b) = Par1 (f a b)+ {-# INLINE gliftU2 #-}+ gliftI2 f (Par1 a) (Par1 b) = Par1 (f a b)+ {-# INLINE gliftI2 #-}++-- | A vector is an additive group with additional structure.+class Functor f => Additive f where+ -- | The zero vector+ zero :: Num a => f a+#ifndef HLINT+ default zero :: (GAdditive (Rep1 f), Generic1 f, Num a) => f a+ zero = to1 gzero+#endif++ -- | Compute the sum of two vectors+ --+ -- >>> V2 1 2 ^+^ V2 3 4+ -- V2 4 6+ (^+^) :: Num a => f a -> f a -> f a+ (^+^) = liftU2 (+)+ {-# INLINE (^+^) #-}++ -- | Compute the difference between two vectors+ --+ -- >>> V2 4 5 ^-^ V2 3 1+ -- V2 1 4+ (^-^) :: Num a => f a -> f a -> f a+ x ^-^ y = x ^+^ negated y++ -- | Linearly interpolate between two vectors.+ --+ -- /Since linear version 1.23, interpolation direction has been reversed; now/+ --+ -- > lerp 0 a b == a+ -- > lerp 1 a b == b+ lerp :: Num a => a -> f a -> f a -> f a+ lerp alpha u v = (1 - alpha) *^ u ^+^ alpha *^ v+ {-# INLINE lerp #-}++ -- | Apply a function to merge the 'non-zero' components of two vectors, unioning the rest of the values.+ --+ -- * For a dense vector this is equivalent to 'liftA2'.+ --+ -- * For a sparse vector this is equivalent to 'unionWith'.+ liftU2 :: (a -> a -> a) -> f a -> f a -> f a+#ifndef HLINT+ default liftU2 :: Applicative f => (a -> a -> a) -> f a -> f a -> f a+ liftU2 = liftA2+ {-# INLINE liftU2 #-}+#endif++ -- | Apply a function to the components of two vectors.+ --+ -- * For a dense vector this is equivalent to 'liftA2'.+ --+ -- * For a sparse vector this is equivalent to 'intersectionWith'.+ liftI2 :: (a -> b -> c) -> f a -> f b -> f c+#ifndef HLINT+ default liftI2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c+ liftI2 = liftA2+ {-# INLINE liftI2 #-}+#endif++instance (Additive f, Additive g) => Additive (Product f g) where+ zero = Pair zero zero+ liftU2 f (Pair a b) (Pair c d) = Pair (liftU2 f a c) (liftU2 f b d)+ liftI2 f (Pair a b) (Pair c d) = Pair (liftI2 f a c) (liftI2 f b d)+ Pair a b ^+^ Pair c d = Pair (a ^+^ c) (b ^+^ d)+ Pair a b ^-^ Pair c d = Pair (a ^-^ c) (b ^-^ d)+ lerp alpha (Pair a b) (Pair c d) = Pair (lerp alpha a c) (lerp alpha b d)++instance (Additive f, Additive g) => Additive (Compose f g) where+ zero = Compose $ zero <$ (zero :: f Int)+ {-# INLINE zero #-}+ Compose a ^+^ Compose b = Compose $ liftU2 (^+^) a b+ {-# INLINE (^+^) #-}+ Compose a ^-^ Compose b = Compose $ liftU2 (^-^) a b+ {-# INLINE (^-^) #-}+ liftU2 f (Compose a) (Compose b) = Compose $ liftU2 (liftU2 f) a b+ {-# INLINE liftU2 #-}+ liftI2 f (Compose a) (Compose b) = Compose $ liftI2 (liftI2 f) a b+ {-# INLINE liftI2 #-}++instance Additive ZipList where+ zero = ZipList []+ {-# INLINE zero #-}+ liftU2 f (ZipList xs) (ZipList ys) = ZipList (liftU2 f xs ys)+ {-# INLINE liftU2 #-}+ liftI2 = liftA2+ {-# INLINE liftI2 #-}++instance Additive Vector where+ zero = mempty+ {-# INLINE zero #-}+ liftU2 f u v = case compare lu lv of+ LT | lu == 0 -> v+ | otherwise -> Vector.modify (\ w -> Foldable.forM_ [0..lu-1] $ \i -> Mutable.unsafeWrite w i $ f (Vector.unsafeIndex u i) (Vector.unsafeIndex v i)) v+ EQ -> Vector.zipWith f u v+ GT | lv == 0 -> u+ | otherwise -> Vector.modify (\ w -> Foldable.forM_ [0..lv-1] $ \i -> Mutable.unsafeWrite w i $ f (Vector.unsafeIndex u i) (Vector.unsafeIndex v i)) u+ where+ lu = Vector.length u+ lv = Vector.length v+ {-# INLINE liftU2 #-}+ liftI2 = Vector.zipWith+ {-# INLINE liftI2 #-}++instance Additive Maybe where+ zero = Nothing+ {-# INLINE zero #-}+ liftU2 f (Just a) (Just b) = Just (f a b)+ liftU2 _ Nothing ys = ys+ liftU2 _ xs Nothing = xs+ {-# INLINE liftU2 #-}+ liftI2 = liftA2+ {-# INLINE liftI2 #-}++instance Additive [] where+ zero = []+ {-# INLINE zero #-}+ liftU2 f = go where+ go (x:xs) (y:ys) = f x y : go xs ys+ go [] ys = ys+ go xs [] = xs+ {-# INLINE liftU2 #-}+ liftI2 = Prelude.zipWith+ {-# INLINE liftI2 #-}++instance Additive IntMap where+ zero = IntMap.empty+ {-# INLINE zero #-}+ liftU2 = IntMap.unionWith+ {-# INLINE liftU2 #-}+ liftI2 = IntMap.intersectionWith+ {-# INLINE liftI2 #-}++instance Ord k => Additive (Map k) where+ zero = Map.empty+ {-# INLINE zero #-}+ liftU2 = Map.unionWith+ {-# INLINE liftU2 #-}+ liftI2 = Map.intersectionWith+ {-# INLINE liftI2 #-}++instance (Eq k, Hashable k) => Additive (HashMap k) where+ zero = HashMap.empty+ {-# INLINE zero #-}+ liftU2 = HashMap.unionWith+ {-# INLINE liftU2 #-}+ liftI2 = HashMap.intersectionWith+ {-# INLINE liftI2 #-}++instance Additive ((->) b) where+ zero = const 0+ {-# INLINE zero #-}+ liftU2 = liftA2+ {-# INLINE liftU2 #-}+ liftI2 = liftA2+ {-# INLINE liftI2 #-}++instance Additive Complex where+ zero = 0 :+ 0+ {-# INLINE zero #-}+ liftU2 f (a :+ b) (c :+ d) = f a c :+ f b d+ {-# INLINE liftU2 #-}+ liftI2 f (a :+ b) (c :+ d) = f a c :+ f b d+ {-# INLINE liftI2 #-}++instance Additive Identity where+ zero = Identity 0+ {-# INLINE zero #-}+ liftU2 = liftA2+ {-# INLINE liftU2 #-}+ liftI2 = liftA2+ {-# INLINE liftI2 #-}++-- | Compute the negation of a vector+--+-- >>> negated (V2 2 4)+-- V2 (-2) (-4)+negated :: (Functor f, Num a) => f a -> f a+negated = fmap negate+{-# INLINE negated #-}++-- | Sum over multiple vectors+--+-- >>> sumV [V2 1 1, V2 3 4]+-- V2 4 5+sumV :: (Foldable f, Additive v, Num a) => f (v a) -> v a+sumV = Foldable.foldl' (^+^) zero+{-# INLINE sumV #-}++-- | Compute the left scalar product+--+-- >>> 2 *^ V2 3 4+-- V2 6 8+(*^) :: (Functor f, Num a) => a -> f a -> f a+(*^) a = fmap (a*)+{-# INLINE (*^) #-}++-- | Compute the right scalar product+--+-- >>> V2 3 4 ^* 2+-- V2 6 8+(^*) :: (Functor f, Num a) => f a -> a -> f a+f ^* a = fmap (*a) f+{-# INLINE (^*) #-}++-- | Compute division by a scalar on the right.+(^/) :: (Functor f, Fractional a) => f a -> a -> f a+f ^/ a = fmap (/a) f+{-# INLINE (^/) #-}++-- | Produce a default basis for a vector space. If the dimensionality+-- of the vector space is not statically known, see 'basisFor'.+basis :: (Additive t, Traversable t, Num a) => [t a]+basis = basisFor (zero :: Additive v => v Int)++-- | Produce a default basis for a vector space from which the+-- argument is drawn.+basisFor :: (Traversable t, Num a) => t b -> [t a]+basisFor = \t ->+ ifoldMapOf traversed ?? t $ \i _ ->+ return $+ iover traversed ?? t $ \j _ ->+ if i == j then 1 else 0+{-# INLINABLE basisFor #-}++-- | Produce a diagonal (scale) matrix from a vector.+--+-- >>> scaled (V2 2 3)+-- V2 (V2 2 0) (V2 0 3)+scaled :: (Traversable t, Num a) => t a -> t (t a)+scaled = \t -> iter t (\i x -> iter t (\j _ -> if i == j then x else 0))+ where+ iter :: Traversable t => t a -> (Int -> a -> b) -> t b+ iter x f = iover traversed f x+{-# INLINE scaled #-}++-- | Create a unit vector.+--+-- >>> unit _x :: V2 Int+-- V2 1 0+unit :: (Additive t, Num a) => ASetter' (t a) a -> t a+unit l = set' l 1 zero++-- | Outer (tensor) product of two vectors+outer :: (Functor f, Functor g, Num a) => f a -> g a -> f (g a)+outer a b = fmap (\x->fmap (*x) b) a
− tests/Binary.hs
@@ -1,19 +0,0 @@-module Binary (tests) where - -import Data.Binary.Put -import Data.Binary.Get -import Linear -import qualified Data.ByteString.Lazy as BS -import Test.HUnit - -originalVecs :: (V3 Float, V2 Char) -originalVecs = (V3 1 2 3, V2 'a' 'b') - -bytes :: BS.ByteString -bytes = runPut $ do putLinear $ fst originalVecs - putLinear $ snd originalVecs - -tests :: Test -tests = test [ "Serialized length" ~: BS.length bytes ~?= 3*13+2 - , "Deserialization" ~: deserialized ~?= originalVecs ] - where deserialized = runGet ((,) <$> getLinear <*> getLinear) bytes
− tests/Plucker.hs
@@ -1,35 +0,0 @@-module Plucker (tests) where -import Linear -import Linear.Plucker -import Linear.Plucker.Coincides -import Test.HUnit - -ln2,ln3,ln4,ln5,ln6,ln7,ln8,ln9 :: Plucker Float -ln2 = plucker3D (V3 1 3 0) (V3 1 3 (-2)) -- starting line -ln3 = plucker3D (V3 2 3 0) (V3 2 3 (-2)) -- parallel -ln4 = plucker3D (V3 2 4 0) (V3 1 4 (-2)) -- ccw -ln5 = plucker3D (V3 (-2) 4 0) (V3 2 4 (-2)) -- cw -ln6 = plucker3D (V3 2 3 0) (V3 1 3 (-2)) -- intersect -ln7 = plucker3D (V3 1 3 0) (V3 1 3 2) -- reversed -ln8 = plucker3D (V3 0 4 4) (V3 0 (-4) (-4)) -- through origin -ln9 = Plucker 1 2 3 4 5 6 -- not a 3D line - -tests :: Test -tests = test [ "parallel" ~: parallel ln2 ln3 ~?= True - , "CCW" ~: passes ln2 ln4 ~?= Counterclockwise - , "CW" ~: passes ln2 ln5 ~?= Clockwise - , "intersect1" ~: intersects ln2 ln6 ~?= True - , "intersect2" ~: intersects ln2 ln3 ~?= False - , "line equality 1" ~: Line ln2 == Line ln2 ~?= True - , "line equality 2" ~: Line ln2 == Line ln7 ~?= True - , "line equality 3" ~: Line ln2 == Ray ln7 ~?= True - , "line equality 4" ~: Ray ln2 == Line ln7 ~?= True - , "ray equality 1" ~: Ray ln2 == Ray ln7 ~?= False - , "ray equality 2" ~: Ray ln2 == Ray (3 *^ ln2) ~?= True - , "ray equality 3" ~: Ray ln2 == Ray (negate ln7) ~?= True - , "quadrance" ~: nearZero (quadranceToOrigin ln2 - 10) ~?= True - , "closest 1" ~: - nearZero (qd (V3 1 3 0) $ closestToOrigin ln2) ~?= True - , "closest 2" ~: nearZero (qd 0 $ closestToOrigin ln8) ~?= True - , "isLine 1" ~: isLine ln2 ~?= True - , "isLine 2" ~: isLine ln9 ~?= False ]
+ tests/Prop/Quaternion.hs view
@@ -0,0 +1,28 @@+{-# OPTIONS_GHC -Wno-orphans #-}+module Prop.Quaternion (tests) where++import Linear.Quaternion (Quaternion(..))+import Linear.Epsilon (nearZero)+import Linear.Vector (lerp)+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck (Arbitrary(..))++import Prop.V3 ()++instance Arbitrary a => Arbitrary (Quaternion a) where+ arbitrary = Quaternion <$> arbitrary <*> arbitrary++prop_lerp0 :: Quaternion Double -> Quaternion Double -> Bool+prop_lerp0 a b = nearZero (lerp 0 a b - a)++prop_lerp1 :: Quaternion Double -> Quaternion Double -> Bool+prop_lerp1 a b = nearZero (lerp 1 a b - b)++tests :: [Test]+tests =+ [ testGroup "lerp"+ [ testProperty "lerp 0 a b == a" prop_lerp0+ , testProperty "lerp 1 a b == b" prop_lerp1+ ]+ ]
+ tests/Prop/V3.hs view
@@ -0,0 +1,8 @@+{-# OPTIONS_GHC -Wno-orphans #-}+module Prop.V3 () where++import Linear.V3 (V3(..))+import Test.QuickCheck (Arbitrary(..))++instance Arbitrary a => Arbitrary (V3 a) where+ arbitrary = V3 <$> arbitrary <*> arbitrary <*> arbitrary
+ tests/Test.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE CPP #-}+module Main (main) where++import Test.Framework (defaultMain, testGroup, Test)+import Test.Framework.Providers.HUnit++import qualified Prop.Quaternion+import qualified Unit.Binary+import qualified Unit.Plucker+import qualified Unit.V++tests :: [Test]+tests =+ [ testGroup "Property tests"+ [ testGroup "Quaternion" Prop.Quaternion.tests+ ]+ , testGroup "Unit tests"+ [ testGroup "Binary" $ hUnitTestToTests Unit.Binary.tests+ , testGroup "Plucker" $ hUnitTestToTests Unit.Plucker.tests+ , testGroup "V" $ hUnitTestToTests Unit.V.tests+ ]+ ]++main :: IO ()+main = defaultMain tests
+ tests/Unit/Binary.hs view
@@ -0,0 +1,19 @@+module Unit.Binary (tests) where++import Data.Binary.Put+import Data.Binary.Get+import Linear+import qualified Data.ByteString.Lazy as BS+import Test.HUnit++originalVecs :: (V3 Float, V2 Char)+originalVecs = (V3 1 2 3, V2 'a' 'b')++bytes :: BS.ByteString+bytes = runPut $ do putLinear $ fst originalVecs+ putLinear $ snd originalVecs++tests :: Test+tests = test [ "Serialized length" ~: BS.length bytes ~?= 3*13+2+ , "Deserialization" ~: deserialized ~?= originalVecs ]+ where deserialized = runGet ((,) <$> getLinear <*> getLinear) bytes
+ tests/Unit/Plucker.hs view
@@ -0,0 +1,35 @@+module Unit.Plucker (tests) where+import Linear+import Linear.Plucker+import Linear.Plucker.Coincides+import Test.HUnit++ln2,ln3,ln4,ln5,ln6,ln7,ln8,ln9 :: Plucker Float+ln2 = plucker3D (V3 1 3 0) (V3 1 3 (-2)) -- starting line+ln3 = plucker3D (V3 2 3 0) (V3 2 3 (-2)) -- parallel+ln4 = plucker3D (V3 2 4 0) (V3 1 4 (-2)) -- ccw+ln5 = plucker3D (V3 (-2) 4 0) (V3 2 4 (-2)) -- cw+ln6 = plucker3D (V3 2 3 0) (V3 1 3 (-2)) -- intersect+ln7 = plucker3D (V3 1 3 0) (V3 1 3 2) -- reversed+ln8 = plucker3D (V3 0 4 4) (V3 0 (-4) (-4)) -- through origin+ln9 = Plucker 1 2 3 4 5 6 -- not a 3D line++tests :: Test+tests = test [ "parallel" ~: parallel ln2 ln3 ~?= True+ , "CCW" ~: passes ln2 ln4 ~?= Counterclockwise+ , "CW" ~: passes ln2 ln5 ~?= Clockwise+ , "intersect1" ~: intersects ln2 ln6 ~?= True+ , "intersect2" ~: intersects ln2 ln3 ~?= False+ , "line equality 1" ~: Line ln2 == Line ln2 ~?= True+ , "line equality 2" ~: Line ln2 == Line ln7 ~?= True+ , "line equality 3" ~: Line ln2 == Ray ln7 ~?= True+ , "line equality 4" ~: Ray ln2 == Line ln7 ~?= True+ , "ray equality 1" ~: Ray ln2 == Ray ln7 ~?= False+ , "ray equality 2" ~: Ray ln2 == Ray (3 *^ ln2) ~?= True+ , "ray equality 3" ~: Ray ln2 == Ray (negate ln7) ~?= True+ , "quadrance" ~: nearZero (quadranceToOrigin ln2 - 10) ~?= True+ , "closest 1" ~:+ nearZero (qd (V3 1 3 0) $ closestToOrigin ln2) ~?= True+ , "closest 2" ~: nearZero (qd 0 $ closestToOrigin ln8) ~?= True+ , "isLine 1" ~: isLine ln2 ~?= True+ , "isLine 2" ~: isLine ln9 ~?= False ]
+ tests/Unit/V.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE DataKinds #-}+module Unit.V (tests) where++import Control.DeepSeq (rnf)+import qualified Data.Vector.Unboxed as U (fromList)+import Linear.V (V)+import Test.HUnit++v10 :: V 10 Int+v10 = return 5++tests :: Test+tests = test [ "GH124" ~: rnf (U.fromList [v10]) ~?= () ]
− tests/UnitTests.hs
@@ -1,16 +0,0 @@-{-# LANGUAGE CPP #-} -module Main (main) where -import Test.Framework (defaultMain, testGroup, Test) -import Test.Framework.Providers.HUnit -import qualified Plucker -import qualified Binary -import qualified V - -tests :: [Test] -tests = [ testGroup "Plucker" $ hUnitTestToTests Plucker.tests - , testGroup "Binary" $ hUnitTestToTests Binary.tests - , testGroup "V" $ hUnitTestToTests V.tests - ] - -main :: IO () -main = defaultMain tests
− tests/V.hs
@@ -1,13 +0,0 @@-{-# LANGUAGE DataKinds #-} -module V (tests) where - -import Control.DeepSeq (rnf) -import qualified Data.Vector.Unboxed as U (fromList) -import Linear.V (V) -import Test.HUnit - -v10 :: V 10 Int -v10 = return 5 - -tests :: Test -tests = test [ "GH124" ~: rnf (U.fromList [v10]) ~?= () ]
tests/doctests.hs view
@@ -1,19 +1,19 @@------------------------------------------------------------------------------ --- | --- Module : Main (doctests) --- Copyright : (C) 2012-14 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : provisional --- Portability : portable --- --- This module exists to add dependencies ------------------------------------------------------------------------------ -module Main where - -main :: IO () -main = do - putStrLn "This test-suite exists only to add dependencies" - putStrLn "To run doctests: " - putStrLn " cabal build all --enable-tests" - putStrLn " cabal-docspec" +-----------------------------------------------------------------------------+-- |+-- Module : Main (doctests)+-- Copyright : (C) 2012-14 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- This module exists to add dependencies+-----------------------------------------------------------------------------+module Main where++main :: IO ()+main = do+ putStrLn "This test-suite exists only to add dependencies"+ putStrLn "To run doctests: "+ putStrLn " cabal build all --enable-tests"+ putStrLn " cabal-docspec"