vector-space 0.5.3 → 0.5.6
raw patch · 7 files changed
+300/−102 lines, 7 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Data.LinearMap: compL :: (HasBasis u, HasTrie (Basis u), HasBasis v, HasTrie (Basis v), VectorSpace w, (Scalar v) ~ (Scalar w)) => (v :-* w) -> (u :-* v) -> (u :-* w)
- Data.Maclaurin: instance (HasBasis a, HasTrie (Basis a), VectorSpace u) => VectorSpace (a :> u)
+ Data.AdditiveGroup: getSum :: Sum a -> a
+ Data.AdditiveGroup: inSum :: (a -> b) -> (Sum a -> Sum b)
+ Data.AdditiveGroup: inSum2 :: (a -> b -> c) -> (Sum a -> Sum b -> Sum c)
+ Data.AdditiveGroup: instance (AdditiveGroup a) => AdditiveGroup (Sum a)
+ Data.AdditiveGroup: instance (AdditiveGroup u, AdditiveGroup v, AdditiveGroup w, AdditiveGroup x) => AdditiveGroup (u, v, w, x)
+ Data.AdditiveGroup: instance AdditiveGroup Int
+ Data.AdditiveGroup: instance AdditiveGroup Integer
+ Data.LinearMap: (*.*) :: (HasBasis u, HasTrie (Basis u), HasBasis v, HasTrie (Basis v), VectorSpace w, (Scalar v) ~ (Scalar w)) => (v :-* w) -> (u :-* v) -> (u :-* w)
+ Data.LinearMap: atBasis :: (HasTrie a, AdditiveGroup b) => MSum (a :->: b) -> a -> b
+ Data.LinearMap: liftL :: (Functor f, AdditiveGroup (f a)) => (a -> b) -> MSum (f a) -> MSum (f b)
+ Data.LinearMap: liftL2 :: (Applicative f, AdditiveGroup (f a), AdditiveGroup (f b)) => (a -> b -> c) -> (MSum (f a) -> MSum (f b) -> MSum (f c))
+ Data.LinearMap: 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))
+ Data.LinearMap: liftMS :: (AdditiveGroup a) => (a -> b) -> (MSum a -> MSum b)
+ Data.LinearMap: liftMS2 :: (AdditiveGroup a, AdditiveGroup b) => (a -> b -> c) -> (MSum a -> MSum b -> MSum c)
+ Data.LinearMap: liftMS3 :: (AdditiveGroup a, AdditiveGroup b, AdditiveGroup c) => (a -> b -> c -> d) -> (MSum a -> MSum b -> MSum c -> MSum d)
+ Data.Maclaurin: D :: b -> a :-* (a :> b) -> :> a b
+ Data.Maclaurin: derivAtBasis :: (HasTrie (Basis a), HasBasis a, AdditiveGroup b) => (a :> b) -> (Basis a -> (a :> b))
+ Data.Maclaurin: instance (HasBasis a, HasTrie (Basis a), VectorSpace u, AdditiveGroup (Scalar u)) => VectorSpace (a :> u)
+ Data.Maclaurin: pairD :: (HasBasis a, HasTrie (Basis a), VectorSpace b, VectorSpace c, (Scalar b) ~ (Scalar c)) => (a :> b, a :> c) -> a :> (b, c)
+ Data.Maclaurin: tripleD :: (HasBasis a, HasTrie (Basis a), VectorSpace b, VectorSpace c, VectorSpace d, (Scalar b) ~ (Scalar c), (Scalar c) ~ (Scalar d)) => (a :> b, a :> c, a :> d) -> a :> (b, c, d)
+ Data.Maclaurin: unpairD :: (HasBasis a, HasTrie (Basis a), VectorSpace a, VectorSpace b, VectorSpace c, (Scalar b) ~ (Scalar c)) => (a :> (b, c)) -> (a :> b, a :> c)
+ Data.Maclaurin: untripleD :: (HasBasis a, HasTrie (Basis a), VectorSpace a, VectorSpace b, VectorSpace c, VectorSpace d, (Scalar b) ~ (Scalar c), (Scalar c) ~ (Scalar d)) => (a :> (b, c, d)) -> (a :> b, a :> c, a :> d)
+ Data.VectorSpace: instance (s ~ Scalar u, s ~ Scalar v, s ~ Scalar w, s ~ Scalar x, InnerSpace u, InnerSpace v, InnerSpace w, InnerSpace x, AdditiveGroup s) => InnerSpace (u, v, w, x)
+ Data.VectorSpace: instance (s ~ Scalar u, s ~ Scalar v, s ~ Scalar w, s ~ Scalar x, VectorSpace u, VectorSpace v, VectorSpace w, VectorSpace x) => VectorSpace (u, v, w, x)
- Data.LinearMap: type :-* u v = Basis u :->: v
+ Data.LinearMap: type :-* u v = MSum (Basis u :->: v)
- Data.Maclaurin: (<$>>) :: (HasTrie (Basis a)) => (b -> c) -> (a :> b) -> (a :> c)
+ Data.Maclaurin: (<$>>) :: (HasBasis a, HasTrie (Basis a), AdditiveGroup b) => (b -> c) -> (a :> b) -> (a :> c)
- Data.Maclaurin: (>-<) :: (HasBasis a, HasTrie (Basis a), VectorSpace u) => (u -> u) -> ((a :> u) -> (a :> Scalar u)) -> (a :> u) -> (a :> u)
+ Data.Maclaurin: (>-<) :: (HasBasis a, HasTrie (Basis a), VectorSpace u, AdditiveGroup (Scalar u)) => (u -> u) -> ((a :> u) -> (a :> Scalar u)) -> (a :> u) -> (a :> u)
- Data.Maclaurin: distrib :: (HasBasis a, HasTrie (Basis a), AdditiveGroup u) => (b -> c -> u) -> (a :> b) -> (a :> c) -> (a :> u)
+ Data.Maclaurin: distrib :: (HasBasis a, HasTrie (Basis a), AdditiveGroup b, AdditiveGroup c, AdditiveGroup u) => (b -> c -> u) -> (a :> b) -> (a :> c) -> (a :> u)
- Data.Maclaurin: fmapD :: (HasTrie (Basis a)) => (b -> c) -> (a :> b) -> (a :> c)
+ Data.Maclaurin: fmapD :: (HasBasis a, HasTrie (Basis a), AdditiveGroup b) => (b -> c) -> (a :> b) -> (a :> c)
- Data.Maclaurin: liftD2 :: (HasTrie (Basis a)) => (b -> c -> d) -> (a :> b) -> (a :> c) -> (a :> d)
+ Data.Maclaurin: liftD2 :: (HasBasis a, HasTrie (Basis a), AdditiveGroup b, AdditiveGroup c) => (b -> c -> d) -> (a :> b) -> (a :> c) -> (a :> d)
- Data.Maclaurin: liftD3 :: (HasTrie (Basis a)) => (b -> c -> d -> e) -> (a :> b) -> (a :> c) -> (a :> d) -> (a :> e)
+ Data.Maclaurin: liftD3 :: (HasBasis a, HasTrie (Basis a), AdditiveGroup b, AdditiveGroup c, AdditiveGroup d) => (b -> c -> d -> e) -> (a :> b) -> (a :> c) -> (a :> d) -> (a :> e)
Files
- src/Data/AdditiveGroup.hs +51/−12
- src/Data/Basis.hs +3/−0
- src/Data/Cross.hs +18/−33
- src/Data/LinearMap.hs +128/−14
- src/Data/Maclaurin.hs +81/−39
- src/Data/VectorSpace.hs +18/−3
- vector-space.cabal +1/−1
src/Data/AdditiveGroup.hs view
@@ -13,7 +13,8 @@ module Data.AdditiveGroup ( - AdditiveGroup(..), (^-^), sumV, Sum(..)+ AdditiveGroup(..), (^-^), sumV+ , Sum(..), inSum, inSum2 ) where import Control.Applicative@@ -47,16 +48,16 @@ () ^+^ () = () negateV = id -instance AdditiveGroup Double where- zeroV = 0.0- (^+^) = (+)- negateV = negate+-- For 'Num' types:+-- +-- instance AdditiveGroup n where {zeroV=0; (^+^) = (+); negateV = negate} -instance AdditiveGroup Float where- zeroV = 0.0- (^+^) = (+)- negateV = negate+instance AdditiveGroup Int where {zeroV=0; (^+^) = (+); negateV = negate}+instance AdditiveGroup Integer where {zeroV=0; (^+^) = (+); negateV = negate}+instance AdditiveGroup Float where {zeroV=0; (^+^) = (+); negateV = negate}+instance AdditiveGroup Double where {zeroV=0; (^+^) = (+); negateV = negate} + instance (RealFloat v, AdditiveGroup v) => AdditiveGroup (Complex v) where zeroV = zeroV :+ zeroV (^+^) = (+)@@ -77,7 +78,13 @@ (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@@ -103,17 +110,49 @@ -- | Monoid under group addition. Alternative to the @Sum@ in -- "Data.Monoid", which uses 'Num' instead of 'AdditiveGroup'.-newtype Sum a = Sum a+newtype Sum a = Sum { getSum :: a } deriving (Eq, Ord, Read, Show, Bounded) instance Functor Sum where fmap f (Sum a) = Sum (f a) +-- instance Applicative Sum where+-- pure a = Sum a+-- Sum f <*> Sum x = Sum (f x)+ instance Applicative Sum where- pure a = Sum a- Sum f <*> Sum x = Sum (f x)+ pure = Sum+ (<*>) = inSum2 ($) instance AdditiveGroup a => Monoid (Sum a) where mempty = Sum zeroV mappend = liftA2 (^+^) ++-- | Application a unary function inside a 'Sum'+inSum :: (a -> b) -> (Sum a -> Sum b)+inSum = getSum ~> Sum++-- | Application a binary function inside a 'Sum'+inSum2 :: (a -> b -> c) -> (Sum a -> Sum b -> Sum c)+inSum2 = getSum ~> inSum+++instance AdditiveGroup a => AdditiveGroup (Sum a) where+ zeroV = mempty+ (^+^) = mappend+ negateV = inSum negateV+++---- to go elsewhere++(~>) :: (a' -> a) -> (b -> b') -> ((a -> b) -> (a' -> b'))+(i ~> o) f = o . f . i++-- result :: (b -> b') -> ((a -> b) -> (a -> b'))+-- result = (.)++-- argument :: (a' -> a) -> ((a -> b) -> (a' -> b))+-- argument = flip (.)++-- g ~> f = result g . argument f
src/Data/Basis.hs view
@@ -27,6 +27,9 @@ import Data.VectorSpace +-- using associated data type instead of associated type synonym to work+-- around ghc bug <http://hackage.haskell.org/trac/ghc/ticket/3038>+ class VectorSpace v => HasBasis v where -- | Representation of the canonical basis for @v@ type Basis v :: *
src/Data/Cross.hs view
@@ -25,9 +25,7 @@ import Data.MemoTrie import Data.Basis --- import Data.LinearMap import Data.Derivative--- import Data.Maclaurin -- | Thing with a normal vector (not necessarily normalized). class HasNormal v where normalVec :: v -> v@@ -58,8 +56,24 @@ instance (HasBasis s, HasTrie (Basis s), Basis s ~ ()) => HasNormal (One s :> Two s) where- normalVec v = cross2 (derivative v `untrie` ())+ 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 ( Num s, VectorSpace s , HasBasis s, HasTrie (Basis s), Basis s ~ ()) => HasNormal (Two (One s :> s)) where@@ -86,38 +100,9 @@ HasNormal (Two s :> Three s) where normalVec v = d (Left ()) `cross3` d (Right ()) where- d = untrie (derivative v)+ d = derivAtBasis v instance ( Num s, VectorSpace s, HasBasis s, HasTrie (Basis s) , HasNormal (Two s :> Three s)) => HasNormal (Three (Two s :> s)) where normalVec = untripleD . normalVec . tripleD------- Could go elsewhere--pairD :: ( HasBasis a, HasTrie (Basis a)- , VectorSpace b, VectorSpace c- , Scalar b ~ Scalar c- ) => (a:>b,a:>c) -> a:>(b,c)-pairD (u,v) = liftD2 (,) u v--tripleD :: ( HasBasis a, HasTrie (Basis a)- , VectorSpace b, VectorSpace c, VectorSpace d- , Scalar b ~ Scalar c, Scalar c ~ Scalar d- ) => (a:>b,a:>c,a:>d) -> a:>(b,c,d)-tripleD (u,v,w) = liftD3 (,,) u v w--unpairD :: ( HasBasis a, HasTrie (Basis a)- , VectorSpace a, VectorSpace b, VectorSpace c- , Scalar b ~ Scalar c- ) => (a :> (b,c)) -> (a:>b, a:>c)-unpairD d = (fst <$>> d, snd <$>> d)--untripleD :: ( HasBasis a, HasTrie (Basis a)- , VectorSpace a, VectorSpace b, VectorSpace c, VectorSpace d- , Scalar b ~ Scalar c, Scalar c ~ Scalar d- ) =>- (a :> (b,c,d)) -> (a:>b, a:>c, a:>d)-untripleD d =- ((\ (a,_,_) -> a) <$>> d, (\ (_,b,_) -> b) <$>> d, (\ (_,_,c) -> c) <$>> d)
src/Data/LinearMap.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeOperators, FlexibleContexts, TypeFamilies, CPP #-}+{-# LANGUAGE TypeOperators, FlexibleContexts, TypeFamilies #-} {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} -- {-# OPTIONS_GHC -funbox-strict-fields #-} -- {-# OPTIONS_GHC -ddump-simpl-stats -ddump-simpl #-}@@ -15,51 +15,119 @@ ---------------------------------------------------------------------- module Data.LinearMap- ( (:-*) , linear, lapply, idL, compL+ ( (:-*) , linear, lapply, atBasis, idL, (*.*)+ , liftMS, liftMS2, liftMS3+ , liftL, liftL2, liftL3 ) where -import Control.Arrow (first)+import Control.Applicative ((<$>),Applicative,liftA2,liftA3)+import Control.Arrow (first) -import Data.MemoTrie ((:->:)(..))-import Data.VectorSpace (VectorSpace(..))-import Data.Basis (HasBasis(..), linearCombo)+import Data.MemoTrie ((:->:)(..))+import Data.AdditiveGroup (Sum(..),inSum2, 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. --- | Linear map, represented as a memo-trie from basis to values.-type u :-* v = Basis u :->: v+-- | An optional additive value+type MSum a = Maybe (Sum a) +-- nsum :: MSum a+-- nsum = Nothing --- TODO: Use a regular function from @Basis u@, but memoize it.+jsum :: a -> MSum a+jsum = Just . Sum +-- | Linear map, represented as an optional memo-trie from basis to+-- values, where 'Nothing' means the zero map (an optimization).+type u :-* v = MSum (Basis u :->: v)++-- 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+-- <http://metavar.blogspot.com/2008/02/higher-order-multivariate-automatic.html>+-- which uses in @IntMap@.+++-- PROBLEM: u :-* v is a type synonym, and Basis is an associated 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 <http://hackage.haskell.org/trac/ghc/ticket/1897>+-- +-- Work in progress. See NewLinearMap.hs++ -- | Function (assumed linear) as linear map. linear :: (HasBasis u, HasTrie (Basis u)) => (u -> v) -> (u :-* v)-linear f = trie (f . basisValue)+linear f = 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++-- | Evaluate a linear map on a basis element. I've loosened the type to+-- work around a typing problem in 'derivAtBasis'.+-- atBasis :: (AdditiveGroup v, HasTrie (Basis u)) =>+-- (u :-* v) -> Basis u -> v+atBasis :: (HasTrie a, AdditiveGroup b) => MSum (a :->: b) -> a -> b+m `atBasis` b = atZ (`untrie` b) m+ -- | Apply a linear map to a vector. lapply :: ( VectorSpace v, Scalar u ~ Scalar v , HasBasis u, HasTrie (Basis u) ) => (u :-* v) -> (u -> v)-lapply tr = linearCombo . fmap (first (untrie tr)) . decompose+lapply = atZ lapply' +-- 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-compL :: ( HasBasis u, HasTrie (Basis u)+(*.*) :: ( HasBasis u, HasTrie (Basis u) , HasBasis v, HasTrie (Basis v)- , VectorSpace w, Scalar v ~ Scalar w ) =>+ , VectorSpace w+ , Scalar v ~ Scalar w ) => (v :-* w) -> (u :-* v) -> (u :-* w) -compL vw = fmap (lapply vw)+-- 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')++ -- 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. @@ -72,3 +140,49 @@ -- The problem with these definitions is that basis elements get converted -- to values and then decomposed, followed by recombination of the -- results.++liftMS :: (AdditiveGroup a) =>+ (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, AdditiveGroup (f a)) =>+ (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
src/Data/Maclaurin.hs view
@@ -30,17 +30,18 @@ module Data.Maclaurin (- (:>), powVal, derivative+ (:>)(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 import Data.VectorSpace import Data.NumInstances ()@@ -73,35 +74,38 @@ infixl 4 <$>> -- | Map a /linear/ function over a derivative tower.-fmapD, (<$>>) :: (HasTrie (Basis a)) =>+fmapD, (<$>>) :: (HasBasis a, HasTrie (Basis a), AdditiveGroup b) => (b -> c) -> (a :> b) -> (a :> c)-fmapD f (D b0 b') = D (f b0) ((fmap.fmapD) f b')+fmapD f = lf+ where+ lf (D b0 b') = D (f b0) (liftL lf b') (<$>>) = fmapD -- | Apply a /linear/ binary function over derivative towers.-liftD2 :: HasTrie (Basis a) =>+liftD2 :: (HasBasis a, HasTrie (Basis a), AdditiveGroup b, AdditiveGroup c) => (b -> c -> d) -> (a :> b) -> (a :> c) -> (a :> d)-liftD2 f (D b0 b') (D c0 c') = D (f b0 c0) (liftA2 (liftD2 f) b' c')+liftD2 f = lf+ where+ lf (D b0 b') (D c0 c') = D (f b0 c0) (liftL2 lf b' c') -- | Apply a /linear/ ternary function over derivative towers.-liftD3 :: HasTrie (Basis a) =>+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 (D b0 b') (D c0 c') (D d0 d') = D (f b0 c0 d0) (liftA3 (liftD3 f) b' c' d')+liftD3 f = lf+ where+ lf (D b0 b') (D c0 c') (D d0 d') =+ D (f b0 c0 d0) (liftL3 lf b' c' d') --- TODO: Define liftD2, liftD3 in terms of (<*>>) Compare generated code--- for speed. --- infixl 4 <*>>--- -- | Like '(<*>)' for derivative towers.--- (<*>>) :: (HasTrie (Basis a)) =>--- (a :> (b -> c)) -> (a :> b) -> (a :> c)--- D f0 f' <*>> D x0 x' = D (f0 x0) (liftA2 (<*>>) f' x')+-- 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 @@ -163,25 +167,17 @@ -- | Derivative tower for applying a binary function that distributes over -- addition, such as multiplication. A bit weaker assumption than--- bilinearity.+-- bilinearity. Is bilinearity necessary for correctness here? distrib :: forall a b c u.- (HasBasis a, HasTrie (Basis a), AdditiveGroup u) =>+ ( HasBasis a, HasTrie (Basis a)+ , AdditiveGroup b, AdditiveGroup c, AdditiveGroup u) => (b -> c -> u) -> (a :> b) -> (a :> c) -> (a :> u) --- distrib op u@(D u0 u') v@(D v0 v') =--- D (u0 `op` v0) (trie (\ e -> distrib op u (v' `untrie` e) ^+^--- distrib op (u' `untrie` e) v))--distrib op u@(D u0 u') v@(D v0 v') = D (u0 `op` v0) (inTrie2 comb u' v')+distrib op = (#) where- -- comb :: (Basis a -> a :> b) -> (Basis a -> a :> c) -> (Basis a -> a :> u)- comb uf vf (e :: Basis a) =- distrib op u (vf e) ^+^ distrib op (uf e) v---- comb uf vf = distrib op u . vf ^+^ flip (distrib op) v . uf---- TODO: Look for a formulation of distrib that eliminates the explicit--- conversion between functions and tries. Maybe something with trie addition.+ u@(D u0 u') # v@(D v0 v') =+ D (u0 `op` v0) ( liftMS (inTrie ((# v) .)) u' ^+^+ liftMS (inTrie ((u #) .)) v' ) -- TODO: I think this distrib is exponential in increasing degree. Switch@@ -189,16 +185,23 @@ -- McIlroy. -instance Show b => Show (a :> b) where show = noOv "show"+-- 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 b => Eq (a :> b) where (==) = noOv "(==)" instance Ord b => Ord (a :> b) where compare = noOv "compare" instance (HasBasis a, HasTrie (Basis a), AdditiveGroup u) => AdditiveGroup (a :> u) where zeroV = pureD zeroV -- or dZero negateV = fmapD negateV- (^+^) = liftD2 (^+^)+ D a0 a' ^+^ D b0 b' = D (a0 ^+^ b0) (a' ^+^ b')+ -- Less efficient: adds zero+ -- (^+^) = liftD2 (^+^) -instance (HasBasis a, HasTrie (Basis a), VectorSpace u)+instance ( HasBasis a, HasTrie (Basis a)+ , VectorSpace u, AdditiveGroup (Scalar u) ) => VectorSpace (a :> u) where type Scalar (a :> u) = (a :> Scalar u) (*^) = distrib (*^) @@ -220,10 +223,11 @@ infix 0 >-< -- | Specialized chain rule. See also '(\@.)'-(>-<) :: (HasBasis a, HasTrie (Basis a), VectorSpace u) =>+(>-<) :: ( HasBasis a, HasTrie (Basis a), VectorSpace u+ , AdditiveGroup (Scalar u)) => (u -> u) -> ((a :> u) -> (a :> Scalar u)) -> (a :> u) -> (a :> u)-f >-< f' = \ u@(D u0 u') -> D (f u0) (f' u *^ u')+f >-< f' = \ u@(D u0 u') -> D (f u0) (liftMS (f' u *^) u') -- TODO: express '(>-<)' in terms of '(@.)'. If I can't, then understand why not.@@ -233,9 +237,8 @@ ) => Num (a:>s) where fromInteger = pureD . fromInteger- (+) = liftD2 (+)- (-) = liftD2 (-)- (*) = distrib (*)+ (+) = (^+^)+ (*) = distrib (*) negate = negate >-< -1 abs = abs >-< signum signum = signum >-< 0 -- derivative wrong at zero@@ -266,3 +269,42 @@ 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+ , Scalar b ~ Scalar c+ ) => (a:>b,a:>c) -> a:>(b,c)++pairD (u,v) = liftD2 (,) u v++unpairD :: ( HasBasis a, HasTrie (Basis a)+ , VectorSpace a, VectorSpace b, VectorSpace c+ , Scalar b ~ Scalar c+ ) => (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+ , Scalar b ~ Scalar c, Scalar c ~ Scalar d+ ) => (a:>b,a:>c,a:>d) -> a:>(b,c,d)+tripleD (u,v,w) = liftD3 (,,) u v w++untripleD :: ( HasBasis a, HasTrie (Basis a)+ , VectorSpace a, VectorSpace b, VectorSpace c, VectorSpace d+ , Scalar b ~ Scalar c, Scalar c ~ Scalar d+ ) =>+ (a :> (b,c,d)) -> (a:>b, a:>c, a:>d)+untripleD d =+ ((\ (a,_,_) -> a) <$>> d, (\ (_,b,_) -> b) <$>> d, (\ (_,_,c) -> c) <$>> d)+
src/Data/VectorSpace.hs view
@@ -37,12 +37,11 @@ infixr 7 *^ --- | Vector space @v@ over a scalar field @s@. Extends 'AdditiveGroup'--- with scalar multiplication.+-- | Vector space @v@. class AdditiveGroup v => VectorSpace v where type Scalar v :: * -- | Scale a vector- (*^) :: Scalar v -> v -> v+ (*^) :: Scalar v -> v -> v infixr 7 <.> @@ -134,6 +133,22 @@ , AdditiveGroup s ) => 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+ , AdditiveGroup s )+ => 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.
vector-space.cabal view
@@ -1,5 +1,5 @@ Name: vector-space-Version: 0.5.3+Version: 0.5.6 Cabal-Version: >= 1.2 Synopsis: Vector & affine spaces, linear maps, and derivatives (requires ghc 6.9 or better) Category: math