vector-space-0.16/0000755000000000000000000000000013421727005012222 5ustar0000000000000000vector-space-0.16/Setup.lhs0000644000000000000000000000011413421727005014026 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain vector-space-0.16/vector-space.cabal0000644000000000000000000000374013421727005015605 0ustar0000000000000000Name: vector-space Version: 0.16 Cabal-Version: >= 1.8 Synopsis: Vector & affine spaces, linear maps, and derivatives Category: math Description: /vector-space/ provides classes and generic operations for vector spaces and affine spaces. It also defines a type of infinite towers of generalized derivatives. A generalized derivative is a linear transformation rather than one of the common concrete representations (scalars, vectors, matrices, ...). . /Warning/: this package depends on type families working fairly well, requiring GHC version at least 6.9. . Project wiki page: . © 2008-2012 by Conal Elliott; BSD3 license. Author: Conal Elliott Maintainer: conal@conal.net Copyright: (c) 2008-2012 by Conal Elliott License: BSD3 License-File: COPYING Stability: experimental build-type: Simple source-repository head type: git location: git://github.com/conal/vector-space.git Library hs-Source-Dirs: src Extensions: Build-Depends: base<5, MemoTrie >= 0.5 , Boolean >= 0.1.0 , NumInstances >= 1.0 Exposed-Modules: Data.AdditiveGroup Data.VectorSpace Data.Basis Data.LinearMap Data.Maclaurin -- Data.Horner Data.Derivative Data.Cross Data.AffineSpace Other-Modules: Data.VectorSpace.Generic -- This library relies on type families working as well as in 6.10. if impl(ghc < 6.10) { buildable: False } if !impl(ghc >= 7.6) { Build-Depends: ghc-prim >= 0.2 } if !impl(ghc >= 7.9) { Build-Depends: void >= 0.4 } if !impl(ghc >= 8.0) { Build-Depends: semigroups >= 0.16 } ghc-options: -Wall -O2 vector-space-0.16/COPYING0000644000000000000000000000256513421727005013265 0ustar0000000000000000Copyright (c) 2009 Conal Elliott 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. The names of the authors may not 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 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. vector-space-0.16/src/0000755000000000000000000000000013421727005013011 5ustar0000000000000000vector-space-0.16/src/Data/0000755000000000000000000000000013421727005013662 5ustar0000000000000000vector-space-0.16/src/Data/VectorSpace.hs0000644000000000000000000002053013421727005016434 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, TypeOperators , TypeFamilies, UndecidableInstances, CPP , FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} ---------------------------------------------------------------------- -- | -- Module : Data.VectorSpace -- Copyright : (c) Conal Elliott and Andy J Gill 2008 -- License : BSD3 -- -- Maintainer : conal@conal.net, andygill@ku.edu -- Stability : experimental -- -- Vector spaces -- -- This version uses associated types instead of fundeps and -- requires ghc-6.10 or later ---------------------------------------------------------------------- -- NB: I'm attempting to replace fundeps with associated types. See -- NewVectorSpace.hs. Ran into trouble with type equality constraints not -- getting propagated. Manuel Ch is looking into it. -- -- Blocking bug: http://hackage.haskell.org/trac/ghc/ticket/2448 module Data.VectorSpace ( module Data.AdditiveGroup , VectorSpace(..), (^/), (^*) , InnerSpace(..) , lerp, linearCombo, magnitudeSq, magnitude, normalized, project ) where import Control.Applicative (liftA2) import Data.Complex hiding (magnitude) import Foreign.C.Types (CSChar, CInt, CShort, CLong, CLLong, CIntMax, CFloat, CDouble) import Data.Ratio import Data.AdditiveGroup import Data.MemoTrie import Data.VectorSpace.Generic import qualified GHC.Generics as Gnrx import GHC.Generics (Generic, (:*:)(..)) infixr 7 *^ -- | Vector space @v@. class AdditiveGroup v => VectorSpace v where type Scalar v :: * type Scalar v = Scalar (VRep v) -- | Scale a vector (*^) :: Scalar v -> v -> v default (*^) :: (Generic v, VectorSpace (VRep v), Scalar (VRep v) ~ Scalar v) => Scalar v -> v -> v μ *^ v = Gnrx.to (μ *^ Gnrx.from v :: VRep v) {-# INLINE (*^) #-} infixr 7 <.> -- | Adds inner (dot) products. class (VectorSpace v, AdditiveGroup (Scalar v)) => InnerSpace v where -- | Inner/dot product (<.>) :: v -> v -> Scalar v default (<.>) :: (Generic v, InnerSpace (VRep v), Scalar (VRep v) ~ Scalar v) => v -> v -> Scalar v v<.>w = (Gnrx.from v :: VRep v) <.> Gnrx.from w {-# INLINE (<.>) #-} infixr 7 ^/ infixl 7 ^* -- | Vector divided by scalar (^/) :: (VectorSpace v, s ~ Scalar v, Fractional s) => v -> s -> v v ^/ s = recip s *^ v {-# INLINE (^/) #-} -- | Vector multiplied by scalar (^*) :: (VectorSpace v, s ~ Scalar v) => v -> s -> v (^*) = flip (*^) {-# INLINE (^*) #-} -- | Linear interpolation between @a@ (when @t==0@) and @b@ (when @t==1@). -- lerp :: (VectorSpace v, s ~ Scalar v, Num s) => v -> v -> s -> v lerp :: VectorSpace v => v -> v -> Scalar v -> v lerp a b t = a ^+^ t *^ (b ^-^ a) {-# INLINE lerp #-} -- | Linear combination of vectors linearCombo :: VectorSpace v => [(v,Scalar v)] -> v linearCombo ps = sumV [v ^* s | (v,s) <- ps] {-# INLINE linearCombo #-} -- | Square of the length of a vector. Sometimes useful for efficiency. -- See also 'magnitude'. magnitudeSq :: (InnerSpace v, s ~ Scalar v) => v -> s magnitudeSq v = v <.> v {-# INLINE magnitudeSq #-} -- | Length of a vector. See also 'magnitudeSq'. magnitude :: (InnerSpace v, s ~ Scalar v, Floating s) => v -> s magnitude = sqrt . magnitudeSq {-# INLINE magnitude #-} -- | Vector in same direction as given one but with length of one. If -- given the zero vector, then return it. normalized :: (InnerSpace v, s ~ Scalar v, Floating s) => v -> v normalized v = v ^/ magnitude v {-# INLINE normalized #-} -- | @project u v@ computes the projection of @v@ onto @u@. project :: (InnerSpace v, s ~ Scalar v, Fractional s) => v -> v -> v project u v = ((v <.> u) / magnitudeSq u) *^ u {-# INLINE project #-} #define ScalarType(t) \ instance VectorSpace (t) where \ { type Scalar (t) = (t) \ ; (*^) = (*) } ; \ instance InnerSpace (t) where (<.>) = (*) ScalarType(Int) ScalarType(Integer) ScalarType(Double) ScalarType(Float) ScalarType(CSChar) ScalarType(CInt) ScalarType(CShort) ScalarType(CLong) ScalarType(CLLong) ScalarType(CIntMax) ScalarType(CDouble) ScalarType(CFloat) instance Integral a => VectorSpace (Ratio a) where type Scalar (Ratio a) = Ratio a (*^) = (*) instance Integral a => InnerSpace (Ratio a) where (<.>) = (*) instance (RealFloat v, VectorSpace v) => VectorSpace (Complex v) where type Scalar (Complex v) = Scalar v s*^(u :+ v) = s*^u :+ s*^v instance (RealFloat v, InnerSpace v) => InnerSpace (Complex v) where (u :+ v) <.> (u' :+ v') = (u <.> u') ^+^ (v <.> v') -- Hm. The 'RealFloat' constraint is unfortunate here. It's due to a -- questionable decision to place 'RealFloat' into the definition of the -- 'Complex' /type/, rather than in functions and instances as needed. -- instance (VectorSpace u,VectorSpace v, s ~ Scalar u, s ~ Scalar v) -- => VectorSpace (u,v) where -- type Scalar (u,v) = Scalar u -- s *^ (u,v) = (s*^u,s*^v) instance ( VectorSpace u, s ~ Scalar u , VectorSpace v, s ~ Scalar v ) => VectorSpace (u,v) where type Scalar (u,v) = Scalar u s *^ (u,v) = (s*^u,s*^v) instance ( InnerSpace u, s ~ Scalar u , InnerSpace v, s ~ Scalar v ) => InnerSpace (u,v) where (u,v) <.> (u',v') = (u <.> u') ^+^ (v <.> v') instance ( VectorSpace u, s ~ Scalar u , VectorSpace v, s ~ Scalar v , VectorSpace w, s ~ Scalar w ) => VectorSpace (u,v,w) where type Scalar (u,v,w) = Scalar u s *^ (u,v,w) = (s*^u,s*^v,s*^w) instance ( InnerSpace u, s ~ Scalar u , InnerSpace v, s ~ Scalar v , InnerSpace w, s ~ Scalar w ) => InnerSpace (u,v,w) where (u,v,w) <.> (u',v',w') = u<.>u' ^+^ v<.>v' ^+^ w<.>w' instance ( VectorSpace u, s ~ Scalar u , VectorSpace v, s ~ Scalar v , VectorSpace w, s ~ Scalar w , VectorSpace x, s ~ Scalar x ) => VectorSpace (u,v,w,x) where type Scalar (u,v,w,x) = Scalar u s *^ (u,v,w,x) = (s*^u,s*^v,s*^w,s*^x) instance ( InnerSpace u, s ~ Scalar u , InnerSpace v, s ~ Scalar v , InnerSpace w, s ~ Scalar w , InnerSpace x, s ~ Scalar x ) => InnerSpace (u,v,w,x) where (u,v,w,x) <.> (u',v',w',x') = u<.>u' ^+^ v<.>v' ^+^ w<.>w' ^+^ x<.>x' -- Standard instances for a functor applied to a vector space. -- For 'Maybe', Nothing represents 'zeroV'. Useful for optimization, since -- we might not be able to test for 'zeroV', e.g., functions and infinite -- derivative towers. instance VectorSpace v => VectorSpace (Maybe v) where type Scalar (Maybe v) = Scalar v (*^) s = fmap (s *^) -- instance VectorSpace v => VectorSpace (a -> v) where -- type Scalar (a -> v) = Scalar v -- (*^) s = fmap (s *^) -- No 'InnerSpace' instance for @a -> v@. -- Or the following definition, which is useful for the higher-order -- shading dsel in Shady (borrowed from Vertigo). instance VectorSpace v => VectorSpace (a -> v) where type Scalar (a -> v) = a -> Scalar v (*^) = liftA2 (*^) instance InnerSpace v => InnerSpace (a -> v) where (<.>) = liftA2 (<.>) instance (HasTrie a, VectorSpace v) => VectorSpace (a :->: v) where type Scalar (a :->: v) = Scalar v (*^) s = fmap (s *^) instance InnerSpace a => InnerSpace (Maybe a) where -- dotting with zero (vector) yields zero (scalar) Nothing <.> _ = zeroV _ <.> Nothing = zeroV Just u <.> Just v = u <.> v -- mu <.> mv = fromMaybe zeroV (liftA2 (<.>) mu mv) -- (<.>) = (fmap.fmap) (fromMaybe zeroV) (liftA2 (<.>)) instance VectorSpace a => VectorSpace (Gnrx.Rec0 a s) where type Scalar (Gnrx.Rec0 a s) = Scalar a μ *^ Gnrx.K1 v = Gnrx.K1 $ μ*^v {-# INLINE (*^) #-} instance VectorSpace (f p) => VectorSpace (Gnrx.M1 i c f p) where type Scalar (Gnrx.M1 i c f p) = Scalar (f p) μ *^ Gnrx.M1 v = Gnrx.M1 $ μ*^v {-# INLINE (*^) #-} instance (VectorSpace (f p), VectorSpace (g p), Scalar (f p) ~ Scalar (g p)) => VectorSpace ((f :*: g) p) where type Scalar ((f:*:g) p) = Scalar (f p) μ *^ (x:*:y) = μ*^x :*: μ*^y {-# INLINE (*^) #-} instance InnerSpace a => InnerSpace (Gnrx.Rec0 a s) where Gnrx.K1 v <.> Gnrx.K1 w = v<.>w {-# INLINE (<.>) #-} instance InnerSpace (f p) => InnerSpace (Gnrx.M1 i c f p) where Gnrx.M1 v <.> Gnrx.M1 w = v<.>w {-# INLINE (<.>) #-} instance ( InnerSpace (f p), InnerSpace (g p) , Scalar (f p) ~ Scalar (g p), Num (Scalar (f p)) ) => InnerSpace ((f :*: g) p) where (x:*:y) <.> (ξ:*:υ) = x<.>ξ + y<.>υ {-# INLINE (<.>) #-} vector-space-0.16/src/Data/AffineSpace.hs0000644000000000000000000001600213421727005016361 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, TypeFamilies, CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DeriveGeneric #-} ---------------------------------------------------------------------- -- | -- Module : Data.AffineSpace -- Copyright : (c) Conal Elliott and Andy J Gill 2008 -- License : BSD3 -- -- Maintainer : conal@conal.net, andygill@ku.edu -- Stability : experimental -- -- Affine spaces. ---------------------------------------------------------------------- module Data.AffineSpace ( AffineSpace(..), (.-^), distanceSq, distance, alerp, affineCombo ) where import Control.Applicative (liftA2) import Data.Ratio import Foreign.C.Types (CSChar, CInt, CShort, CLong, CLLong, CIntMax, CFloat, CDouble) import Control.Arrow(first) import Data.VectorSpace import Data.Basis import Data.VectorSpace.Generic import qualified GHC.Generics as Gnrx import GHC.Generics (Generic, (:*:)(..)) -- Through 0.8.4, I used the following fixities. -- -- infix 4 .+^, .-^, .-. -- -- Changed in 0.8.5 to match precedence of + and -, and to associate usefully. -- Thanks to Ben Gamari for suggesting left-associativity. infixl 6 .+^, .-^ infix 6 .-. -- TODO: Convert AffineSpace from fundep to associated type, and eliminate -- FunctionalDependencies above. class AdditiveGroup (Diff p) => AffineSpace p where -- | Associated vector space type Diff p type Diff p = GenericDiff p -- | Subtract points (.-.) :: p -> p -> Diff p default (.-.) :: ( Generic p, Diff p ~ GenericDiff p, AffineSpace (VRep p) ) => p -> p -> Diff p p .-. q = GenericDiff $ (Gnrx.from p .-. (Gnrx.from q :: VRep p)) -- | Point plus vector (.+^) :: p -> Diff p -> p default (.+^) :: ( Generic p, Diff p ~ GenericDiff p, AffineSpace (VRep p) ) => p -> Diff p -> p p .+^ GenericDiff q = Gnrx.to (Gnrx.from p .+^ q :: VRep p) -- | Point minus vector (.-^) :: AffineSpace p => p -> Diff p -> p p .-^ v = p .+^ negateV v -- | Square of the distance between two points. Sometimes useful for -- efficiency. See also 'distance'. distanceSq :: (AffineSpace p, v ~ Diff p, InnerSpace v) => p -> p -> Scalar v distanceSq = (fmap.fmap) magnitudeSq (.-.) -- | Distance between two points. See also 'distanceSq'. distance :: (AffineSpace p, v ~ Diff p, InnerSpace v , s ~ Scalar v, Floating (Scalar v)) => p -> p -> s distance = (fmap.fmap) sqrt distanceSq -- | Affine linear interpolation. Varies from @p@ to @p'@ as @s@ varies -- from 0 to 1. See also 'lerp' (on vector spaces). alerp :: (AffineSpace p, VectorSpace (Diff p)) => p -> p -> Scalar (Diff p) -> p alerp p p' s = p .+^ (s *^ (p' .-. p)) -- | Compute an affine combination (weighted average) of points. -- The first element is used as origin and is weighted -- such that all coefficients sum to 1. For example, -- -- > affineCombo a [(0.3,b), (0.2,c)] -- -- is equal to -- -- > a .+^ (0.3 *^ (b .-. a) ^+^ 0.2 *^ (c .-. a)) -- -- and if @a@, @b@, and @c@ were in a vector space would also be equal to -- -- > 0.5 *^ a ^+^ 0.3 *^ b ^+^ 0.2 *^ c -- -- See also 'linearCombo' (on vector spaces). affineCombo :: (AffineSpace p, v ~ Diff p, VectorSpace v) => p -> [(p,Scalar v)] -> p affineCombo z l = z .+^ linearCombo (map (first (.-. z)) l) #define ScalarTypeCon(con,t) \ instance con => AffineSpace (t) where \ { type Diff (t) = t \ ; (.-.) = (-) \ ; (.+^) = (+) } #define ScalarType(t) ScalarTypeCon((),t) ScalarType(Int) ScalarType(Integer) ScalarType(Double) ScalarType(Float) ScalarType(CSChar) ScalarType(CInt) ScalarType(CShort) ScalarType(CLong) ScalarType(CLLong) ScalarType(CIntMax) ScalarType(CDouble) ScalarType(CFloat) ScalarTypeCon(Integral a,Ratio a) instance (AffineSpace p, AffineSpace q) => AffineSpace (p,q) where type Diff (p,q) = (Diff p, Diff q) (p,q) .-. (p',q') = (p .-. p', q .-. q') (p,q) .+^ (u,v) = (p .+^ u, q .+^ v) instance (AffineSpace p, AffineSpace q, AffineSpace r) => AffineSpace (p,q,r) where type Diff (p,q,r) = (Diff p, Diff q, Diff r) (p,q,r) .-. (p',q',r') = (p .-. p', q .-. q', r .-. r') (p,q,r) .+^ (u,v,w) = (p .+^ u, q .+^ v, r .+^ w) instance (AffineSpace p) => AffineSpace (a -> p) where type Diff (a -> p) = a -> Diff p (.-.) = liftA2 (.-.) (.+^) = liftA2 (.+^) newtype GenericDiff p = GenericDiff (Diff (VRep p)) deriving (Generic) instance AdditiveGroup (Diff (VRep p)) => AdditiveGroup (GenericDiff p) instance VectorSpace (Diff (VRep p)) => VectorSpace (GenericDiff p) instance InnerSpace (Diff (VRep p)) => InnerSpace (GenericDiff p) instance HasBasis (Diff (VRep p)) => HasBasis (GenericDiff p) data AffineDiffProductSpace f g p = AffineDiffProductSpace !(Diff (f p)) !(Diff (g p)) deriving (Generic) instance (AffineSpace (f p), AffineSpace (g p)) => AdditiveGroup (AffineDiffProductSpace f g p) instance ( AffineSpace (f p), AffineSpace (g p) , VectorSpace (Diff (f p)), VectorSpace (Diff (g p)) , Scalar (Diff (f p)) ~ Scalar (Diff (g p)) ) => VectorSpace (AffineDiffProductSpace f g p) instance ( AffineSpace (f p), AffineSpace (g p) , InnerSpace (Diff (f p)), InnerSpace (Diff (g p)) , Scalar (Diff (f p)) ~ Scalar (Diff (g p)) , Num (Scalar (Diff (f p))) ) => InnerSpace (AffineDiffProductSpace f g p) instance (AffineSpace (f p), AffineSpace (g p)) => AffineSpace (AffineDiffProductSpace f g p) where type Diff (AffineDiffProductSpace f g p) = AffineDiffProductSpace f g p (.+^) = (^+^) (.-.) = (^-^) instance ( AffineSpace (f p), AffineSpace (g p) , HasBasis (Diff (f p)), HasBasis (Diff (g p)) , Scalar (Diff (f p)) ~ Scalar (Diff (g p)) ) => HasBasis (AffineDiffProductSpace f g p) where type Basis (AffineDiffProductSpace f g p) = Either (Basis (Diff (f p))) (Basis (Diff (g p))) basisValue (Left bf) = AffineDiffProductSpace (basisValue bf) zeroV basisValue (Right bg) = AffineDiffProductSpace zeroV (basisValue bg) decompose (AffineDiffProductSpace vf vg) = map (first Left) (decompose vf) ++ map (first Right) (decompose vg) decompose' (AffineDiffProductSpace vf _) (Left bf) = decompose' vf bf decompose' (AffineDiffProductSpace _ vg) (Right bg) = decompose' vg bg instance AffineSpace a => AffineSpace (Gnrx.Rec0 a s) where type Diff (Gnrx.Rec0 a s) = Diff a Gnrx.K1 v .+^ w = Gnrx.K1 $ v .+^ w Gnrx.K1 v .-. Gnrx.K1 w = v .-. w instance AffineSpace (f p) => AffineSpace (Gnrx.M1 i c f p) where type Diff (Gnrx.M1 i c f p) = Diff (f p) Gnrx.M1 v .+^ w = Gnrx.M1 $ v .+^ w Gnrx.M1 v .-. Gnrx.M1 w = v .-. w instance (AffineSpace (f p), AffineSpace (g p)) => AffineSpace ((f :*: g) p) where type Diff ((f:*:g) p) = AffineDiffProductSpace f g p (x:*:y) .+^ AffineDiffProductSpace ξ υ = (x.+^ξ) :*: (y.+^υ) (x:*:y) .-. (ξ:*:υ) = AffineDiffProductSpace (x.-.ξ) (y.-.υ) vector-space-0.16/src/Data/Derivative.hs0000644000000000000000000000100413421727005016313 0ustar0000000000000000---------------------------------------------------------------------- -- | -- Module : Data.Derivative -- Copyright : (c) Conal Elliott 2008 -- License : BSD3 -- -- Maintainer : conal@conal.net -- Stability : experimental -- -- Module indirection module. For Maclaurin- vs Horner-based derivative -- towers. ---------------------------------------------------------------------- module Data.Derivative (module Data.Maclaurin) where import Data.Maclaurin -- Or Data.Horner when working again vector-space-0.16/src/Data/AdditiveGroup.hs0000644000000000000000000001657713421727005017004 0ustar0000000000000000{-# LANGUAGE TypeOperators, CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} ---------------------------------------------------------------------- -- | -- Module : Data.AdditiveGroup -- Copyright : (c) Conal Elliott and Andy J Gill 2008 -- License : BSD3 -- -- Maintainer : conal@conal.net, andygill@ku.edu -- Stability : experimental -- -- Groups: zero, addition, and negation (additive inverse) ---------------------------------------------------------------------- module Data.AdditiveGroup ( AdditiveGroup(..), sumV , Sum(..), inSum, inSum2 ) where import Prelude hiding (foldr) import Control.Applicative #if !(MIN_VERSION_base(4,8,0)) import Data.Monoid (Monoid(..)) import Data.Foldable (Foldable) #endif import Data.Foldable (foldr) import Data.Complex hiding (magnitude) import Data.Ratio #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup(..)) #endif import Foreign.C.Types (CSChar, CInt, CShort, CLong, CLLong, CIntMax, CFloat, CDouble) import Data.MemoTrie import Data.VectorSpace.Generic import qualified GHC.Generics as Gnrx import GHC.Generics (Generic, (:*:)(..)) infixl 6 ^+^, ^-^ -- | Additive group @v@. class AdditiveGroup v where -- | The zero element: identity for '(^+^)' zeroV :: v default zeroV :: (Generic v, AdditiveGroup (VRep v)) => v zeroV = Gnrx.to (zeroV :: VRep v) {-# INLINE zeroV #-} -- | Add vectors (^+^) :: v -> v -> v default (^+^) :: (Generic v, AdditiveGroup (VRep v)) => v -> v -> v v ^+^ v' = Gnrx.to (Gnrx.from v ^+^ Gnrx.from v' :: VRep v) {-# INLINE (^+^) #-} -- | Additive inverse negateV :: v -> v default negateV :: (Generic v, AdditiveGroup (VRep v)) => v -> v negateV v = Gnrx.to (negateV $ Gnrx.from v :: VRep v) {-# INLINE negateV #-} -- | Group subtraction (^-^) :: v -> v -> v v ^-^ v' = v ^+^ negateV v' -- | Sum over several vectors sumV :: (Foldable f, AdditiveGroup v) => f v -> v sumV = foldr (^+^) zeroV {-# INLINE sumV #-} instance AdditiveGroup () where zeroV = () () ^+^ () = () negateV = id -- For 'Num' types: -- -- instance AdditiveGroup n where {zeroV=0; (^+^) = (+); negateV = negate} #define ScalarTypeCon(con,t) \ instance con => AdditiveGroup (t) where {zeroV=0; (^+^) = (+); negateV = negate} #define ScalarType(t) ScalarTypeCon((),t) ScalarType(Int) ScalarType(Integer) ScalarType(Float) ScalarType(Double) ScalarType(CSChar) ScalarType(CInt) ScalarType(CShort) ScalarType(CLong) ScalarType(CLLong) ScalarType(CIntMax) ScalarType(CFloat) ScalarType(CDouble) ScalarTypeCon(Integral a,Ratio a) instance (RealFloat v, AdditiveGroup v) => AdditiveGroup (Complex v) where zeroV = zeroV :+ zeroV (^+^) = (+) negateV = negate -- Hm. The 'RealFloat' constraint is unfortunate here. It's due to a -- questionable decision to place 'RealFloat' into the definition of the -- 'Complex' /type/, rather than in functions and instances as needed. instance (AdditiveGroup u,AdditiveGroup v) => AdditiveGroup (u,v) where zeroV = (zeroV,zeroV) (u,v) ^+^ (u',v') = (u^+^u',v^+^v') negateV (u,v) = (negateV u,negateV v) instance (AdditiveGroup u,AdditiveGroup v,AdditiveGroup w) => AdditiveGroup (u,v,w) where zeroV = (zeroV,zeroV,zeroV) (u,v,w) ^+^ (u',v',w') = (u^+^u',v^+^v',w^+^w') negateV (u,v,w) = (negateV u,negateV v,negateV w) instance (AdditiveGroup u,AdditiveGroup v,AdditiveGroup w,AdditiveGroup x) => AdditiveGroup (u,v,w,x) where zeroV = (zeroV,zeroV,zeroV,zeroV) (u,v,w,x) ^+^ (u',v',w',x') = (u^+^u',v^+^v',w^+^w',x^+^x') negateV (u,v,w,x) = (negateV u,negateV v,negateV w,negateV x) -- Standard instance for an applicative functor applied to a vector space. instance AdditiveGroup v => AdditiveGroup (a -> v) where zeroV = pure zeroV (^+^) = liftA2 (^+^) negateV = fmap negateV -- Maybe is handled like the Maybe-of-Sum monoid instance AdditiveGroup a => AdditiveGroup (Maybe a) where zeroV = Nothing Nothing ^+^ b' = b' a' ^+^ Nothing = a' Just a' ^+^ Just b' = Just (a' ^+^ b') negateV = fmap negateV {- Alexey Khudyakov wrote: I looked through vector-space package and found lawless instance. Namely Maybe's AdditiveGroup instance It's group so following relation is expected to hold. Otherwise it's not a group. > x ^+^ negateV x == zeroV Here is counterexample: > let x = Just 2 in x ^+^ negateV x == zeroV False I think it's not possible to sensibly define group instance for Maybe a at all. I see that the problem here is in distinguishing 'Just zeroV' from Nothing. I could fix the Just + Just line to use Nothing instead of Just zeroV when a' ^+^ b' == zeroV, although doing so would require Eq a and hence lose some generality. Even so, the abstraction leak would probably show up elsewhere. Hm. -} -- Memo tries instance (HasTrie u, AdditiveGroup v) => AdditiveGroup (u :->: v) where zeroV = pure zeroV (^+^) = liftA2 (^+^) negateV = fmap negateV -- | Monoid under group addition. Alternative to the @Sum@ in -- "Data.Monoid", which uses 'Num' instead of 'AdditiveGroup'. newtype Sum a = Sum { getSum :: a } deriving (Eq, Ord, Read, Show, Bounded) instance Functor Sum where fmap f (Sum a) = Sum (f a) {-# INLINE fmap #-} -- instance Applicative Sum where -- pure a = Sum a -- Sum f <*> Sum x = Sum (f x) instance Applicative Sum where pure = Sum {-# INLINE pure #-} (<*>) = inSum2 ($) {-# INLINE (<*>) #-} instance AdditiveGroup a => Semigroup (Sum a) where (<>) = liftA2 (^+^) {-# INLINE (<>) #-} instance AdditiveGroup a => Monoid (Sum a) where mempty = Sum zeroV #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) #endif -- | Application a unary function inside a 'Sum' inSum :: (a -> b) -> (Sum a -> Sum b) inSum = getSum ~> Sum {-# INLINE inSum #-} -- | Application a binary function inside a 'Sum' inSum2 :: (a -> b -> c) -> (Sum a -> Sum b -> Sum c) inSum2 = getSum ~> inSum {-# INLINE inSum2 #-} instance AdditiveGroup a => AdditiveGroup (Sum a) where zeroV = Sum zeroV (^+^) = (<>) negateV = inSum negateV ---- to go elsewhere (~>) :: (a' -> a) -> (b -> b') -> ((a -> b) -> (a' -> b')) (i ~> o) f = o . f . i {-# INLINE (~>) #-} -- result :: (b -> b') -> ((a -> b) -> (a -> b')) -- result = (.) -- argument :: (a' -> a) -> ((a -> b) -> (a' -> b)) -- argument = flip (.) -- g ~> f = result g . argument f instance AdditiveGroup a => AdditiveGroup (Gnrx.Rec0 a s) where zeroV = Gnrx.K1 zeroV {-# INLINE zeroV #-} negateV (Gnrx.K1 v) = Gnrx.K1 $ negateV v {-# INLINE negateV #-} Gnrx.K1 v ^+^ Gnrx.K1 w = Gnrx.K1 $ v ^+^ w {-# INLINE (^+^) #-} Gnrx.K1 v ^-^ Gnrx.K1 w = Gnrx.K1 $ v ^-^ w {-# INLINE (^-^) #-} instance AdditiveGroup (f p) => AdditiveGroup (Gnrx.M1 i c f p) where zeroV = Gnrx.M1 zeroV {-# INLINE zeroV #-} negateV (Gnrx.M1 v) = Gnrx.M1 $ negateV v {-# INLINE negateV #-} Gnrx.M1 v ^+^ Gnrx.M1 w = Gnrx.M1 $ v ^+^ w {-# INLINE (^+^) #-} Gnrx.M1 v ^-^ Gnrx.M1 w = Gnrx.M1 $ v ^-^ w {-# INLINE (^-^) #-} instance (AdditiveGroup (f p), AdditiveGroup (g p)) => AdditiveGroup ((f :*: g) p) where zeroV = zeroV :*: zeroV {-# INLINE zeroV #-} negateV (x:*:y) = negateV x :*: negateV y {-# INLINE negateV #-} (x:*:y) ^+^ (ξ:*:υ) = (x^+^ξ) :*: (y^+^υ) {-# INLINE (^+^) #-} (x:*:y) ^-^ (ξ:*:υ) = (x^-^ξ) :*: (y^-^υ) {-# INLINE (^-^) #-} vector-space-0.16/src/Data/Maclaurin.hs0000644000000000000000000002157213421727005016140 0ustar0000000000000000{-# LANGUAGE TypeOperators, MultiParamTypeClasses, UndecidableInstances , TypeSynonymInstances, FlexibleInstances , FlexibleContexts, TypeFamilies , ScopedTypeVariables, CPP #-} -- The ScopedTypeVariables is there just as a bug work-around. Without it -- I get a bogus error about context mismatch for mutually recursive -- definitions. This bug was introduced between ghc 6.9.20080622 and -- 6.10.0.20081007. -- {-# OPTIONS_GHC -ddump-simpl-stats -ddump-simpl #-} -- TODO: remove FlexibleContexts {-# OPTIONS_GHC -Wall #-} ---------------------------------------------------------------------- -- | -- Module : Data.Maclaurin -- Copyright : (c) Conal Elliott 2008 -- License : BSD3 -- -- Maintainer : conal@conal.net -- Stability : experimental -- -- Infinite derivative towers via linear maps, using the Maclaurin -- representation. See blog posts . ---------------------------------------------------------------------- module Data.Maclaurin ( (:>)(D), powVal, derivative, derivAtBasis -- maybe not D , (:~>), pureD , fmapD, (<$>>){-, (<*>>)-}, liftD2, liftD3 , idD, fstD, sndD , linearD, distrib -- , (@.) , (>-<) -- * Misc , pairD, unpairD, tripleD, untripleD ) where -- import Control.Applicative (liftA2) import Data.Function (on) import Data.VectorSpace import Data.NumInstances () import Data.MemoTrie import Data.Basis import Data.LinearMap import Data.Boolean #if MIN_VERSION_base(4,8,0) import Prelude hiding ((<*)) #endif infixr 9 `D` -- | Tower of derivatives. data a :> b = D { powVal :: b, derivative :: a :-* (a :> b) } -- | Infinitely differentiable functions type a :~> b = a -> (a:>b) -- Handy for missing methods. noOv :: String -> a noOv op = error (op ++ ": not defined on a :> b") -- | Constant derivative tower. pureD :: (AdditiveGroup b, HasBasis a, HasTrie (Basis a)) => b -> a:>b pureD b = b `D` zeroV infixl 4 <$>> -- | Map a /linear/ function over a derivative tower. fmapD, (<$>>) :: HasTrie (Basis a) => (b -> c) -> (a :> b) -> (a :> c) fmapD f = lf where lf (D b0 b') = D (f b0) ((inLMap.liftL) lf b') (<$>>) = fmapD -- | Apply a /linear/ binary function over derivative towers. liftD2 :: (HasBasis a, HasTrie (Basis a), AdditiveGroup b, AdditiveGroup c) => (b -> c -> d) -> (a :> b) -> (a :> c) -> (a :> d) liftD2 f = lf where lf (D b0 b') (D c0 c') = D (f b0 c0) ((inLMap2.liftL2) lf b' c') -- | Apply a /linear/ ternary function over derivative towers. liftD3 :: (HasBasis a, HasTrie (Basis a) , AdditiveGroup b, AdditiveGroup c, AdditiveGroup d) => (b -> c -> d -> e) -> (a :> b) -> (a :> c) -> (a :> d) -> (a :> e) liftD3 f = lf where lf (D b0 b') (D c0 c') (D d0 d') = D (f b0 c0 d0) ((inLMap3.liftL3) lf b' c' d') -- TODO: Can liftD2 and liftD3 be defined in terms of a (<*>>) similar to -- (<*>)? If so, can the speed be as good? -- liftD2 f a b = (f <$>> a) <*>> b -- -- liftD3 f a b c = liftD2 f a b <*>> c -- | Differentiable identity function. Sometimes called "the -- derivation variable" or similar, but it's not really a variable. idD :: (VectorSpace u , HasBasis u, HasTrie (Basis u)) => u :~> u idD = linearD id -- or -- dId v = D v pureD -- | Every linear function has a constant derivative equal to the function -- itself (as a linear map). linearD :: (HasBasis u, HasTrie (Basis u), AdditiveGroup v) => (u -> v) -> (u :~> v) -- linearD f u = f u `D` linear (pureD . f) -- HEY! I think there's a hugely wasteful recomputation going on in -- 'linearD' above. Note the definition of 'linear': -- -- linear f = trie (f . basisValue) -- -- Substituting, -- -- linearD f u = f u `D` trie ((pureD . f) . basisValue) -- -- The trie gets rebuilt for each @u@. -- Look for similar problems. linearD f = \ u -> f u `D` d where d = linear (pureD . f) -- (`D` d) . f -- linearD f = (`D` linear (pureD . f)) . f -- Other examples of linear functions -- | Differentiable version of 'fst' fstD :: ( HasBasis a, HasTrie (Basis a) , HasBasis b, HasTrie (Basis b) , Scalar a ~ Scalar b ) => (a,b) :~> a fstD = linearD fst -- | Differentiable version of 'snd' sndD :: ( HasBasis a, HasTrie (Basis a) , HasBasis b, HasTrie (Basis b) , Scalar a ~ Scalar b ) => (a,b) :~> b sndD = linearD snd -- | Derivative tower for applying a binary function that distributes over -- addition, such as multiplication. A bit weaker assumption than -- bilinearity. Is bilinearity necessary for correctness here? distrib :: forall a b c u. (HasBasis a, HasTrie (Basis a) , AdditiveGroup u) => (b -> c -> u) -> (a :> b) -> (a :> c) -> (a :> u) distrib op = (#) where u@(D u0 u') # v@(D v0 v') = D (u0 `op` v0) ( (inLMap.liftMS) (inTrie ((# v) .)) u' ^+^ (inLMap.liftMS) (inTrie ((u #) .)) v' ) -- TODO: I think this distrib is exponential in increasing degree. Switch -- to the Horner representation. See /The Music of Streams/ by Doug -- McIlroy. -- instance Show b => Show (a :> b) where show = noOv "show" instance Show b => Show (a :> b) where show (D b0 _) = "D " ++ show b0 ++ " ..." instance Eq (a :> b) where (==) = noOv "(==)" type instance BooleanOf (a :> b) = BooleanOf b instance (AdditiveGroup v, HasBasis u, HasTrie (Basis u), IfB v) => IfB (u :> v) where ifB = liftD2 . ifB instance OrdB v => OrdB (u :> v) where (<*) = (<*) `on` powVal instance ( AdditiveGroup b, HasBasis a, HasTrie (Basis a) , OrdB b, IfB b, Ord b) => Ord (a :> b) where compare = compare `on` powVal min = minB max = maxB -- minB & maxB use ifB, and so can work even if b is an expression type, -- as in deep DSELs. instance (HasBasis a, HasTrie (Basis a), AdditiveGroup u) => AdditiveGroup (a :> u) where zeroV = pureD zeroV negateV = fmapD negateV D a0 a' ^+^ D b0 b' = D (a0 ^+^ b0) (a' ^+^ b') -- Less efficient: adds zero -- (^+^) = liftD2 (^+^) instance (HasBasis a, HasTrie (Basis a), VectorSpace u) => VectorSpace (a :> u) where type Scalar (a :> u) = (a :> Scalar u) (*^) = distrib (*^) instance ( InnerSpace u, s ~ Scalar u, AdditiveGroup s , HasBasis a, HasTrie (Basis a) ) => InnerSpace (a :> u) where (<.>) = distrib (<.>) -- infixr 9 @. -- -- | Chain rule. See also '(>-<)'. -- (@.) :: (HasTrie (Basis b), HasTrie (Basis a), VectorSpace c s) => -- (b :~> c) -> (a :~> b) -> (a :~> c) -- (h @. g) a0 = D c0 (inL2 (@.) c' b') -- where -- D b0 b' = g a0 -- D c0 c' = h b0 infix 0 >-< -- | Specialized chain rule. See also '(\@.)' (>-<) :: (HasBasis a, HasTrie (Basis a), VectorSpace u) => (u -> u) -> ((a :> u) -> (a :> Scalar u)) -> (a :> u) -> (a :> u) f >-< f' = \ u@(D u0 u') -> D (f u0) ((inLMap.liftMS) (f' u *^) u') -- TODO: express '(>-<)' in terms of '(@.)'. If I can't, then understand why not. instance ( HasBasis a, s ~ Scalar a, HasTrie (Basis a) , Num s, VectorSpace s, Scalar s ~ s ) => Num (a:>s) where fromInteger = pureD . fromInteger (+) = (^+^) (*) = distrib (*) negate = negate >-< -1 abs = abs >-< signum signum = signum >-< 0 -- derivative wrong at zero instance ( HasBasis a, s ~ Scalar a, HasTrie (Basis a) , Fractional s, VectorSpace s, Scalar s ~ s) => Fractional (a:>s) where fromRational = pureD . fromRational recip = recip >-< - recip sqr sqr :: Num a => a -> a sqr x = x*x instance ( HasBasis a, s ~ Scalar a, HasTrie (Basis a) , Floating s, VectorSpace s, Scalar s ~ s) => Floating (a:>s) where pi = pureD pi exp = exp >-< exp log = log >-< recip sqrt = sqrt >-< recip (2 * sqrt) sin = sin >-< cos cos = cos >-< - sin sinh = sinh >-< cosh cosh = cosh >-< sinh asin = asin >-< recip (sqrt (1-sqr)) acos = acos >-< recip (- sqrt (1-sqr)) atan = atan >-< recip (1+sqr) asinh = asinh >-< recip (sqrt (1+sqr)) acosh = acosh >-< recip (- sqrt (sqr-1)) atanh = atanh >-< recip (1-sqr) -- | Sample the derivative at a basis element. Optimized for partial -- application to save work for non-scalar derivatives. derivAtBasis :: (HasTrie (Basis a), HasBasis a, AdditiveGroup b) => (a :> b) -> (Basis a -> (a :> b)) derivAtBasis f = atBasis (derivative f) ---- Misc pairD :: (HasBasis a, HasTrie (Basis a), VectorSpace b, VectorSpace c) => (a:>b,a:>c) -> a:>(b,c) pairD (u,v) = liftD2 (,) u v unpairD :: HasTrie (Basis a) => (a :> (b,c)) -> (a:>b, a:>c) unpairD d = (fst <$>> d, snd <$>> d) tripleD :: ( HasBasis a, HasTrie (Basis a) , VectorSpace b, VectorSpace c, VectorSpace d ) => (a:>b,a:>c,a:>d) -> a:>(b,c,d) tripleD (u,v,w) = liftD3 (,,) u v w untripleD :: HasTrie (Basis a) => (a :> (b,c,d)) -> (a:>b, a:>c, a:>d) untripleD d = ((\ (a,_,_) -> a) <$>> d, (\ (_,b,_) -> b) <$>> d, (\ (_,_,c) -> c) <$>> d) vector-space-0.16/src/Data/LinearMap.hs0000644000000000000000000002306213421727005016071 0ustar0000000000000000{-# LANGUAGE TupleSections #-} {-# LANGUAGE CPP, TypeOperators, FlexibleContexts, TypeFamilies , GeneralizedNewtypeDeriving, StandaloneDeriving, UndecidableInstances #-} {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} ---------------------------------------------------------------------- -- | -- Module : Data.LinearMap -- Copyright : (c) Conal Elliott 2008-2016 -- License : BSD3 -- -- Maintainer : conal@conal.net -- Stability : experimental -- -- Linear maps ---------------------------------------------------------------------- module Data.LinearMap ( (:-*) , linear, lapply, atBasis, idL, (*.*) , inLMap, inLMap2, inLMap3 , liftMS, liftMS2, liftMS3 , liftL, liftL2, liftL3 , exlL, exrL, forkL, firstL, secondL , inlL, inrL, joinL -- , leftL, rightL ) where #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative (Applicative) #endif import Control.Applicative (liftA2, liftA3) import Control.Arrow (first,second) import Data.MemoTrie (HasTrie(..),(:->:)) import Data.AdditiveGroup (Sum(..), AdditiveGroup(..)) import Data.VectorSpace (VectorSpace(..)) import Data.Basis (HasBasis(..), linearCombo) -- Linear maps are almost but not quite a Control.Category. The type -- class constraints interfere. They're almost an Arrow also, but for the -- constraints and the generality of arr. -- | An optional additive value type MSum a = Maybe (Sum a) jsum :: a -> MSum a jsum = Just . Sum type LMap' u v = MSum (Basis u :->: v) infixr 1 :-* -- | Linear map, represented as an optional memo-trie from basis to -- values, where 'Nothing' means the zero map (an optimization). newtype u :-* v = LMap { unLMap :: LMap' u v } deriving instance (HasTrie (Basis u), AdditiveGroup v) => AdditiveGroup (u :-* v) instance (HasTrie (Basis u), VectorSpace v) => VectorSpace (u :-* v) where type Scalar (u :-* v) = Scalar v (*^) s = (inLMap.liftMS.fmap) (s *^) -- In GHC 7.10: -- Constraint is no smaller than the instance head -- in the constraint: HasTrie (Basis u) -- (Use UndecidableInstances to permit this) exlL :: ( HasBasis a, HasTrie (Basis a), HasBasis b, HasTrie (Basis b) , Scalar a ~ Scalar b ) => (a,b) :-* a exlL = linear fst exrL :: ( HasBasis a, HasTrie (Basis a), HasBasis b, HasTrie (Basis b) , Scalar a ~ Scalar b ) => (a,b) :-* b exrL = linear snd forkL :: (HasTrie (Basis a), HasBasis c, HasBasis d) => (a :-* c) -> (a :-* d) -> (a :-* (c,d)) forkL = (inLMap2.liftL2) (,) firstL :: ( HasBasis u, HasBasis u', HasBasis v , HasTrie (Basis u), HasTrie (Basis v) , Scalar u ~ Scalar v, Scalar u ~ Scalar u' ) => (u :-* u') -> ((u,v) :-* (u',v)) firstL = linear.first.lapply secondL :: ( HasBasis u, HasBasis v, HasBasis v' , HasTrie (Basis u), HasTrie (Basis v) , Scalar u ~ Scalar v, Scalar u ~ Scalar v' ) => (v :-* v') -> ((u,v) :-* (u,v')) secondL = linear.second.lapply -- TODO: more efficient firstL -- liftMS :: (AdditiveGroup a) => (a -> b) -> (MSum a -> MSum b) -- (s *^) :: v -> v -- fmap (s *^) :: (Basis u :->: v) -> (Basis u :->: v) -- (liftMS.fmap) (s *^) :: LMap' u v -> LMap' u v -- (inLMap.liftMS.fmap) (s *^) :: (u :-* v) -> (u :-* v) inlL :: (HasBasis a, HasTrie (Basis a), HasBasis b) => a :-* (a,b) inlL = linear (,zeroV) inrL :: (HasBasis a, HasBasis b, HasTrie (Basis b)) => b :-* (a,b) inrL = linear (zeroV,) joinL :: ( HasBasis a, HasTrie (Basis a) , HasBasis b, HasTrie (Basis b) , Scalar a ~ Scalar b, Scalar a ~ Scalar c , VectorSpace c ) => (a :-* c) -> (b :-* c) -> ((a,b) :-* c) f `joinL` g = linear (\ (a,b) -> lapply f a ^+^ lapply g b) -- Before version 0.7, u :-* v was a type synonym, resulting in a subtle -- ambiguity: u:-*v == u':-*v' does not imply that u==u', since Basis -- might map different types to the same basis (e.g., Float & Double). -- See . -- See also . -- TODO: Try a partial trie instead, excluding (known) zero elements. -- Then 'lapply' could be much faster for sparse situations. Make sure to -- correctly sum them. It'd be more like Jason Foutz's formulation -- -- which uses in @IntMap@. -- | Function (assumed linear) as linear map. linear :: (HasBasis u, HasTrie (Basis u)) => (u -> v) -> (u :-* v) linear f = LMap (jsum (trie (f . basisValue))) atZ :: AdditiveGroup b => (a -> b) -> (MSum a -> b) atZ f = maybe zeroV (f . getSum) -- atZ :: AdditiveGroup b => (a -> b) -> (a -> b) -- atZ = id inLMap :: (LMap' r s -> LMap' t u) -> ((r :-* s) -> (t :-* u)) inLMap = unLMap ~> LMap inLMap2 :: (LMap' r s -> LMap' t u -> LMap' v w) -> ((r :-* s) -> (t :-* u) -> (v :-* w)) inLMap2 = unLMap ~> inLMap inLMap3 :: (LMap' r s -> LMap' t u -> LMap' v w -> LMap' x y) -> ((r :-* s) -> (t :-* u) -> (v :-* w) -> (x :-* y)) inLMap3 = unLMap ~> inLMap2 -- | Apply a linear map to a vector. lapply :: ( VectorSpace v, Scalar u ~ Scalar v , HasBasis u, HasTrie (Basis u) ) => (u :-* v) -> (u -> v) lapply = atZ lapply' . unLMap -- | Evaluate a linear map on a basis element. atBasis :: (AdditiveGroup v, HasTrie (Basis u)) => (u :-* v) -> Basis u -> v LMap m `atBasis` b = atZ (`untrie` b) m -- | Handy for 'lapply' and '(*.*)'. lapply' :: ( VectorSpace v, Scalar u ~ Scalar v , HasBasis u, HasTrie (Basis u) ) => (Basis u :->: v) -> (u -> v) lapply' tr = linearCombo . fmap (first (untrie tr)) . decompose -- | Identity linear map idL :: (HasBasis u, HasTrie (Basis u)) => u :-* u idL = linear id infixr 9 *.* -- | Compose linear maps (*.*) :: ( HasTrie (Basis u) , HasBasis v, HasTrie (Basis v) , VectorSpace w , Scalar v ~ Scalar w ) => (v :-* w) -> (u :-* v) -> (u :-* w) -- Simple definition, but only optimizes out uv == zero -- vw *.* uv = LMap ((fmap.fmap.fmap) (lapply vw) (unLMap uv)) (*.*) vw = (inLMap.fmap.fmap.fmap) (lapply vw) -- Eep: -- (*.*) = inLMap.fmap.fmap.fmap.lapply -- Instead, use Nothing/zero if /either/ map is zeroV (exploiting linearity -- when uv == zeroV.) -- LMap Nothing *.* _ = LMap Nothing -- _ *.* LMap Nothing = LMap Nothing -- LMap (Just (Sum vw)) *.* LMap (Just (Sum uv)) = LMap (Just (Sum (lapply' vw <$> uv))) -- (*.*) = liftA2 (\ (LMap (Sum vw)) (LMap (Sum uv)) -> LMap (Sum (lapply' vw <$> uv))) -- (*.*) = (liftA2.inSum2.inLMap2) (\ vw uv -> lapply' vw <$> uv) -- (*.*) = (liftA2.inSum2.inLMap2) (\ vw -> fmap (lapply' vw)) -- (*.*) = (liftA2.inSum2.inLMap2) (fmap . lapply') -- It may be helpful that @lapply vw@ is evaluated just once and not -- once per uv. 'untrie' can strip off all of its trie constructors. -- Less efficient definition: -- -- vw `compL` uv = linear (lapply vw . lapply uv) -- -- i.e., compL = inL2 (.) -- -- The problem with these definitions is that basis elements get converted -- to values and then decomposed, followed by recombination of the -- results. liftMS :: (a -> b) -> (MSum a -> MSum b) -- liftMS _ Nothing = Nothing -- liftMS h ma = Just (Sum (h (z ma))) liftMS = fmap.fmap liftMS2 :: (AdditiveGroup a, AdditiveGroup b) => (a -> b -> c) -> (MSum a -> MSum b -> MSum c) liftMS2 _ Nothing Nothing = Nothing liftMS2 h ma mb = Just (Sum (h (fromMS ma) (fromMS mb))) liftMS3 :: (AdditiveGroup a, AdditiveGroup b, AdditiveGroup c) => (a -> b -> c -> d) -> (MSum a -> MSum b -> MSum c -> MSum d) liftMS3 _ Nothing Nothing Nothing = Nothing liftMS3 h ma mb mc = Just (Sum (h (fromMS ma) (fromMS mb) (fromMS mc))) fromMS :: AdditiveGroup u => MSum u -> u fromMS Nothing = zeroV fromMS (Just (Sum u)) = u -- | Apply a linear function to each element of a linear map. -- @liftL f l == linear f *.* l@, but works more efficiently. liftL :: Functor f => (a -> b) -> MSum (f a) -> MSum (f b) liftL = liftMS . fmap -- | Apply a linear binary function (not to be confused with a bilinear -- function) to each element of a linear map. liftL2 :: (Applicative f, AdditiveGroup (f a), AdditiveGroup (f b)) => (a -> b -> c) -> (MSum (f a) -> MSum (f b) -> MSum (f c)) liftL2 = liftMS2 . liftA2 -- | Apply a linear ternary function (not to be confused with a trilinear -- function) to each element of a linear map. liftL3 :: ( Applicative f , AdditiveGroup (f a), AdditiveGroup (f b), AdditiveGroup (f c)) => (a -> b -> c -> d) -> (MSum (f a) -> MSum (f b) -> MSum (f c) -> MSum (f d)) liftL3 = liftMS3 . liftA3 {- infixr 9 *.* -- | Compose linear maps (*.*) :: ( HasBasis u, HasTrie (Basis u) , HasBasis v, HasTrie (Basis v) , VectorSpace w , Scalar v ~ Scalar w ) => (v :-* w) -> (u :-* v) -> (u :-* w) -- Simple definition, but only optimizes out uv == zero -- -- (*.*) vw = (fmap.fmap) (lapply vw) -- Instead, use Nothing/zero if /either/ map is zeroV (exploiting linearity -- when uv == zeroV.) -- Nothing *.* _ = Nothing -- _ *.* Nothing = Nothing -- Just (Sum vw) *.* Just (Sum uv) = Just (Sum (lapply' vw <$> uv)) -- (*.*) = liftA2 (\ (Sum vw) (Sum uv) -> Sum (lapply' vw <$> uv)) -- (*.*) = (liftA2.inSum2) (\ vw uv -> lapply' vw <$> uv) (*.*) = (liftA2.inSum2) (\ vw uv -> lapply' vw <$> uv) -- (*.*) = (liftA2.inSum2) (\ vw -> fmap (lapply' vw)) -- (*.*) = (liftA2.inSum2) (fmap . lapply') -} ----- (~>) :: (a' -> a) -> (b -> b') -> ((a -> b) -> (a' -> b')) (f ~> h) g = h . g . f vector-space-0.16/src/Data/Cross.hs0000644000000000000000000000655013421727005015315 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeOperators , TypeFamilies, TypeSynonymInstances , UndecidableInstances #-} {-# OPTIONS_GHC -Wall #-} ---------------------------------------------------------------------- -- | -- Module : Data.Cross -- Copyright : (c) Conal Elliott 2008 -- License : BSD3 -- -- Maintainer : conal@conal.net -- Stability : experimental -- -- Cross products and normals ---------------------------------------------------------------------- module Data.Cross ( HasNormal(..), normal , One, Two, Three , HasCross2(..), HasCross3(..) ) where import Data.VectorSpace import Data.MemoTrie import Data.Basis import Data.Derivative -- | Thing with a normal vector (not necessarily normalized). class HasNormal v where normalVec :: v -> v -- | Normalized normal vector. See also 'cross'. normal :: (HasNormal v, InnerSpace v, Floating (Scalar v)) => v -> v normal = normalized . normalVec -- | Singleton type One s = s -- | Homogeneous pair type Two s = (s,s) -- | Homogeneous triple type Three s = (s,s,s) -- | Cross product of various forms of 2D vectors class HasCross2 v where cross2 :: v -> v instance AdditiveGroup u => HasCross2 (u,u) where cross2 (x,y) = (negateV y,x) -- or @(y,-x)@? instance (HasTrie (Basis a), HasCross2 v) => HasCross2 (a:>v) where -- 2d cross-product is linear cross2 = fmapD cross2 instance (HasBasis s, HasTrie (Basis s), Basis s ~ ()) => HasNormal (One s :> Two s) where normalVec v = cross2 (v `derivAtBasis` ()) -- When I use atBasis (from LinearMap) instead of the more liberally-typed -- atB (below), I get a type error: -- -- Couldn't match expected type `Basis a1' against inferred type `()' -- Expected type: a1 :-* (s :> Two s) -- Inferred type: s :-* (s :> Two s) -- In the first argument of `atB', namely `derivative v' -- -- I think this type error is a GHC bug, but I'm not sure. -- atB :: (AdditiveGroup b, HasTrie a) => Maybe (a :->: b) -> a -> b -- -- atB :: (AdditiveGroup b, HasBasis a, HasTrie (Basis a)) => -- -- Maybe (Basis a :->: b) -> Basis a -> b -- l `atB` b = maybe zeroV (`untrie` b) l instance (VectorSpace s, HasBasis s, HasTrie (Basis s), Basis s ~ ()) => HasNormal (Two (One s :> s)) where normalVec = unpairD . normalVec . pairD -- I don't know why I can't eliminate the @HasTrie (Basis s)@ constraints -- above, considering @Basis s ~ ()@ and @HasTrie ()@. -- | Cross product of various forms of 3D vectors class HasCross3 v where cross3 :: v -> v -> v instance Num s => HasCross3 (s,s,s) where (ax,ay,az) `cross3` (bx,by,bz) = ( ay * bz - az * by , az * bx - ax * bz , ax * by - ay * bx ) -- TODO: Eliminate the 'Num' constraint by using 'VectorSpace' operations. instance (HasBasis a, HasTrie (Basis a), VectorSpace v, HasCross3 v) => HasCross3 (a:>v) where -- 3D cross-product is bilinear (curried linear) cross3 = distrib cross3 instance (Num s, HasTrie (Basis (s, s)), HasBasis s, Basis s ~ ()) => HasNormal (Two s :> Three s) where normalVec v = d (Left ()) `cross3` d (Right ()) where d = derivAtBasis v instance ( VectorSpace s, HasBasis s, HasTrie (Basis s) , HasNormal (Two s :> Three s) ) => HasNormal (Three (Two s :> s)) where normalVec = untripleD . normalVec . tripleD vector-space-0.16/src/Data/Basis.hs0000644000000000000000000001315513421727005015264 0ustar0000000000000000{-# LANGUAGE TypeOperators, TypeFamilies, UndecidableInstances , FlexibleInstances, MultiParamTypeClasses, CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} ---------------------------------------------------------------------- -- | -- Module : Data.Basis -- Copyright : (c) Conal Elliott 2008 -- License : BSD3 -- -- Maintainer : conal@conal.net -- Stability : experimental -- -- Basis of a vector space, as an associated type -- This module requires ghc-6.10 or later ---------------------------------------------------------------------- module Data.Basis (HasBasis(..), linearCombo, recompose) where -- import Control.Applicative ((<$>)) import Control.Arrow (first) import Data.Ratio import Foreign.C.Types (CFloat, CDouble) -- import Data.Either import Data.VectorSpace import Data.VectorSpace.Generic import qualified GHC.Generics as Gnrx import GHC.Generics (Generic, (:*:)(..)) -- using associated data type instead of associated type synonym to work -- around ghc bug class VectorSpace v => HasBasis v where -- | Representation of the canonical basis for @v@ type Basis v :: * type Basis v = Basis (VRep v) -- | Interpret basis rep as a vector basisValue :: Basis v -> v default basisValue :: (Generic v, HasBasis (VRep v), Basis (VRep v) ~ Basis v) => Basis v -> v basisValue b = Gnrx.to (basisValue b :: VRep v) -- | Extract coordinates decompose :: v -> [(Basis v, Scalar v)] default decompose :: ( Generic v, HasBasis (VRep v) , Scalar (VRep v) ~ Scalar v, Basis (VRep v) ~ Basis v ) => v -> [(Basis v, Scalar v)] decompose v = decompose (Gnrx.from v :: VRep v) -- | Experimental version. More elegant definitions, and friendly to -- infinite-dimensional vector spaces. decompose' :: v -> (Basis v -> Scalar v) default decompose' :: ( Generic v, HasBasis (VRep v) , Scalar (VRep v) ~ Scalar v, Basis (VRep v) ~ Basis v ) => v -> Basis v -> Scalar v decompose' v = decompose' (Gnrx.from v :: VRep v) -- Defining property: recompose . decompose == id -- Turn a basis decomposition back into a vector. recompose :: HasBasis v => [(Basis v, Scalar v)] -> v recompose = linearCombo . fmap (first basisValue) -- recompose ps = linearCombo (first basisValue <$> ps) -- I don't know how to define -- -- recompose' :: HasBasis v => (Basis v -> Scalar v) -> v -- -- However, I don't seem to use recompose anywhere. -- I don't even use basisValue or decompose. #define ScalarTypeCon(con,t) \ instance con => HasBasis (t) where \ { type Basis (t) = () \ ; basisValue () = 1 \ ; decompose s = [((),s)] \ ; decompose' s = const s } #define ScalarType(t) ScalarTypeCon((),t) ScalarType(Float) ScalarType(CFloat) ScalarType(Double) ScalarType(CDouble) ScalarTypeCon(Integral a, Ratio a) instance ( HasBasis u, s ~ Scalar u , HasBasis v, s ~ Scalar v ) => HasBasis (u,v) where type Basis (u,v) = Basis u `Either` Basis v basisValue (Left a) = (basisValue a, zeroV) basisValue (Right b) = (zeroV, basisValue b) decompose (u,v) = decomp2 Left u ++ decomp2 Right v decompose' (u,v) = decompose' u `either` decompose' v decomp2 :: HasBasis w => (Basis w -> b) -> w -> [(b, Scalar w)] decomp2 inject = fmap (first inject) . decompose instance ( HasBasis u, s ~ Scalar u , HasBasis v, s ~ Scalar v , HasBasis w, s ~ Scalar w ) => HasBasis (u,v,w) where type Basis (u,v,w) = Basis (u,(v,w)) basisValue = unnest3 . basisValue decompose = decompose . nest3 decompose' = decompose' . nest3 unnest3 :: (a,(b,c)) -> (a,b,c) unnest3 (a,(b,c)) = (a,b,c) nest3 :: (a,b,c) -> (a,(b,c)) nest3 (a,b,c) = (a,(b,c)) -- instance (Eq a, HasBasis u) => HasBasis (a -> u) where -- type Basis (a -> u) = (a, Basis u) -- basisValue (a,b) = f -- where f a' | a == a' = bv -- | otherwise = zeroV -- bv = basisValue b -- decompose = error "decompose: not defined on functions" -- decompose' g (a,b) = decompose' (g a) b -- Simpler but less efficient: -- -- basisValue (a,b) a' | a == a' = basisValue b -- | otherwise = zeroV -- Just for pointless perversion points: -- -- decompose' g = uncurry (\ a b -> decompose' (g a) b) -- decompose' g = uncurry (\ a -> decompose' (g a)) -- decompose' g = uncurry (decompose' . g) -- decompose' = uncurry . fmap decompose' -- decompose' = (fmap uncurry) (fmap decompose') {- ---- Testing t1 = basisValue () :: Float t2 = basisValue () :: Double t3 = basisValue (Right ()) :: (Float,Double) t4 = basisValue (Right (Left ())) :: (Float,Double,Float) -} instance HasBasis a => HasBasis (Gnrx.Rec0 a s) where type Basis (Gnrx.Rec0 a s) = Basis a basisValue = Gnrx.K1 . basisValue decompose = decompose . Gnrx.unK1 decompose' = decompose' . Gnrx.unK1 instance HasBasis (f p) => HasBasis (Gnrx.M1 i c f p) where type Basis (Gnrx.M1 i c f p) = Basis (f p) basisValue = Gnrx.M1 . basisValue decompose = decompose . Gnrx.unM1 decompose' = decompose' . Gnrx.unM1 instance (HasBasis (f p), HasBasis (g p), Scalar (f p) ~ Scalar (g p)) => HasBasis ((f :*: g) p) where type Basis ((f:*:g) p) = Either (Basis (f p)) (Basis (g p)) basisValue (Left bf) = basisValue bf :*: zeroV basisValue (Right bg) = zeroV :*: basisValue bg decompose (u:*:v) = decomp2 Left u ++ decomp2 Right v decompose' (u:*:v) = decompose' u `either` decompose' v vector-space-0.16/src/Data/VectorSpace/0000755000000000000000000000000013421727005016100 5ustar0000000000000000vector-space-0.16/src/Data/VectorSpace/Generic.hs0000644000000000000000000000071713421727005020015 0ustar0000000000000000-- | -- Module : Data.VectorSpace.Generic -- Copyright : (c) Conal Elliott and Justus Sagemüller 2017 -- License : BSD3 -- -- Maintainer : conal@conal.net, (@) jsagemue $ uni-koeln.de -- Stability : experimental -- -- Underpinnings of the type that represents vector / affine / etc. spaces -- with GHC generics module Data.VectorSpace.Generic where import qualified GHC.Generics as Gnrx import Data.Void type VRep v = Gnrx.Rep v Void