linear-1.22/0000755000000000000000000000000007346545000011101 5ustar0000000000000000linear-1.22/.gitignore0000644000000000000000000000047007346545000013072 0ustar0000000000000000dist 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.* linear-1.22/.hlint.yaml0000644000000000000000000000045607346545000013166 0ustar0000000000000000- 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]} linear-1.22/.vim.custom0000644000000000000000000000107007346545000013204 0ustar0000000000000000" 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 :exec ":!hasktags -x -c --ignore src" au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace() au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src" linear-1.22/CHANGELOG.markdown0000644000000000000000000002404007346545000014134 0ustar00000000000000001.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 linear-1.22/LICENSE0000644000000000000000000000271607346545000012114 0ustar0000000000000000Copyright 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. linear-1.22/README.markdown0000644000000000000000000000106207346545000013601 0ustar0000000000000000linear ====== [![Hackage](https://img.shields.io/hackage/v/linear.svg)](https://hackage.haskell.org/package/linear) [![Build Status](https://github.com/ekmett/linear/workflows/Haskell-CI/badge.svg)](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-1.22/Setup.lhs0000644000000000000000000000017407346545000012713 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain linear-1.22/linear.cabal0000644000000000000000000001002507346545000013335 0ustar0000000000000000name: linear category: Math, Algebra version: 1.22 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett 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 linear-1.22/src/0000755000000000000000000000000007346545000011670 5ustar0000000000000000linear-1.22/src/Linear.hs0000644000000000000000000000243007346545000013435 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Copyright : (C) 2012-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- 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 linear-1.22/src/Linear/0000755000000000000000000000000007346545000013102 5ustar0000000000000000linear-1.22/src/Linear/Affine.hs0000644000000000000000000002255407346545000014636 0ustar0000000000000000{-# 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 -- 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 linear-1.22/src/Linear/Algebra.hs0000644000000000000000000001020407346545000014770 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- 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) linear-1.22/src/Linear/Binary.hs0000644000000000000000000000152407346545000014664 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Copyright : (C) 2013-2015 Edward Kmett and Anthony Cowley -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- 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 linear-1.22/src/Linear/Conjugate.hs0000644000000000000000000000443107346545000015357 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2012-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- 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 linear-1.22/src/Linear/Covector.hs0000644000000000000000000000474207346545000015231 0ustar0000000000000000{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- 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 linear-1.22/src/Linear/Epsilon.hs0000644000000000000000000000254107346545000015051 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Copyright : (C) 2012-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- 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 linear-1.22/src/Linear/Instances.hs0000644000000000000000000000103207346545000015361 0ustar0000000000000000{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2012-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- Re-exports orphan instances for @Complex@ from the @base-orphans@ package. ----------------------------------------------------------------------------- module Linear.Instances () where import Data.Orphans () linear-1.22/src/Linear/Matrix.hs0000644000000000000000000005617207346545000014715 0ustar0000000000000000{-# 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 -- 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 linear-1.22/src/Linear/Metric.hs0000644000000000000000000000657507346545000014676 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2012-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- 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 linear-1.22/src/Linear/Plucker.hs0000644000000000000000000005755407346545000015063 0ustar0000000000000000{-# 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 -- 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 linear-1.22/src/Linear/Plucker/0000755000000000000000000000000007346545000014507 5ustar0000000000000000linear-1.22/src/Linear/Plucker/Coincides.hs0000644000000000000000000000302007346545000016736 0ustar0000000000000000{-# LANGUAGE GADTs #-} --------------------------------------------------------------------------------- -- | -- Copyright : (C) 2012-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- 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 linear-1.22/src/Linear/Projection.hs0000644000000000000000000001435107346545000015556 0ustar0000000000000000{-# LANGUAGE CPP #-} --------------------------------------------------------------------------- -- | -- Copyright : (C) 2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- 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) linear-1.22/src/Linear/Quaternion.hs0000644000000000000000000006073407346545000015575 0ustar0000000000000000{-# 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 -- 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') linear-1.22/src/Linear/Trace.hs0000644000000000000000000000651207346545000014500 0ustar0000000000000000{-# 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 -- 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 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) linear-1.22/src/Linear/V.hs0000644000000000000000000004606507346545000013656 0ustar0000000000000000{-# 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 -- 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 linear-1.22/src/Linear/V0.hs0000644000000000000000000002120507346545000013723 0ustar0000000000000000{-# 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 -- 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 linear-1.22/src/Linear/V1.hs0000644000000000000000000002512307346545000013727 0ustar0000000000000000{-# 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 -- 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 linear-1.22/src/Linear/V2.hs0000644000000000000000000003217007346545000013730 0ustar0000000000000000{-# 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 -- 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 linear-1.22/src/Linear/V3.hs0000644000000000000000000003534107346545000013734 0ustar0000000000000000{-# 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 -- 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 linear-1.22/src/Linear/V4.hs0000644000000000000000000005165507346545000013743 0ustar0000000000000000{-# 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 -- 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 linear-1.22/src/Linear/Vector.hs0000644000000000000000000002373207346545000014707 0ustar0000000000000000{-# 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 -- 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 linear-1.22/tests/0000755000000000000000000000000007346545000012243 5ustar0000000000000000linear-1.22/tests/Binary.hs0000644000000000000000000000111107346545000014015 0ustar0000000000000000module 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 linear-1.22/tests/Plucker.hs0000644000000000000000000000337207346545000014211 0ustar0000000000000000module 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 ] linear-1.22/tests/UnitTests.hs0000644000000000000000000000071707346545000014546 0ustar0000000000000000{-# 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 linear-1.22/tests/V.hs0000644000000000000000000000044107346545000013003 0ustar0000000000000000{-# 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]) ~?= () ] linear-1.22/tests/doctests.hs0000644000000000000000000000125207346545000014427 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Main (doctests) -- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- 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"