diff --git a/src/Data/AdditiveGroup.hs b/src/Data/AdditiveGroup.hs --- a/src/Data/AdditiveGroup.hs +++ b/src/Data/AdditiveGroup.hs @@ -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 diff --git a/src/Data/Basis.hs b/src/Data/Basis.hs --- a/src/Data/Basis.hs +++ b/src/Data/Basis.hs @@ -27,6 +27,9 @@ import Data.VectorSpace +-- 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 :: * diff --git a/src/Data/Cross.hs b/src/Data/Cross.hs --- a/src/Data/Cross.hs +++ b/src/Data/Cross.hs @@ -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) diff --git a/src/Data/LinearMap.hs b/src/Data/LinearMap.hs --- a/src/Data/LinearMap.hs +++ b/src/Data/LinearMap.hs @@ -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 +-- +-- 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 +-- +-- 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 diff --git a/src/Data/Maclaurin.hs b/src/Data/Maclaurin.hs --- a/src/Data/Maclaurin.hs +++ b/src/Data/Maclaurin.hs @@ -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) + diff --git a/src/Data/VectorSpace.hs b/src/Data/VectorSpace.hs --- a/src/Data/VectorSpace.hs +++ b/src/Data/VectorSpace.hs @@ -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. diff --git a/vector-space.cabal b/vector-space.cabal --- a/vector-space.cabal +++ b/vector-space.cabal @@ -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