linear-1.20.5/0000755000000000000000000000000012722610624011241 5ustar0000000000000000linear-1.20.5/.gitignore0000644000000000000000000000010412722610624013224 0ustar0000000000000000dist docs wiki TAGS tags wip .DS_Store .*.swp .*.swo *.o *.hi *~ *# linear-1.20.5/.travis.yml0000644000000000000000000000213412722610624013352 0ustar0000000000000000env: - GHCVER=7.4.2 CABALVER=1.18 - GHCVER=7.6.3 CABALVER=1.18 - GHCVER=7.8.4 CABALVER=1.18 - GHCVER=7.10.1 CABALVER=1.22 - GHCVER=8.0.1 CABALVER=1.24 - GHCVER=head CABALVER=1.22 matrix: allow_failures: - env: GHCVER=head CABALVER=1.24 before_install: - travis_retry sudo add-apt-repository -y ppa:hvr/ghc - travis_retry sudo apt-get update - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH - cabal --version install: - travis_retry cabal update - cabal install --enable-tests --only-dependencies script: - cabal configure -v2 --enable-tests - cabal build - cabal sdist - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ; cd dist/; if [ -f "$SRC_TGZ" ]; then cabal install "$SRC_TGZ"; else echo "expected '$SRC_TGZ' not found"; exit 1; fi notifications: irc: channels: - "irc.freenode.org#haskell-lens" skip_join: true template: - "\x0313linear\x0f/\x0306%{branch}\x0f \x0314%{commit}\x0f %{message} \x0302\x1f%{build_url}\x0f" linear-1.20.5/.vim.custom0000644000000000000000000000104312722610624013344 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.20.5/CHANGELOG.markdown0000644000000000000000000001351712722610624014303 0ustar00000000000000001.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.20.5/LICENSE0000644000000000000000000000266012722610624012252 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.20.5/linear.cabal0000644000000000000000000000712012722610624013477 0ustar0000000000000000name: linear category: Math, Algebra version: 1.20.5 license: BSD3 cabal-version: >= 1.8 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: Custom tested-with: GHC == 7.4.2, GHC == 7.6.1, GHC == 7.8.4, GHC == 7.10.1, GHC==8.0.1 extra-source-files: .gitignore .travis.yml .vim.custom travis/cabal-apt-install travis/config 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: git://github.com/ekmett/linear.git library build-depends: adjunctions >= 4 && < 5, base >= 4.5 && < 5, base-orphans >= 0.5 && < 1, binary >= 0.5 && < 0.9, bytes >= 0.15 && < 1, cereal >= 0.4.1.1 && < 0.6, containers >= 0.4 && < 0.6, deepseq >= 1.1 && < 1.5, distributive >= 0.2.2 && < 1, ghc-prim, hashable >= 1.1 && < 1.3, lens >= 4 && < 5, reflection >= 1.3.2 && < 3, semigroups >= 0.9 && < 1, semigroupoids >= 3 && < 6, tagged >= 0.4.4 && < 1, transformers >= 0.2 && < 0.6, transformers-compat >= 0.4 && < 1, unordered-containers >= 0.2.3 && < 0.3, vector >= 0.10 && < 0.12, void >= 0.6 && < 1 if flag(template-haskell) && impl(ghc) build-depends: template-haskell >= 2.7 && < 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 -fwarn-tabs -O2 -fdicts-cheap -funbox-strict-fields hs-source-dirs: src -- hack around the buggy unused matches check for class associated types in ghc 8 rc1 if impl(ghc >= 8) ghc-options: -fno-warn-unused-matches -- Verify the results of the examples test-suite doctests type: exitcode-stdio-1.0 main-is: doctests.hs ghc-options: -Wall -threaded hs-source-dirs: tests build-depends: base, directory >= 1.0 && < 1.3, doctest >= 0.8 && < 0.12, filepath >= 1.3 && < 1.5, lens, simple-reflect >= 0.3.1 test-suite UnitTests type: exitcode-stdio-1.0 main-is: UnitTests.hs other-modules: Plucker, Binary ghc-options: -Wall -threaded hs-source-dirs: tests build-depends: base, binary, bytestring, test-framework >= 0.8, test-framework-hunit >= 0.3, HUnit >= 1.2.5, linear linear-1.20.5/README.markdown0000644000000000000000000000044312722610624013743 0ustar0000000000000000linear ====== 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.20.5/Setup.lhs0000644000000000000000000000401212722610624013046 0ustar0000000000000000#!/usr/bin/runhaskell \begin{code} {-# OPTIONS_GHC -Wall #-} module Main (main) where import Data.List ( nub ) import Data.Version ( showVersion ) import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName ) import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose ) import Distribution.Simple.BuildPaths ( autogenModulesDir ) import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag ) import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) import Distribution.Verbosity ( Verbosity ) import System.FilePath ( () ) main :: IO () main = defaultMainWithHooks simpleUserHooks { buildHook = \pkg lbi hooks flags -> do generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi buildHook simpleUserHooks pkg lbi hooks flags } generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () generateBuildModule verbosity pkg lbi = do let dir = autogenModulesDir lbi createDirectoryIfMissingVerbose verbosity True dir withLibLBI pkg lbi $ \_ libcfg -> do withTestLBI pkg lbi $ \suite suitecfg -> do rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines [ "module Build_" ++ testName suite ++ " where" , "" , "autogen_dir :: String" , "autogen_dir = " ++ show dir , "" , "deps :: [String]" , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) ] where formatdeps = map (formatone . snd) formatone p = case packageName p of PackageName n -> n ++ "-" ++ showVersion (packageVersion p) testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys \end{code} linear-1.20.5/src/0000755000000000000000000000000012722610624012030 5ustar0000000000000000linear-1.20.5/src/Linear.hs0000644000000000000000000000244712722610624013605 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 {-# ANN module "Hlint: ignore Use import/export shortcut" #-} linear-1.20.5/src/Linear/0000755000000000000000000000000012722610624013242 5ustar0000000000000000linear-1.20.5/src/Linear/Affine.hs0000644000000000000000000002056412722610624014775 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} {-# LANGUAGE DeriveGeneric #-} #endif {-# LANGUAGE DeriveDataTypeable #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 708 {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} #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.Complex (Complex) import Data.Data import Data.Distributive import Data.Foldable as Foldable import Data.Functor.Bind import Data.Functor.Classes import Data.Functor.Rep as Rep import Data.HashMap.Lazy (HashMap) import Data.Hashable import Data.IntMap (IntMap) import Data.Ix import Data.Map (Map) import Data.Serialize as Cereal import Data.Vector (Vector) import Foreign.Storable #if __GLASGOW_HASKELL__ >= 702 import GHC.Generics (Generic) #endif #if __GLASGOW_HASKELL__ >= 706 import GHC.Generics (Generic1) #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.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 #ifdef HLINT {-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-} #endif -- | 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 :: * -> * 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 (.-^) #-} -- | 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 , Hashable #if __GLASGOW_HASKELL__ >= 702 , Generic #endif #if __GLASGOW_HASKELL__ >= 706 , Generic1 #endif #if __GLASGOW_HASKELL__ >= 708 , Typeable, Data #endif ) 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 #if __GLASGOW_HASKELL__ < 708 instance forall f. Typeable1 f => Typeable1 (Point f) where typeOf1 _ = mkTyConApp (mkTyCon3 "linear" "Linear.Affine" "Point") [] `mkAppTy` typeOf1 (undefined :: f a) deriving instance (Data (f a), Typeable1 f, Typeable a) => Data (Point f a) #endif lensP :: Lens' (Point g a) (g a) lensP afb (P a) = P <$> afb a {-# INLINE lensP #-} _Point :: Iso' (Point f a) (f a) _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' #-} instance Bind f => Bind (Point f) where join (P m) = P $ join $ fmap (\(P m')->m') m instance Distributive f => Distributive (Point f) where distribute = P . collect (\(P p) -> p) instance Representable f => Representable (Point f) where type Rep (Point f) = Rep f tabulate f = P (tabulate f) {-# INLINE tabulate #-} index (P xs) = Rep.index xs {-# 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 P x .-. P y = x ^-^ y {-# INLINE (.-.) #-} P x .+^ v = P (x ^+^ v) {-# INLINE (.+^) #-} P x .-^ v = P (x ^-^ v) {-# 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 #-} data instance U.Vector (Point f a) = V_P !(U.Vector (f a)) data 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 #if MIN_VERSION_vector(0,11,0) basicInitialize (MV_P v) = M.basicInitialize v {-# INLINE basicInitialize #-} #endif 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.20.5/src/Linear/Algebra.hs0000644000000000000000000001022312722610624015131 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} #if __GLASGOW_HASKELL__ >= 800 {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -- they are mathematically required, not redundant, damn it. #endif ----------------------------------------------------------------------------- -- | -- 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.20.5/src/Linear/Binary.hs0000644000000000000000000000202512722610624015021 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- 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 #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Data.Binary #if __GLASGOW_HASKELL__ < 710 import Data.Foldable (Foldable, traverse_) import Data.Traversable (Traversable, sequenceA) #else import Data.Foldable (traverse_) #endif -- | 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.20.5/src/Linear/Conjugate.hs0000644000000000000000000000434712722610624015525 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} #if __GLASGOW_HASKELL__ >= 800 {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} #endif ----------------------------------------------------------------------------- -- | -- 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) -- | 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.20.5/src/Linear/Covector.hs0000644000000000000000000000455512722610624015373 0ustar0000000000000000{-# LANGUAGE 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 return a = Covector $ \k -> k a 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.20.5/src/Linear/Epsilon.hs0000644000000000000000000000224312722610624015210 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 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 linear-1.20.5/src/Linear/Instances.hs0000644000000000000000000000327512722610624015534 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2012-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- Orphans ----------------------------------------------------------------------------- module Linear.Instances () where import Control.Applicative import Control.Monad.Fix import Control.Monad.Zip import Data.Complex import Data.Functor.Bind import Data.HashMap.Lazy as HashMap import Data.Hashable import Data.Orphans () import Data.Semigroup import Data.Semigroup.Foldable import Data.Semigroup.Traversable instance (Hashable k, Eq k) => Apply (HashMap k) where (<.>) = HashMap.intersectionWith id instance (Hashable k, Eq k) => Bind (HashMap k) where -- this is needlessly painful m >>- f = HashMap.fromList $ do (k, a) <- HashMap.toList m case HashMap.lookup k (f a) of Just b -> [(k,b)] Nothing -> [] instance Apply Complex where (a :+ b) <.> (c :+ d) = a c :+ b d instance Bind Complex where (a :+ b) >>- f = a' :+ b' where a' :+ _ = f a _ :+ b' = f b {-# INLINE (>>-) #-} instance MonadZip Complex where mzipWith = liftA2 instance MonadFix Complex where mfix f = (let a :+ _ = f a in a) :+ (let _ :+ a = f a in a) instance Foldable1 Complex where foldMap1 f (a :+ b) = f a <> f b {-# INLINE foldMap1 #-} instance Traversable1 Complex where traverse1 f (a :+ b) = (:+) <$> f a <.> f b {-# INLINE traverse1 #-} linear-1.20.5/src/Linear/Matrix.hs0000644000000000000000000003236712722610624015055 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif --------------------------------------------------------------------------- -- | -- 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 ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Lens hiding (index) import Control.Lens.Internal.Context import Data.Distributive import Data.Foldable as Foldable import Data.Functor.Rep import Linear.Quaternion import Linear.V2 import Linear.V3 import Linear.V4 import Linear.Vector import Linear.Conjugate import Linear.Trace #ifdef HLINT {-# ANN module "HLint: ignore Reduce duplication" #-} #endif -- | 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)) -- $setup -- >>> import Data.Complex -- >>> import Data.IntMap -- >>> import Debug.SimpleReflect.Vars -- >>> import Linear.V 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 (fromList [(1,2)]) (fromList [(2,3)]) !*! 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 2x3 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) {-# ANN m43_to_m44 "HLint: ignore Use camelCase" #-} -- | 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) {-# ANN m33_to_m44 "HLint: ignore Use camelCase" #-} -- |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 #-} linear-1.20.5/src/Linear/Metric.hs0000644000000000000000000000541612722610624015027 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- 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.Identity 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 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.20.5/src/Linear/Plucker.hs0000644000000000000000000005062312722610624015211 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GADTs #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} {-# LANGUAGE DeriveGeneric #-} #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 -- -- 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 hiding (index, (<.>)) import Data.Binary as Binary import Data.Bytes.Serial import Data.Distributive import Data.Foldable as Foldable import Data.Functor.Bind import Data.Functor.Classes import Data.Functor.Rep import Data.Hashable import Data.Semigroup import Data.Semigroup.Foldable import Data.Serialize as Cereal import Foreign.Ptr (castPtr) import Foreign.Storable (Storable(..)) import GHC.Arr (Ix(..)) #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 import GHC.Generics (Generic) #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 import GHC.Generics (Generic1) #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.Epsilon import Linear.Metric import Linear.V2 import Linear.V3 import Linear.V4 import Linear.Vector {-# ANN module "HLint: ignore Reduce duplication" #-} -- | 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 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 ,Generic #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 ,Generic1 #endif ) 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 return a = Plucker a a a a a a {-# INLINE return #-} 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 #-} 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 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 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 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 #-} type instance Index (Plucker a) = E Plucker type instance IxValue (Plucker a) = a instance Ixed (Plucker a) where ix = el {-# 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 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 ,Generic #endif ) -- | 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 . getOption . fold $ saveDiv <$> p1 <*> p2 saveDiv x y | nearZero y = Option Nothing | otherwise = Option . 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 . getOption . fold $ saveDiv <$> p1 <*> p2 saveDiv x y | nearZero y = Option Nothing | otherwise = Option . Just $ First (x / y) {-# INLINABLE coincides' #-} -- | 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 #if MIN_VERSION_vector(0,11,0) basicInitialize (MV_Plucker _ v) = M.basicInitialize v #endif 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 #if (MIN_VERSION_transformers(0,5,0)) || !(MIN_VERSION_transformers(0,4,0)) 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 #else instance Eq1 Plucker where eq1 = (==) instance Ord1 Plucker where compare1 = compare instance Show1 Plucker where showsPrec1 = showsPrec instance Read1 Plucker where readsPrec1 = readsPrec #endif linear-1.20.5/src/Linear/Projection.hs0000644000000000000000000001373112722610624015717 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 #ifdef HLINT {-# ANN module "HLint: ignore Reduce duplication" #-} #endif -- | 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.20.5/src/Linear/Quaternion.hs0000644000000000000000000005260212722610624015730 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} {-# LANGUAGE DeriveGeneric #-} #endif #ifndef MIN_VERSION_vector #define MIN_VERSION_vector(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 hiding ((<.>)) import Data.Binary as Binary import Data.Bytes.Serial import Data.Complex (Complex((:+))) import Data.Data import Data.Distributive import Data.Foldable import Data.Functor.Bind import Data.Functor.Classes import Data.Functor.Rep import Data.Hashable import Data.Serialize as Cereal import GHC.Arr (Ix(..)) import qualified Data.Foldable as F import Data.Monoid import Foreign.Ptr (castPtr, plusPtr) import Foreign.Storable (Storable(..)) #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 import GHC.Generics (Generic) #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 import GHC.Generics (Generic1) #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.Epsilon import Linear.Conjugate import Linear.Metric import Linear.V3 import Linear.Vector import Prelude hiding (any) {-# ANN module "HLint: ignore Reduce duplication" #-} -- | Quaternions data Quaternion a = Quaternion !a {-# UNPACK #-}!(V3 a) deriving (Eq,Ord,Read,Show,Data,Typeable #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 ,Generic #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 ,Generic1 #endif ) 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 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 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 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 #-} type instance Index (Quaternion a) = E Quaternion type instance IxValue (Quaternion a) = a instance Ixed (Quaternion a) where ix = el {-# 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 #-} 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 #-} 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 = q ^/ 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@(V3 _i j k)) | qiq == 0 = if e >= 0 then Quaternion (log e) v else Quaternion (log (negate e)) (V3 pi j k) -- mmm, pi | ai <- sqrt qiq = reimagine (log m) (atan2 m e / 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 -- reimagine (cos e * cosh ai) (- sin e * sinh ai / ai) q -- 13.5 bits worse 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 #if MIN_VERSION_vector(0,11,0) basicInitialize (MV_Quaternion _ v) = M.basicInitialize v #endif 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 #if (MIN_VERSION_transformers(0,5,0)) || !(MIN_VERSION_transformers(0,4,0)) 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 #else instance Eq1 Quaternion where eq1 = (==) instance Ord1 Quaternion where compare1 = compare instance Show1 Quaternion where showsPrec1 = showsPrec instance Read1 Quaternion where readsPrec1 = readsPrec #endif linear-1.20.5/src/Linear/Trace.hs0000644000000000000000000000606412722610624014642 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DefaultSignatures #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710 {-# LANGUAGE Trustworthy #-} #endif --------------------------------------------------------------------------- -- | -- 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(..) ) 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 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 704 import Data.Complex #endif 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 import Data.Map -- $setup -- >>> import Data.Complex -- >>> import Data.IntMap -- >>> import Debug.SimpleReflect.Vars 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 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 704 instance Trace Complex where trace ((a :+ _) :+ (_ :+ b)) = a + b {-# INLINE trace #-} diagonal ((a :+ _) :+ (_ :+ b)) = a :+ b {-# INLINE diagonal #-} #endif 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 #-} linear-1.20.5/src/Linear/V.hs0000644000000000000000000003765612722610624014024 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances #-} {-# LANGUAGE DeriveDataTypeable #-} #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RoleAnnotations #-} #define USE_TYPE_LITS 1 #endif {-# LANGUAGE Trustworthy #-} {-# LANGUAGE DeriveGeneric #-} #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 ----------------------------------------------------------------------------- -- | -- 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 #if (MIN_VERSION_reflection(2,0,0)) && __GLASGOW_HASKELL__ >= 708 , reifyDimNat , reifyVectorNat #endif , fromVector ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.DeepSeq (NFData) import Control.Monad import Control.Monad.Fix import Control.Monad.Zip import Control.Lens as Lens import Data.Binary as Binary import Data.Bytes.Serial import Data.Data import Data.Distributive import Data.Foldable as Foldable import Data.Functor.Bind import Data.Functor.Classes import Data.Functor.Rep as Rep #if __GLASGOW_HASKELL__ < 708 import Data.Proxy #endif import Data.Reflection as R import Data.Serialize as Cereal #if __GLASGOW_HASKELL__ < 710 import Data.Traversable (sequenceA) #endif import Data.Vector as V 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 #ifdef USE_TYPE_LITS import GHC.TypeLits #endif #if __GLASGOW_HASKELL__ >= 702 import GHC.Generics (Generic) #endif #if __GLASGOW_HASKELL__ >= 707 import GHC.Generics (Generic1) #endif #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 #if (MIN_VERSION_transformers(0,5,0)) || !(MIN_VERSION_transformers(0,4,0)) import Prelude as P #if __GLASGOW_HASKELL__ < 710 import Data.Monoid #endif #endif #ifdef HLINT {-# ANN module "hlint: ignore Eta reduce" #-} #endif class Dim n where reflectDim :: p n -> Int #if __GLASGOW_HASKELL__ >= 707 type role V nominal representational #endif newtype V n a = V { toVector :: V.Vector a } deriving (Eq,Ord,Show,Read,Typeable,NFData , Generic -- GHC bug: https://ghc.haskell.org/trac/ghc/ticket/8468 #if __GLASGOW_HASKELL__ >= 707 ,Generic1 #endif ) dim :: forall n a. Dim n => V n a -> Int dim _ = reflectDim (Proxy :: Proxy n) {-# INLINE dim #-} #ifdef USE_TYPE_LITS instance KnownNat n => Dim (n :: Nat) where reflectDim = fromInteger . natVal {-# INLINE reflectDim #-} #endif data ReifiedDim (s :: *) 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 #-} #if (MIN_VERSION_reflection(2,0,0)) && __GLASGOW_HASKELL__ >= 708 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 #-} #endif reifyDim :: Int -> (forall (n :: *). Dim n => Proxy n -> r) -> r reifyDim i f = R.reify i (go f) where go :: Reifies n Int => (Proxy (ReifiedDim n) -> a) -> proxy n -> a go g _ = g Proxy {-# INLINE reifyDim #-} reifyVector :: forall a r. Vector a -> (forall (n :: *). 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 Functor (V n) where fmap f (V as) = V (fmap f as) {-# INLINE fmap #-} instance 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) = 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 #-} #if __GLASGOW_HASKELL__ >= 706 foldr' f z (V as) = V.foldr' f z as {-# INLINE foldr' #-} foldl' f z (V as) = V.foldl' f z as {-# INLINE foldl' #-} #endif foldr1 f (V as) = V.foldr1 f as {-# INLINE foldr1 #-} foldl1 f (V as) = V.foldl1 f as {-# INLINE foldl1 #-} #if __GLASGOW_HASKELL__ >= 710 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 #-} #endif instance 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 TraversableWithIndex Int (V n) where itraverse f (V as) = V <$> itraverse f as {-# INLINE itraverse #-} 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 $ generate (V.length as) $ \i -> toVector (f (as `unsafeIndex` i)) `unsafeIndex` i {-# INLINE (>>-) #-} instance Dim n => Monad (V n) where return = V . V.replicate (reflectDim (Proxy :: Proxy n)) {-# INLINE return #-} V as >>= f = V $ generate (reflectDim (Proxy :: Proxy n)) $ \i -> toVector (f (as `unsafeIndex` i)) `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) -> unsafeIndex v i) f {-# INLINE distribute #-} 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 (unsafeIndex xs i) where ptr' = castPtr ptr {-# INLINE poke #-} peek ptr = 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 . 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 as) | i < 0 || i >= V.length as = pure $ V as | otherwise = f (as ! i) <&> \a -> V $ as V.// [(i, a)] {-# 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 #-} #if __GLASGOW_HASKELL__ >= 708 #define Typeable1 Typeable #endif instance (Typeable1 (V n), Typeable (V n a), Dim n, Data a) => Data (V n a) where gfoldl f z (V as) = z (V . fromList) `f` V.toList as toConstr _ = vConstr gunfold k z c = case constrIndex c of 1 -> k (z (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 #if (MIN_VERSION_transformers(0,5,0)) || !(MIN_VERSION_transformers(0,4,0)) 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) ] #else instance Dim n => Eq1 (V n) where eq1 = (==) instance Dim n => Ord1 (V n) where compare1 = compare instance Dim n => Show1 (V n) where showsPrec1 = showsPrec instance Dim n => Read1 (V n) where readsPrec1 = readsPrec #endif 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) i0 (V vn0) = let d0 = V.length vn0 in go v0 vn0 d0 (d0*i0) i0 where go v vn d o i | i >= d = return () | otherwise = do a <- G.basicUnsafeIndexM vn i M.basicUnsafeWrite v o a go v vn d (o+1) (i-1) #if MIN_VERSION_vector(0,11,0) basicInitialize (MV_VN _ v) = M.basicInitialize v {-# INLINE basicInitialize #-} #endif 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) linear-1.20.5/src/Linear/V0.hs0000644000000000000000000001701612722610624014070 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE Trustworthy #-} #endif #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 -- -- 0-D Vectors ---------------------------------------------------------------------------- module Linear.V0 ( V0(..) ) where import Control.Applicative import Control.DeepSeq (NFData(rnf)) import Control.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 Data.Functor.Bind import Data.Functor.Classes import Data.Functor.Rep import Data.Hashable import Data.Ix import Data.Semigroup import Data.Serialize -- cereal import Foreign.Storable (Storable(..)) #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 import GHC.Generics (Generic) #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 import GHC.Generics (Generic1) #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 Prelude hiding (sum) -- $setup -- >>> import Control.Lens -- | A 0-dimensional vector -- -- >>> pure 1 :: V0 Int -- V0 -- -- >>> V0 + V0 -- V0 -- data V0 a = V0 deriving (Eq,Ord,Show,Read,Ix,Enum,Data,Typeable #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 ,Generic #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 ,Generic1 #endif ) 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 #-} 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 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 return _ = V0 {-# INLINE return #-} 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 #if (MIN_VERSION_hashable(1,2,1)) || !(MIN_VERSION_hashable(1,2,0)) hash V0 = 0 {-# INLINE hash #-} #endif hashWithSalt s V0 = s {-# INLINE hashWithSalt #-} 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 FunctorWithIndex (E V0) V0 where imap _ V0 = V0 {-# INLINE imap #-} instance FoldableWithIndex (E V0) V0 where ifoldMap _ V0 = mempty {-# INLINE ifoldMap #-} instance TraversableWithIndex (E V0) V0 where itraverse _ V0 = pure V0 {-# INLINE itraverse #-} 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 = el {-# 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 () #if MIN_VERSION_vector(0,11,0) basicInitialize _ = return () {-# INLINE basicInitialize #-} #endif 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 = () #if (MIN_VERSION_transformers(0,5,0)) || !(MIN_VERSION_transformers(0,4,0)) instance Eq1 V0 where liftEq _ _ _ = True instance Ord1 V0 where liftCompare _ _ _ = EQ instance Show1 V0 where liftShowsPrec _ _ = showsPrec instance Read1 V0 where liftReadsPrec _ _ = readsPrec #else instance Eq1 V0 where eq1 = (==) instance Ord1 V0 where compare1 = compare instance Show1 V0 where showsPrec1 = showsPrec instance Read1 V0 where readsPrec1 = readsPrec #endif linear-1.20.5/src/Linear/V1.hs0000644000000000000000000002226512722610624014073 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ScopedTypeVariables #-} -- {-# OPTIONS_GHC -fno-warn-name-shadowing #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} {-# LANGUAGE DeriveGeneric #-} #endif #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 -- -- 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 import Data.Binary as Binary import Data.Bytes.Serial import Data.Serialize as Cereal import Data.Data import Data.Distributive import Data.Foldable import Data.Functor.Bind import Data.Functor.Classes import Data.Functor.Rep import Data.Hashable import Data.Semigroup.Foldable import Foreign.Storable (Storable) import GHC.Arr (Ix(..)) #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 import GHC.Generics (Generic) #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 import GHC.Generics (Generic1) #endif import Linear.Metric import Linear.Epsilon import Linear.Vector import Prelude hiding (sum) import qualified Data.Vector.Generic.Mutable as M import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed.Base as U #ifdef HLINT -- HLint is delusional {-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-} #endif -- $setup -- >>> import Control.Lens -- | 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,Typeable) newtype V1 a = V1 a deriving (Eq,Ord,Show,Read,Data,Typeable, Functor,Foldable,Traversable, Epsilon,Storable,NFData #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 ,Generic #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 ,Generic1 #endif ) 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 return = V1 {-# INLINE return #-} 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 #if (MIN_VERSION_hashable(1,2,1)) || !(MIN_VERSION_hashable(1,2,0)) hash (V1 a) = hash a #endif hashWithSalt s (V1 a) = s `hashWithSalt` a 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 FunctorWithIndex (E V1) V1 where imap f (V1 a) = V1 (f ex a) {-# INLINE imap #-} instance FoldableWithIndex (E V1) V1 where ifoldMap f (V1 a) = f ex a {-# INLINE ifoldMap #-} instance TraversableWithIndex (E V1) V1 where itraverse f (V1 a) = V1 <$> f ex a {-# INLINE itraverse #-} type instance Index (V1 a) = E V1 type instance IxValue (V1 a) = a instance Ixed (V1 a) where ix = el {-# 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 #if MIN_VERSION_vector(0,11,0) basicInitialize (MV_V1 v) = M.basicInitialize v {-# INLINE basicInitialize #-} #endif 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 #if (MIN_VERSION_transformers(0,5,0)) || !(MIN_VERSION_transformers(0,4,0)) 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 #else instance Eq1 V1 where eq1 = (==) instance Ord1 V1 where compare1 = compare instance Show1 V1 where showsPrec1 = showsPrec instance Read1 V1 where readsPrec1 = readsPrec #endif linear-1.20.5/src/Linear/V2.hs0000644000000000000000000002613312722610624014072 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} -- {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} {-# LANGUAGE DeriveGeneric #-} #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 -- -- 2-D Vectors ---------------------------------------------------------------------------- module Linear.V2 ( V2(..) , R1(..) , R2(..) , _yx , ex, ey , perp , angle , 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 hiding ((<.>)) import Data.Binary as Binary import Data.Bytes.Serial import Data.Data import Data.Distributive import Data.Foldable import Data.Functor.Bind import Data.Functor.Classes import Data.Functor.Rep import Data.Hashable import Data.Semigroup import Data.Semigroup.Foldable import Data.Serialize as Cereal import Foreign.Ptr (castPtr) import Foreign.Storable (Storable(..)) import GHC.Arr (Ix(..)) #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 import GHC.Generics (Generic) #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 import GHC.Generics (Generic1) #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.V1 (R1(..),ex) import Prelude hiding (sum) -- $setup -- >>> import Control.Lens -- | 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,Typeable #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 ,Generic #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 ,Generic1 #endif ) 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 #-} 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 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 return a = V2 a a {-# INLINE return #-} 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 FunctorWithIndex (E V2) V2 where imap f (V2 a b) = V2 (f ex a) (f ey b) {-# INLINE imap #-} instance FoldableWithIndex (E V2) V2 where ifoldMap f (V2 a b) = f ex a `mappend` f ey b {-# INLINE ifoldMap #-} instance TraversableWithIndex (E V2) V2 where itraverse f (V2 a b) = V2 <$> f ex a <*> f ey b {-# INLINE itraverse #-} type instance Index (V2 a) = E V2 type instance IxValue (V2 a) = a instance Ixed (V2 a) where ix = el {-# 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 #if MIN_VERSION_vector(0,11,0) basicInitialize (MV_V2 _ v) = M.basicInitialize v {-# INLINE basicInitialize #-} #endif 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) -- | 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 #if (MIN_VERSION_transformers(0,5,0)) || !(MIN_VERSION_transformers(0,4,0)) 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 #else instance Eq1 V2 where eq1 = (==) instance Ord1 V2 where compare1 = compare instance Show1 V2 where showsPrec1 = showsPrec instance Read1 V2 where readsPrec1 = readsPrec #endif linear-1.20.5/src/Linear/V3.hs0000644000000000000000000003135712722610624014077 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} {-# LANGUAGE DeriveGeneric #-} #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 hiding ((<.>)) import Data.Binary as Binary -- binary import Data.Bytes.Serial -- bytes import Data.Data import Data.Distributive import Data.Foldable import Data.Functor.Bind import Data.Functor.Classes import Data.Functor.Rep import Data.Hashable import Data.Semigroup import Data.Semigroup.Foldable import Data.Serialize as Cereal -- cereal import Foreign.Ptr (castPtr) import Foreign.Storable (Storable(..)) import GHC.Arr (Ix(..)) #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 import GHC.Generics (Generic) #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 import GHC.Generics (Generic1) #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.Epsilon import Linear.Metric import Linear.V2 import Linear.Vector {-# ANN module "HLint: ignore Reduce duplication" #-} -- | A 3-dimensional vector data V3 a = V3 !a !a !a deriving (Eq,Ord,Show,Read,Data,Typeable #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 ,Generic #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 ,Generic1 #endif ) 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 #-} 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 return a = V3 a a a {-# INLINE return #-} 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 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 FunctorWithIndex (E V3) V3 where imap f (V3 a b c) = V3 (f ex a) (f ey b) (f ez c) {-# INLINE imap #-} instance 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 TraversableWithIndex (E V3) V3 where itraverse f (V3 a b c) = V3 <$> f ex a <*> f ey b <*> f ez c {-# INLINE itraverse #-} type instance Index (V3 a) = E V3 type instance IxValue (V3 a) = a instance Ixed (V3 a) where ix = el {-# 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 #if MIN_VERSION_vector(0,11,0) basicInitialize (MV_V3 _ v) = M.basicInitialize v {-# INLINE basicInitialize #-} #endif 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 #if (MIN_VERSION_transformers(0,5,0)) || !(MIN_VERSION_transformers(0,4,0)) 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 #else instance Eq1 V3 where eq1 = (==) instance Ord1 V3 where compare1 = compare instance Show1 V3 where showsPrec1 = showsPrec instance Read1 V3 where readsPrec1 = readsPrec #endif linear-1.20.5/src/Linear/V4.hs0000644000000000000000000004505612722610624014101 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} {-# LANGUAGE DeriveGeneric #-} #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 hiding ((<.>)) import Data.Binary as Binary import Data.Bytes.Serial import Data.Data import Data.Distributive import Data.Foldable import Data.Functor.Bind import Data.Functor.Classes import Data.Functor.Rep import Data.Hashable import Data.Semigroup import Data.Semigroup.Foldable import Data.Serialize as Cereal import Foreign.Ptr (castPtr) import Foreign.Storable (Storable(..)) import GHC.Arr (Ix(..)) #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 import GHC.Generics (Generic) #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 import GHC.Generics (Generic1) #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.Epsilon import Linear.Metric import Linear.V2 import Linear.V3 import Linear.Vector {-# ANN module "HLint: ignore Reduce duplication" #-} -- | A 4-dimensional vector. data V4 a = V4 !a !a !a !a deriving (Eq,Ord,Show,Read,Data,Typeable #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 ,Generic #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 ,Generic1 #endif ) 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 #-} 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 return a = V4 a a a a {-# INLINE return #-} 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 #-} -- | 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 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 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 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 #-} type instance Index (V4 a) = E V4 type instance IxValue (V4 a) = a instance Ixed (V4 a) where ix = el 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 #if MIN_VERSION_vector(0,11,0) basicInitialize (MV_V4 _ v) = M.basicInitialize v #endif 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 #if (MIN_VERSION_transformers(0,5,0)) || !(MIN_VERSION_transformers(0,4,0)) 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 #else instance Eq1 V4 where eq1 = (==) instance Ord1 V4 where compare1 = compare instance Show1 V4 where showsPrec1 = showsPrec instance Read1 V4 where readsPrec1 = readsPrec #endif linear-1.20.5/src/Linear/Vector.hs0000644000000000000000000002430212722610624015041 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} {-# LANGUAGE DefaultSignatures #-} #define USE_GHC_GENERICS #endif ----------------------------------------------------------------------------- -- | -- 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 #if __GLASGOW_HASKELL__ < 710 import Data.Foldable as Foldable (Foldable, forM_, foldl') #else import Data.Foldable as Foldable (forM_, foldl') #endif import Data.HashMap.Lazy as HashMap import Data.Hashable import Data.IntMap as IntMap import Data.Map as Map #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mempty) #endif import Data.Vector as Vector import Data.Vector.Mutable as Mutable #ifdef USE_GHC_GENERICS import GHC.Generics #endif import Linear.Instances () {-# ANN module "HLint: ignore Redundant lambda" #-} -- $setup -- >>> import Linear.V2 -- | Basis element newtype E t = E { el :: forall x. Lens' (t x) x } infixl 6 ^+^, ^-^ infixl 7 ^*, *^, ^/ #ifdef USE_GHC_GENERICS 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 (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 #-} #endif -- | A vector is an additive group with additional structure. class Functor f => Additive f where -- | The zero vector zero :: Num a => f a #ifdef USE_GHC_GENERICS #ifndef HLINT default zero :: (GAdditive (Rep1 f), Generic1 f, Num a) => f a zero = to1 gzero #endif #endif -- | Compute the sum of two vectors -- -- >>> V2 1 2 ^+^ V2 3 4 -- V2 4 6 (^+^) :: Num a => f a -> f a -> f a #ifdef USE_GHC_GENERICS #ifndef HLINT default (^+^) :: Num a => f a -> f a -> f a (^+^) = liftU2 (+) {-# INLINE (^+^) #-} #endif #endif -- | Compute the difference between two vectors -- -- >>> V2 4 5 ^-^ V2 3 1 -- V2 1 4 (^-^) :: Num a => f a -> f a -> f a #ifdef USE_GHC_GENERICS #ifndef HLINT default (^-^) :: Num a => f a -> f a -> f a x ^-^ y = x ^+^ negated y {-# INLINE (^-^) #-} #endif #endif -- | 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 #ifdef USE_GHC_GENERICS #ifndef HLINT default liftU2 :: Applicative f => (a -> a -> a) -> f a -> f a -> f a liftU2 = liftA2 {-# INLINE liftU2 #-} #endif #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 #ifdef USE_GHC_GENERICS #ifndef HLINT default liftI2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c liftI2 = liftA2 {-# INLINE liftI2 #-} #endif #endif 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 #-} #ifndef USE_GHC_GENERICS (^+^) = liftU2 (+) {-# INLINE (^+^) #-} x ^-^ y = x ^+^ negated y {-# INLINE (^-^) #-} #endif 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 -> unsafeWrite w i $ f (unsafeIndex u i) (unsafeIndex v i)) v EQ -> Vector.zipWith f u v GT | lv == 0 -> u | otherwise -> Vector.modify (\ w -> Foldable.forM_ [0..lv-1] $ \i -> unsafeWrite w i $ f (unsafeIndex u i) (unsafeIndex v i)) u where lu = Vector.length u lv = Vector.length v {-# INLINE liftU2 #-} liftI2 = Vector.zipWith {-# INLINE liftI2 #-} #ifndef USE_GHC_GENERICS (^+^) = liftU2 (+) {-# INLINE (^+^) #-} x ^-^ y = x ^+^ negated y {-# INLINE (^-^) #-} #endif 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 #-} #ifndef USE_GHC_GENERICS (^+^) = liftU2 (+) {-# INLINE (^+^) #-} x ^-^ y = x ^+^ negated y {-# INLINE (^-^) #-} #endif 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 #-} #ifndef USE_GHC_GENERICS (^+^) = liftU2 (+) {-# INLINE (^+^) #-} x ^-^ y = x ^+^ negated y {-# INLINE (^-^) #-} #endif instance Additive IntMap where zero = IntMap.empty {-# INLINE zero #-} liftU2 = IntMap.unionWith {-# INLINE liftU2 #-} liftI2 = IntMap.intersectionWith {-# INLINE liftI2 #-} #ifndef USE_GHC_GENERICS (^+^) = liftU2 (+) {-# INLINE (^+^) #-} x ^-^ y = x ^+^ negated y {-# INLINE (^-^) #-} #endif instance Ord k => Additive (Map k) where zero = Map.empty {-# INLINE zero #-} liftU2 = Map.unionWith {-# INLINE liftU2 #-} liftI2 = Map.intersectionWith {-# INLINE liftI2 #-} #ifndef USE_GHC_GENERICS (^+^) = liftU2 (+) {-# INLINE (^+^) #-} x ^-^ y = x ^+^ negated y {-# INLINE (^-^) #-} #endif instance (Eq k, Hashable k) => Additive (HashMap k) where zero = HashMap.empty {-# INLINE zero #-} liftU2 = HashMap.unionWith {-# INLINE liftU2 #-} liftI2 = HashMap.intersectionWith {-# INLINE liftI2 #-} #ifndef USE_GHC_GENERICS (^+^) = liftU2 (+) {-# INLINE (^+^) #-} x ^-^ y = x ^+^ negated y {-# INLINE (^-^) #-} #endif instance Additive ((->) b) where zero = const 0 {-# INLINE zero #-} liftU2 = liftA2 {-# INLINE liftU2 #-} liftI2 = liftA2 {-# INLINE liftI2 #-} #ifndef USE_GHC_GENERICS (^+^) = liftU2 (+) {-# INLINE (^+^) #-} x ^-^ y = x ^+^ negated y {-# INLINE (^-^) #-} #endif 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 #-} #ifndef USE_GHC_GENERICS (^+^) = liftU2 (+) {-# INLINE (^+^) #-} x ^-^ y = x ^+^ negated y {-# INLINE (^-^) #-} #endif instance Additive Identity where zero = Identity 0 {-# INLINE zero #-} liftU2 = liftA2 {-# INLINE liftU2 #-} liftI2 = liftA2 {-# INLINE liftI2 #-} #ifndef USE_GHC_GENERICS (^+^) = liftU2 (+) {-# INLINE (^+^) #-} x ^-^ y = x ^+^ negated y {-# INLINE (^-^) #-} #endif -- | 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.20.5/src/Linear/Plucker/0000755000000000000000000000000012722610624014647 5ustar0000000000000000linear-1.20.5/src/Linear/Plucker/Coincides.hs0000644000000000000000000000275212722610624017111 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.20.5/tests/0000755000000000000000000000000012722610624012403 5ustar0000000000000000linear-1.20.5/tests/Binary.hs0000644000000000000000000000112012722610624014155 0ustar0000000000000000module Binary (tests) where import Control.Applicative 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.20.5/tests/doctests.hs0000644000000000000000000000155012722610624014570 0ustar0000000000000000module Main where import Build_doctests (autogen_dir, deps) import Control.Applicative import Control.Monad import Data.List import System.Directory import System.FilePath import Test.DocTest main :: IO () main = getSources >>= \sources -> doctest $ "-isrc" : ("-i" ++ autogen_dir) : "-optP-include" : ("-optP" ++ autogen_dir ++ "/cabal_macros.h") : "-hide-all-packages" : map ("-package="++) deps ++ sources getSources :: IO [FilePath] getSources = filter (isSuffixOf ".hs") <$> go "src" where go dir = do (dirs, files) <- getFilesAndDirectories dir (files ++) . concat <$> mapM go dirs getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) getFilesAndDirectories dir = do c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c linear-1.20.5/tests/Plucker.hs0000644000000000000000000000332712722610624014351 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.20.5/tests/UnitTests.hs0000644000000000000000000000053512722610624014704 0ustar0000000000000000module Main (main) where import Test.Framework (defaultMain, testGroup, Test) import Test.Framework.Providers.HUnit import qualified Plucker import qualified Binary tests :: [Test] tests = [ testGroup "Plucker" $ hUnitTestToTests Plucker.tests , testGroup "Binary" $ hUnitTestToTests Binary.tests ] main :: IO () main = defaultMain tests linear-1.20.5/travis/0000755000000000000000000000000012722610624012551 5ustar0000000000000000linear-1.20.5/travis/cabal-apt-install0000755000000000000000000000127212722610624015771 0ustar0000000000000000#! /bin/bash set -eu APT="sudo apt-get -q -y" CABAL_INSTALL_DEPS="cabal install --only-dependencies --force-reinstall" $APT update $APT install dctrl-tools # Find potential system packages to satisfy cabal dependencies deps() { local M='^\([^ ]\+\)-[0-9.]\+ (.*$' local G=' -o ( -FPackage -X libghc-\L\1\E-dev )' local E="$($CABAL_INSTALL_DEPS "$@" --dry-run -v 2> /dev/null \ | sed -ne "s/$M/$G/p" | sort -u)" grep-aptavail -n -sPackage \( -FNone -X None \) $E | sort -u } $APT install $(deps "$@") libghc-quickcheck2-dev # QuickCheck is special $CABAL_INSTALL_DEPS "$@" # Install the rest via Hackage if ! $APT install hlint ; then $APT install $(deps hlint) cabal install hlint fi linear-1.20.5/travis/config0000644000000000000000000000120612722610624013740 0ustar0000000000000000-- This provides a custom ~/.cabal/config file for use when hackage is down that should work on unix -- -- This is particularly useful for travis-ci to get it to stop complaining -- about a broken build when everything is still correct on our end. -- -- This uses Luite Stegeman's mirror of hackage provided by his 'hdiff' site instead -- -- To enable this, uncomment the before_script in .travis.yml remote-repo: hdiff.luite.com:http://hdiff.luite.com/packages/archive remote-repo-cache: ~/.cabal/packages world-file: ~/.cabal/world build-summary: ~/.cabal/logs/build.log remote-build-reporting: anonymous install-dirs user install-dirs global