packages feed

vector-space 0.2.0 → 0.3

raw patch · 10 files changed

+358/−595 lines, 10 filesdep +MemoTriedep −OpenGLdep −old-time

Dependencies added: MemoTrie

Dependencies removed: OpenGL, old-time

Files

Makefile view
@@ -4,4 +4,6 @@ server-dir = /srv/code server-url-dir = +# extra-configure-args += --enable-library-profiling --enable-executable-profiling+ include ../my-cabal-make.inc
src/Data/AdditiveGroup.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TypeOperators #-} ---------------------------------------------------------------------- -- | -- Module      :   Data.AdditiveGroup@@ -12,12 +13,14 @@  module Data.AdditiveGroup   ( -    AdditiveGroup(..), (^-^)+    AdditiveGroup(..), (^-^), sumV   ) where  import Control.Applicative import Data.Complex hiding (magnitude) +import Data.MemoTrie+ infixl 6 ^+^, ^-^  -- | Additive group @v@.@@ -33,6 +36,10 @@ (^-^) :: AdditiveGroup v => v -> v -> v v ^-^ v' = v ^+^ negateV v' +-- | Sum over several vectors+sumV :: AdditiveGroup v => [v] -> v+sumV = foldr (^+^) zeroV+ instance AdditiveGroup Double where   zeroV   = 0.0   (^+^)   = (+)@@ -65,7 +72,13 @@   -- Standard instance for an applicative functor applied to a vector space.-instance AdditiveGroup v => AdditiveGroup (a->v) where+instance AdditiveGroup v => AdditiveGroup (u->v) where+  zeroV   = pure   zeroV+  (^+^)   = liftA2 (^+^)+  negateV = fmap   negateV++-- Memo tries+instance (HasTrie u, AdditiveGroup v) => AdditiveGroup (u :->: v) where   zeroV   = pure   zeroV   (^+^)   = liftA2 (^+^)   negateV = fmap   negateV
+ src/Data/Basis.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE TypeOperators, TypeFamilies, UndecidableInstances+  , FlexibleInstances, MultiParamTypeClasses+  #-}+{-# 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+----------------------------------------------------------------------++module Data.Basis+  (+    HasBasis(..)+  ) where++import Control.Arrow (second)+import Data.Either++import Data.VectorSpace++class VectorSpace v s => HasBasis v s where+  type Basis v :: *+  basisValue :: Basis v -> v+  decompose :: v -> [(s, Basis v)]++-- TODO: switch from fundep to associated type.  eliminate the second type+-- parameter in VectorSpace and HasBasis.+-- Blocking bug: http://hackage.haskell.org/trac/ghc/ticket/2448++instance HasBasis Float Float where+  type Basis Float = ()+  basisValue ()    = 1+  decompose s      = [(s,())]++instance HasBasis Double Double where+  type Basis Double = ()+  basisValue ()     = 1+  decompose s       = [(s,())]++instance (HasBasis u s, HasBasis v s) => HasBasis (u,v) s 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++decomp2 :: HasBasis w s => (Basis w -> b) -> w -> [(s, b)]+decomp2 inject = fmap (second inject) . decompose++instance (HasBasis u s, HasBasis v s, HasBasis w s) => HasBasis (u,v,w) s where+  type Basis (u,v,w) = Basis (u,(v,w))+  basisValue         = unnest3 . basisValue+  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))++-- Without UndecidableInstances:+-- +--     Application is no smaller than the instance head+--       in the type family application: Basis (u, (v, w))+--     (Use -fallow-undecidable-instances to permit this)+--     In the type synonym instance declaration for `Basis'+--     In the instance declaration for `HasBasis (u, v, w)'+-- +-- A work-around:+-- +--     type Basis (u,v,w) = Basis u `Either` Basis (v,w)+++{-++---- Testing++t1 = basisValue () :: Float+t2 = basisValue () :: Double+t3 = basisValue (Right ()) :: (Float,Double)+t4 = basisValue (Right (Left ())) :: (Float,Double,Float)++-}+
src/Data/Cross.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE FlexibleInstances, TypeOperators, UndecidableInstances-           , TypeSynonymInstances+{-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeOperators, UndecidableInstances+           , TypeFamilies, TypeSynonymInstances   #-} {-# OPTIONS_GHC -Wall #-} ----------------------------------------------------------------------@@ -22,8 +22,12 @@   ) where  import Data.VectorSpace-import Data.LinearMap+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@@ -32,7 +36,6 @@ normal :: (HasNormal v, InnerSpace v s, Floating s) => v -> v normal = normalized . normalVec - -- | Singleton type One   s = s @@ -45,27 +48,28 @@ -- | Cross product of various forms of 2D vectors class HasCross2 v where cross2 :: v -> v -instance Num s => HasCross2 (s,s) where-  cross2 (x,y) = (-y,x)  -- or @(y,-x)@?---- TODO: Eliminate the 'Num' constraint by using negateV.+instance AdditiveGroup u => HasCross2 (u,u) where+  cross2 (x,y) = (negateV y,x)  -- or @(y,-x)@?  -- "Variable occurs more often in a constraint than in the instance -- head".  Hence UndecidableInstances. -instance (LMapDom a s, VectorSpace v s, HasCross2 v) => HasCross2 (a:>v) where+instance ( HasBasis a s, HasTrie (Basis a)+         , VectorSpace v s, HasCross2 v) => HasCross2 (a:>v) where   -- 2d cross-product is linear   cross2 = fmapD cross2 -instance (Num s, LMapDom s s) => HasNormal (One s :> Two s) where-  normalVec v = cross2 (derivativeAt v 1)---- Does this problem come from the choice of 'VectorSpace' instance?+instance (HasBasis s s, HasTrie (Basis s), Basis s ~ ()) =>+         HasNormal (One s :> Two s) where+  normalVec v = cross2 (derivative v `untrie` ()) -instance (Num s, LMapDom s s, VectorSpace s s)+instance ( Num s, VectorSpace s s+         , HasBasis s 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@@ -77,33 +81,37 @@  -- TODO: Eliminate the 'Num' constraint by using 'VectorSpace' operations. -instance (LMapDom a s, VectorSpace v s, HasCross3 v) => HasCross3 (a:>v) where+instance (HasBasis a s, HasTrie (Basis a), VectorSpace v s, HasCross3 v) => HasCross3 (a:>v) where   -- 3D cross-product is bilinear (curried linear)   cross3 = distrib cross3 -instance (Num s, LMapDom s s) => HasNormal (Two s :> Three s) where-  normalVec v = d (1,0) `cross3` d (0,1)+instance (Num s, HasTrie (Basis (s, s)), HasBasis s s, Basis s ~ ()) =>+         HasNormal (Two s :> Three s) where+  normalVec v = d (Left ()) `cross3` d (Right ())    where-     d = derivativeAt v+     d = untrie (derivative v) -instance (Num s, VectorSpace s s, LMapDom s s) => HasNormal (Three (Two s :> s)) where+instance ( Num s, VectorSpace s s, HasBasis s s, HasTrie (Basis s)+         , HasNormal (Two s :> Three s))+         => HasNormal (Three (Two s :> s)) where   normalVec = untripleD . normalVec . tripleD + ---- Could go elsewhere -pairD :: (LMapDom a s, VectorSpace b s, VectorSpace c s) =>+pairD :: (HasBasis a s, HasTrie (Basis a), VectorSpace b s, VectorSpace c s) =>          (a:>b,a:>c) -> a:>(b,c) pairD (u,v) = liftD2 (,) u v -tripleD :: (LMapDom a s, VectorSpace b s, VectorSpace c s, VectorSpace d s) =>+tripleD :: (HasBasis a s, HasTrie (Basis a), VectorSpace b s, VectorSpace c s, VectorSpace d s) =>            (a:>b,a:>c,a:>d) -> a:>(b,c,d) tripleD (u,v,w) = liftD3 (,,) u v w -unpairD :: (LMapDom a s, VectorSpace a s, VectorSpace b s, VectorSpace c s) =>+unpairD :: (HasBasis a s, HasTrie (Basis a), VectorSpace a s, VectorSpace b s, VectorSpace c s) =>            (a :> (b,c)) -> (a:>b, a:>c) unpairD d = (fst <$>> d, snd <$>> d) -untripleD :: ( LMapDom a s , VectorSpace a s, VectorSpace b s+untripleD :: ( HasBasis a s, HasTrie (Basis a) , VectorSpace a s, VectorSpace b s              , VectorSpace c s, VectorSpace d s) =>              (a :> (b,c,d)) -> (a:>b, a:>c, a:>d) untripleD d =
src/Data/Derivative.hs view
@@ -1,12 +1,3 @@-{-# LANGUAGE TypeOperators, MultiParamTypeClasses, UndecidableInstances-           , TypeSynonymInstances, FlexibleInstances, FunctionalDependencies-           , FlexibleContexts-           , GeneralizedNewtypeDeriving, StandaloneDeriving-  #-}---- TODO: remove FlexibleContexts---- {-# OPTIONS_GHC -Wall #-} ---------------------------------------------------------------------- -- | -- Module      :  Data.Derivative@@ -15,179 +6,13 @@ --  -- Maintainer  :  conal@conal.net -- Stability   :  experimental--- --- This module is a wrapper around Data.Maclaurin or Data.Horner, to--- change the 'VectorSpace' instance for '(:>)'.+--+-- Module indirection module.  For Maclaurin- vs Horner-based derivative+-- towers. ---------------------------------------------------------------------- -module Data.Derivative-  (-    (:>), powVal, derivative, derivativeAt-  , (:~>), dZero, pureD-  , fmapD, (<$>>){-, (<*>>)-}, liftD2, liftD3-  , idD, fstD, sndD-  , linearD, distrib-  , (@.), (>-<)-  ) where--import Data.Function (on)--import Data.VectorSpace-import Data.NumInstances ()-import Data.LinearMap--import qualified Data.Maclaurin as D--- import qualified Data.Horner as D---- TODO: sync Data.Horner interface with Data.Maclaurin.  Better: refactor--- Maclaurin into a module that depends on the representation (e.g.,--- Horner vs Maclaurin) and the rest that doesn't.--infixr 9 @.-infixl 4 {-<*>>,-} <$>>-infix  0 >-<----- | Tower of derivatives.-newtype (a :> b) = T { unT :: a D.:> b }--deriving instance (VectorSpace b b, LMapDom a b, Num b       ) => Num           (a :> b)-deriving instance (VectorSpace b b, LMapDom a b, Fractional b) => Fractional    (a :> b)-deriving instance (VectorSpace b b, LMapDom a b, Floating b  ) => Floating      (a :> b)-deriving instance (VectorSpace b s, LMapDom a s              ) => AdditiveGroup (a :> b)---inT :: ((a D.:> b) -> (c D.:> d))-    -> ((a   :> b) -> (c   :> d))-inT  = (T .).(. unT)--inT2 :: ((a D.:> b) -> (c D.:> d) -> (e D.:> f))-     -> ((a   :> b) -> (c   :> d) -> (e   :> f))-inT2  = (inT .).(. unT)--inT3 :: ((a D.:> b) -> (c D.:> d) -> (e D.:> f) -> (g D.:> h))-     -> ((a   :> b) -> (c   :> d) -> (e   :> f) -> (g   :> h))-inT3  = (inT2 .).(. unT)---- | Extract the value from a derivative tower-powVal :: (a :> b) -> b-powVal = D.powVal . unT---- | Extract the derivative from a derivative tower-derivative :: (VectorSpace b s, LMapDom a s) =>-              (a :> b) -> (a :-* (a :> b))-derivative = fmapL T . D.derivative . unT---- | Sampled derivative.  For avoiding an awkward typing problem related--- to the two required 'VectorSpace' instances.-derivativeAt :: (LMapDom a s, VectorSpace b s) =>-                (a :> b) -> a -> (a :> b)-derivativeAt d = T . D.derivativeAt (unT d)---- The definition of 'derivativeAt' takes care to share partial--- applications of 'D.derivativeAt', which is useful in power series--- representations for which 'derivative' is not free (Horner).---- | 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")----- | Derivative tower full of 'zeroV'.-dZero :: (LMapDom a s, VectorSpace b s) => a:>b-dZero = T D.dZero----- | Constant derivative tower.-pureD :: (LMapDom a s, VectorSpace b s) => b -> a:>b-pureD = fmap T D.pureD---- | Map a /linear/ function over a derivative tower.-fmapD, (<$>>) :: (LMapDom a s, VectorSpace b s) =>-                 (b -> c) -> (a :> b) -> (a :> c)-fmapD = fmap inT D.fmapD--(<$>>) = fmapD---- -- | Like '(<*>)' for derivative towers.--- (<*>>) :: (LMapDom a s, VectorSpace b s, VectorSpace c s) =>---           (a :> (b -> c)) -> (a :> b) -> (a :> c)--- (<*>>) = inT2 (D.<*>>)---- | Apply a /linear/ binary function over derivative towers.-liftD2 :: (VectorSpace b s, LMapDom a s, VectorSpace c s, VectorSpace d s) =>-          (b -> c -> d) -> (a :> b) -> (a :> c) -> (a :> d)-liftD2 = fmap inT2 D.liftD2----- | Apply a /linear/ ternary function over derivative towers.-liftD3 :: ( LMapDom a s-          , VectorSpace b s, VectorSpace c s-          , VectorSpace d s, VectorSpace e s ) =>-          (b -> c -> d -> e)-       -> (a :> b) -> (a :> c) -> (a :> d) -> (a :> e)-liftD3 = fmap inT3 D.liftD3---- | Differentiable identity function.  Sometimes called "the--- derivation variable" or similar, but it's not really a variable.-idD :: (LMapDom u s, VectorSpace u s) => u :~> u-idD = fmap T D.idD---- | Every linear function has a constant derivative equal to the function--- itself (as a linear map).-linearD :: (LMapDom u s, VectorSpace v s) => (u -> v) -> (u :~> v)-linearD = (fmap.fmap) T D.linearD---- Other examples of linear functions---- | Differentiable version of 'fst'-fstD :: (VectorSpace a s, LMapDom b s, LMapDom a s) => (a,b) :~> a-fstD = fmap T D.fstD---- | Differentiable version of 'snd'-sndD :: (VectorSpace b s, LMapDom b s, LMapDom a s) => (a,b) :~> b-sndD = fmap T D.sndD---- | Derivative tower for applying a binary function that distributes over--- addition, such as multiplication.  A bit weaker assumption than--- bilinearity.-distrib :: (LMapDom a s, VectorSpace b s, VectorSpace c s, VectorSpace u s) =>-           (b -> c -> u) -> (a :> b) -> (a :> c) -> (a :> u)-distrib = fmap inT2 D.distrib---- I'm not sure about the next three, which discard information--instance Show b => Show (a :> b) where show    = show     .   unT-instance Eq   b => Eq   (a :> b) where (==)    = (==)    `on` unT-instance Ord  b => Ord  (a :> b) where compare = compare `on` unT---- These next two instances are the reason for having this module.  The--- scalar field differs from the one used in the underlying--- representation.  I can't have both instances.  First, there is a--- functional dependency on 'VectorSpace', which says that a vector space--- type determines its scalar field type.  I experimented with dropping--- the fundep, and then managing the resulting ambiguity.  However,--- the two 'VectorSpace' instances overlap considerably.--instance (LMapDom a s, VectorSpace u s, VectorSpace s s)-    => VectorSpace (a :> u) (a :> s) where-  (*^)    = inT2 (D.**^) -- not '(D.*^)'--instance (InnerSpace u s, InnerSpace s s', VectorSpace s s, LMapDom a s) =>-     InnerSpace (a :> u) (a :> s) where-  (<.>)    = inT2 (D.<*.>) -- not '(D.<.>)'-+module Data.Derivative (module Data.Maclaurin) where --- | Chain rule.-(@.) :: (LMapDom b s, LMapDom a s, VectorSpace c s) =>-        (b :~> c) -> (a :~> b) -> (a :~> c)-h @. g = T . ((unT . h) D.@. (unT . g))+import Data.Maclaurin --- | Specialized chain rule.-(>-<) :: (LMapDom a s, VectorSpace s s, VectorSpace u s) =>-         (u -> u) -> ((a :> u) -> (a :> s))-      -> (a :> u) -> (a :> u)-f >-< f' = inT (f D.>-< (unT . f' . T))+-- Or Data.Horner when working again
src/Data/LinearMap.hs view
@@ -1,8 +1,7 @@-{-# LANGUAGE TypeOperators, TypeFamilies, UndecidableInstances-           , MultiParamTypeClasses, FlexibleInstances-           , FunctionalDependencies-  #-}-{-# OPTIONS_GHC -Wall -fno-warn-orphans -fglasgow-exts #-}+{-# LANGUAGE TypeOperators, FlexibleContexts #-}+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+-- {-# OPTIONS_GHC -fglasgow-exts -funbox-strict-fields #-}+-- {-# OPTIONS_GHC -ddump-simpl-stats -ddump-simpl #-} ---------------------------------------------------------------------- -- | -- Module      :  Data.LinearMap@@ -16,249 +15,31 @@ ----------------------------------------------------------------------  module Data.LinearMap-  (-    LMapDom(..), inL, inL2, inL3-  , linearK, (.*)-  , pureL --, (<*>*)-  , fmapL, (<$>*), liftL2, liftL3, idL+  ( (:-*) , linear, lapply+  -- , inL, inL2, inL3   ) where  -- -fglasgow-exts above enables the RULES pragma -import Control.Applicative import Data.Function  import Data.VectorSpace---- Temporary-import Graphics.Rendering.OpenGL.GL.CoordTrans-  (Vector2(..),Vector3(..))---infixr 9 :-*-infixr 9 .*-infixl 9 `lapply`-infixl 4 <$>* -- , <*>*----- | Domain of a linear map.-class VectorSpace a s => LMapDom a s | a -> s where-  -- | Linear map type-  data (:-*) a :: * -> *-  -- | Linear map as function-  lapply :: VectorSpace b s => (a :-* b) -> (a -> b)-  -- | Function (assumed linear) as linear map.-  linear :: (a -> b) -> (a :-* b)---- Neither 'VectorSpace' nor even 'AdditiveGroup' is really required as a--- 'LMapDom' superclass.  Instead, we could have additional constraints in--- some 'LMapDom' instances and related functions.---{-# RULES-"linear.lapply"   forall m. linear (lapply m) = m-"lapply.linear"   forall f. lapply (linear f) = f- #-}----- | Transform a linear map by transforming a linear function.-inL :: (LMapDom c s, VectorSpace b s', LMapDom a s') =>-        ((a -> b) -> (c -> d)) -> ((a :-* b) -> (c :-* d))-{-# INLINE inL #-}-inL h = linear . h . lapply---- | Transform a linear maps by transforming linear functions.-inL2 :: ( LMapDom c s, VectorSpace b s', LMapDom a s'-        , LMapDom e s, VectorSpace d s ) =>-        ((a -> b) -> (c -> d) -> (e -> f))-     -> ((a :-* b) -> (c :-* d) -> (e :-* f))-{-# INLINE inL2 #-}-inL2 h = inL . h . lapply---- inL2 h m n---   = (inL . h . lapply) m n---   = inL (h (lapply m)) n---   = (linear . (h (lapply m)) . lapply) n---   = linear (h (lapply m) (lapply n)---   = linear (h (lapply m) (lapply n))----- | Transform a linear maps by transforming linear functions.-inL3 :: ( LMapDom a s, VectorSpace b s-        , VectorSpace f s , LMapDom p s, LMapDom c s'-        , VectorSpace d s', LMapDom e s ) =>-        ((a -> b) -> (c -> d) -> (e -> f) -> (p -> q))-     -> ((a :-* b) -> (c :-* d) -> (e :-* f) -> (p :-* q))-{-# INLINE inL3 #-}-inL3 h = inL2 . h . lapply----- TODO: go through this whole module and relax constraints on scalar--- fields.  See if it helps with the scalar dilemma in Mac2----- | Constant value as a linear map-pureL :: LMapDom a s => b -> (a :-* b)-pureL b = linear (const b)---- -- | Like '(<*>)' for linear maps.--- (<*>*) :: (LMapDom a s, VectorSpace b s, VectorSpace c s) =>---         (a :-* (b -> c)) -> (a :-* b) -> (a :-* c)--- (<*>*) = inL2 (<*>)---- | Map a /linear/ function over a linear map.-fmapL, (<$>*) :: (LMapDom a s, VectorSpace b s) =>-                 (b -> c) -> (a :-* b) -> (a :-* c)-{-# INLINE fmapL #-}-fmapL = inL . fmap---- fmapL f---   = inL (f .)---   = linear . (f .) . lapply---   = \ m -> linear (fmap f (lapply m))--(<$>*) = fmapL---{-# RULES-"fmapL.fmapL"  forall f g m. fmapL f (fmapL g m) = fmapL (f.g) m- #-}---- | Apply a /linear/ binary function over linear maps.-liftL2 :: ( LMapDom a s, VectorSpace b s-           , VectorSpace c s, VectorSpace d s) =>-           (b -> c -> d) -> (a :-* b) -> (a :-* c) -> (a :-* d)-liftL2 = inL2 . liftA2---- liftL2 f a b---   = inL2 (liftA2 f) a b---   = linear (liftA2 f (lapply a) (lapply b))---- I expected the following definition to be equivalent, thanks to rewriting:--- ---   liftL2 f b c = fmapL f b <*>* c---     = linear (f . lapply b) <*>* c---     = linear (lapply (linear (f . lapply b)) <*> lapply c)---     = linear ((f . lapply b) <*> lapply c)---     = linear (liftA2 f (lapply b) (lapply c))---     = (inL2.liftA2) f b c---- The rewrite isn't happening, however.  And the '(<*>*)' definition--- yields an incredibly slow implementation.--- --- Here's that derivation again, in slo-mo:----   liftL2 f b c---     = fmapL f b <*>* c                                  -- inline liftL2---     = inL (f .) b <*>* c                                -- inline fmapL---     = (linear . (f .) lapply) b <*>* c                  -- inline inL---     = linear (f . lapply b) <*>* c                      -- inline (.)---     = inL2 (<*>) (linear (f . lapply b)) c              -- inline (<*>*)---     = (inL . (<*>) . lapply) (linear (f . lapply b)) c  -- inline inL2---     = inL ((<*>) (lapply (linear (f . lapply b)))) c    -- inline (.)---     = inL ((<*>) (f . lapply b)) c                      -- RULE lapply.linear---     = (linear . ((<*>) (f . lapply b)) .lapply) c       -- inline inL---     = linear ((<*>) (f . lapply b) (lapply c))          -- inline (.)---     = linear ((f . lapply b) <*> (lapply c))            -- infix <*>---     = linear ((f <$> lapply b) <*> (lapply c))          -- <$> on (a ->)---     = linear (liftA2 f (lapply b) (lapply c))           -- uninline liftA2---- When I compile this module, I don't get any firings of lapply.linear----- | Apply a /linear/ ternary function over linear maps.-liftL3 :: ( LMapDom a s, VectorSpace b s, VectorSpace c s-           , VectorSpace d s, VectorSpace e s) =>-           (b -> c -> d -> e)-        -> (a :-* b) -> (a :-* c) -> (a :-* d) -> (a :-* e)-liftL3 = inL3 . liftA3----- TODO: Get clear about the linearity requirements of 'apL', 'liftL2',--- and 'liftL3'.---- | Identity linear map-idL :: LMapDom a s => a :-* a-idL = linear id---- | Compose linear maps-(.*) :: (VectorSpace c s, LMapDom b s, LMapDom a s) =>-        (b :-* c) -> (a :-* b) -> (a :-* c)-(.*) = inL2 (.)---instance (VectorSpace v s, LMapDom u s) => AdditiveGroup (u :-* v) where-  zeroV   = pureL  zeroV-  (^+^)   = liftL2 (^+^)-  negateV = fmapL  negateV--instance (VectorSpace v s, LMapDom u s) => VectorSpace (u :-* v) s where-  (*^) s  = fmapL  ((*^) s)---- Or possibly the following non-standard definition:---- instance (VectorSpace v s, VectorSpace s s, LMapDom u s)---       => VectorSpace (u :-* v) (u :-* s) where---   zeroV   = pureL  zeroV---   (*^)    = liftL2 (*^)---   (^+^)   = liftL2 (^+^)---   negateV = fmapL  negateV---- Alternatively, add some methods to 'LMapDom' and use them as follows.--- May be more efficient.---- -- Linear maps form a vector space--- instance (VectorSpace o s, LinearMap a o s) => VectorSpace (a :--> o) s where---   zeroV   = zeroL---   (^+^)   = addL---   (*^)    = scaleL---   negateV = negateL------- Instances of LMapDom--instance LMapDom Float Float where-  data Float :-* o   = FloatL o-  lapply (FloatL o)  = (*^ o)-  linear f           = FloatL (f 1)--instance LMapDom Double Double where-  data Double :-* o  = DoubleL o-  lapply (DoubleL o) = (*^ o)-  linear f           = DoubleL (f 1)+import Data.MemoTrie+import Data.Basis  --- | Convenience function for 'linear' definitions.  Both functions are--- assumed linear.-linearK :: (LMapDom a s) => (a -> b) -> (b -> c) -> a :-* c-linearK k f = linear (f . k)---- instance LMapDom (Double,Double) Double where---   data (Double,Double) :-* o = PairD o o---   PairD ao bo `lapply` (a,b) = a *^ ao ^+^ b *^ bo---   linear f = PairD (f (0,1)) (f (1,0))--instance (LMapDom a s, LMapDom b s) => LMapDom (a,b) s where-  data (a,b) :-* o = PairL (a :-* o) (b :-* o)-  PairL ao bo `lapply` (a,b) = ao `lapply` a ^+^ bo `lapply` b-  linear f = PairL (linear (\ a -> f (a,zeroV)))-                   (linear (\ b -> f (zeroV,b)))----   linear = liftA2 PairL---              (linearK (\ a -> (a,zeroV)))---              (linearK (\ b -> (zeroV,b)))--instance (LMapDom a s, LMapDom b s, LMapDom c s) => LMapDom (a,b,c) s where-  data (a,b,c) :-* o = TripleL (a :-* o) (b :-* o) (c :-* o)-  TripleL ao bo co `lapply` (a,b,c) =-    ao `lapply` a ^+^ bo `lapply` b ^+^ co `lapply` c-  linear = liftA3 TripleL-             (linearK (\ a -> (a,zeroV,zeroV)))-             (linearK (\ b -> (zeroV,b,zeroV)))-             (linearK (\ c -> (zeroV,zeroV,c)))+-- | Linear map, represented a as a memo function from basis to values.+type u :-* v = Basis u :->: v +-- | Function (assumed linear) as linear map.+linear :: (VectorSpace u s, VectorSpace v s', HasBasis u s, HasTrie (Basis u)) =>+          (u -> v) -> (u :-* v)+linear f = trie (f . basisValue) +-- | Apply a linear map to a vector.+lapply :: (VectorSpace u s, VectorSpace v s, HasBasis u s, HasTrie (Basis u)) =>+          (u :-* v) -> (u -> v)+lapply lm u = sumV [s *^ (lm `untrie` b) | (s,b) <- decompose u]   -- TODO: unfst, unsnd, pair, unpair@@ -275,41 +56,3 @@ --     Found o but expected Vector2 u
 --     In the associated type instance for `:-*'
 --     In the instance declaration for `LMapDom (Vector2 u) s'
------ TODO: is UndecidableInstances still necessary?--instance AdditiveGroup u => AdditiveGroup (Vector2 u) where-  zeroV                         = Vector2 zeroV zeroV-  Vector2 u v ^+^ Vector2 u' v' = Vector2 (u^+^u') (v^+^v')-  negateV (Vector2 u v)         = Vector2 (negateV u) (negateV v)--instance (VectorSpace u s) => VectorSpace (Vector2 u) s where-  s *^ Vector2 u v            = Vector2 (s*^u) (s*^v)--instance (InnerSpace u s, AdditiveGroup s)-    => InnerSpace (Vector2 u) s where-  Vector2 u v <.> Vector2 u' v' = u<.>u' ^+^ v<.>v'--instance LMapDom u s => LMapDom (Vector2 u) s where-  data Vector2 u :-* o = VecL (u :-* o) (u :-* o)-  VecL ao bo `lapply` Vector2 a b = ao `lapply` a ^+^ bo `lapply` b-  linear = liftA2 VecL-             (linearK (\ a -> Vector2 a zeroV))-             (linearK (\ b -> Vector2 zeroV b))---instance AdditiveGroup u => AdditiveGroup (Vector3 u) where-  zeroV                   = Vector3 zeroV zeroV zeroV-  Vector3 u v w ^+^ Vector3 u' v' w'-                          = Vector3 (u^+^u') (v^+^v') (w^+^w')-  negateV (Vector3 u v w) = Vector3 (negateV u) (negateV v) (negateV w)--instance VectorSpace u s => VectorSpace (Vector3 u) s where-  s *^ Vector3 u v w    = Vector3 (s*^u) (s*^v) (s*^w)--instance (InnerSpace u s, AdditiveGroup s)-    => InnerSpace (Vector3 u) s where-  Vector3 u v w <.> Vector3 u' v' w' = u<.>u' ^+^ v<.>v' ^+^ w<.>w'-
src/Data/Maclaurin.hs view
@@ -2,6 +2,7 @@            , TypeSynonymInstances, FlexibleInstances, FunctionalDependencies            , FlexibleContexts   #-}+-- {-# OPTIONS_GHC -ddump-simpl-stats -ddump-simpl #-}  -- TODO: remove FlexibleContexts @@ -21,43 +22,43 @@  module Data.Maclaurin   (-    (:>), powVal, derivative, derivativeAt+    (:>), powVal, derivative --, derivativeAt   , (:~>), dZero, pureD   , fmapD, (<$>>){-, (<*>>)-}, liftD2, liftD3-  , idD, fstD, sndD+  , idD -- , fstD, sndD   , linearD, distrib-  , (@.), (>-<)+  -- , (@.)+  , (>-<)   ,(**^), (<*.>)   -- , HasDeriv(..)   -- experimental   -- , liftD3-  ) where+  ) +    where --- import Control.Applicative+import Control.Applicative  import Data.VectorSpace import Data.NumInstances ()+import Data.MemoTrie+import Data.Basis import Data.LinearMap  -infixr 9 `D`, @.-infixl 4 {-<*>>,-} <$>>-infix  0 >-<--+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) --- | Sampled derivative.  For avoiding an awkward typing problem related--- to the two required 'VectorSpace' instances.-derivativeAt :: (VectorSpace b s, LMapDom a s) =>-                (a :> b) -> a -> (a :> b)-derivativeAt d = lapply (derivative d)+-- -- | Sampled derivative.  For avoiding an awkward typing problem related+-- -- to the two required 'VectorSpace' instances.+-- derivativeAt :: (VectorSpace b s) =>+--                 (a :> b) -> a -> (a :> b)+-- derivativeAt d = lapply (derivative d) --- The crucial point here is for '($*)' to be interpreted with respect to+-- The crucial point here is for 'lapply' to be interpreted with respect to -- the 'VectorSpace' instance in this module, not Mac.  -- The argument order for 'derivativeAt' allows partial evaluation, which@@ -69,41 +70,48 @@ noOv op = error (op ++ ": not defined on a :> b")  -- | Derivative tower full of 'zeroV'.-dZero :: (LMapDom a s, AdditiveGroup b) => a:>b+dZero :: (AdditiveGroup b, HasBasis a s, HasTrie (Basis a)) => a:>b dZero = pureD zeroV  -- | Constant derivative tower.-pureD :: (LMapDom a s, AdditiveGroup b) => b -> a:>b-pureD b = b `D` pureL dZero+pureD :: (AdditiveGroup b, HasBasis a s, HasTrie (Basis a)) => b -> a:>b+pureD b = b `D` pure dZero ++infixl 4 <$>> -- | Map a /linear/ function over a derivative tower.-fmapD, (<$>>) :: (LMapDom a s, VectorSpace b s) =>+fmapD, (<$>>) :: (HasTrie (Basis a), VectorSpace b s) =>                  (b -> c) -> (a :> b) -> (a :> c)-fmapD f (D b0 b') = D (f b0) ((fmapL.fmapD) f b')+fmapD f (D b0 b') = D (f b0) ((fmap.fmapD) f b')  (<$>>) = fmapD +-- infixl 4 <*>> -- -- | Like '(<*>)' for derivative towers.--- (<*>>) :: (LMapDom a s, VectorSpace b s, VectorSpace c s) =>+-- (<*>>) :: (HasTrie (Basis a), VectorSpace b s, VectorSpace c s) => --           (a :> (b -> c)) -> (a :> b) -> (a :> c)--- D f0 f' <*>> D x0 x' = D (f0 x0) (liftL2 (<*>>) f' x')+-- D f0 f' <*>> D x0 x' = D (f0 x0) (liftA2 (<*>>) f' x')  -- | Apply a /linear/ binary function over derivative towers.-liftD2 :: (VectorSpace b s, LMapDom a s, VectorSpace c s, VectorSpace d s) =>+liftD2 :: (HasTrie (Basis a), VectorSpace b s, VectorSpace c s, VectorSpace d s) =>           (b -> c -> d) -> (a :> b) -> (a :> c) -> (a :> d)-liftD2 f (D b0 b') (D c0 c') = D (f b0 c0) (liftL2 (liftD2 f) b' c')+liftD2 f (D b0 b') (D c0 c') = D (f b0 c0) (liftA2 (liftD2 f) b' c')  -- | Apply a /linear/ ternary function over derivative towers.-liftD3 :: ( LMapDom a s+liftD3 :: ( HasTrie (Basis a)           , VectorSpace b s, VectorSpace c s           , VectorSpace d s, VectorSpace e s ) =>           (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) (liftL3 (liftD3 f) b' c' d')+liftD3 f (D b0 b') (D c0 c') (D d0 d') = D (f b0 c0 d0) (liftA3 (liftD3 f) b' c' d') +-- TODO: try defining liftD2, liftD3 in terms of (<*>>) above+ -- | Differentiable identity function.  Sometimes called "the -- derivation variable" or similar, but it's not really a variable.-idD :: (LMapDom u s, VectorSpace u s) => u :~> u+idD :: ( VectorSpace u s, VectorSpace (u :> u) (u :> s), VectorSpace s s+       , HasBasis u s, HasTrie (Basis u)) =>+       u :~> u idD = linearD id  -- or@@ -111,111 +119,165 @@  -- | Every linear function has a constant derivative equal to the function -- itself (as a linear map).-linearD :: (LMapDom u s, VectorSpace v s) => (u -> v) -> (u :~> v)-linearD f u = D (f u) (linear (pureD . f))+linearD :: ( HasBasis u s, HasTrie (Basis u){-, VectorSpace (u :> v) s, -}+           , VectorSpace v s, VectorSpace s s ) =>+           (u -> v) -> (u :~> v) --- Other examples of linear functions+-- linearD f u = f u `D` linear (pureD . f) --- | Differentiable version of 'fst'-fstD :: (VectorSpace a s, LMapDom b s, LMapDom a s) => (a,b) :~> a-fstD = linearD fst+-- data a :> b = D { powVal :: b, derivative :: a :-* (a :> b) } --- | Differentiable version of 'snd'-sndD :: (VectorSpace b s, LMapDom b s, LMapDom a s) => (a,b) :~> b-sndD = linearD snd+-- linear :: (VectorSpace u s, VectorSpace v s, HasBasis u s, HasTrie (Basis u)) =>+--           (u -> v) -> (u :-* v) --- | Derivative tower for applying a binary function that distributes over--- addition, such as multiplication.  A bit weaker assumption than--- bilinearity.-distrib :: (LMapDom a s, VectorSpace b s, VectorSpace c s, VectorSpace u s) =>-           (b -> c -> u) -> (a :> b) -> (a :> c) -> (a :> u)-distrib op = opD- where-   opD u@(D u0 u') v@(D v0 v') =-     D (u0 `op` v0) (linear (\ da -> u `opD` (v' `lapply` da) ^+^-                                     (u' `lapply` da) `opD` v)) --- Equivalently:+-- HEY!  I think there's a hugely wasteful recomputation going on in+-- 'linearD' above.  Note the definition of 'linear': -- ---    opD u@(D u0 u') v@(D v0 v') =---      D (u0 `op` v0) (linear ((u `opD`) . lapply v' ^+^ (`opD` v) . lapply u'))+--     linear f = trie (f . basisValue) -- --- or+-- Substituting, -- ---    opD u@(D u0 u') v@(D v0 v') =---      D (u0 `op` v0) ( linear ((u `opD`) . lapply v') ^+^---                       linear ((`opD` v) . lapply u') )--- or even+--     linearD f u = f u `D` trie ((pureD . f) . basisValue) -- ---    opD u@(D u0 u') v@(D v0 v') =---      D (u0 `op` v0) ( inL ((u `opD`) .) v' ^+^ inL ((`opD` v) .) u' )+-- 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 --- TODO: look for a simpler definition of distrib.  this definition almost--- fits liftLM2.+-- linearD f = (`D` linear (pureD . f)) . f  ++-- TODO: revise two previous signatures when i've added the VectorSpace instance for u:>v++{-++-- Other examples of linear functions++-- | Differentiable version of 'fst'+fstD :: -- (VectorSpace a s, HasBasis a s, HasTrie (Basis a), HasBasis b s, HasTrie (Basis b)) =>+        ( HasBasis a s, HasTrie (Basis a)+        , HasBasis b s, HasTrie (Basis b)+        , HasBasis (a,b) s, HasTrie (Basis (a, b))+        ) =>+        (a,b) :~> a+fstD = linearD fst++-- wtf:+-- +--   Data/NewMaclaurin.hs:138:7:+--       Could not deduce (HasTrie (Basis (a, b)))+--         from the context (HasBasis a s,+--                           HasTrie (Basis a),+--                           HasBasis b s,+--                           HasTrie (Basis b),+--                           HasBasis (a, b) s,+--                           HasTrie (Basis (a, b)))+--         arising from a use of `linearD' at Data/NewMaclaurin.hs:138:7-17+--       Possible fix:+--         add (HasTrie (Basis (a, b))) to the context of+--           the type signature for `fstD'+--         or add an instance declaration for (HasTrie (Basis (a, b)))+--       In the expression: linearD fst+--       In the definition of `fstD': fstD = linearD fst+--   Failed, modules loaded: Data.MemoTrie, Data.Basis, Data.VectorSpace, Data.AdditiveGroup, Data.NumInstances.+--   *Data.Basis> ++-- -- | Differentiable version of 'snd'+-- sndD :: (VectorSpace b s, HasBasis b s, HasTrie (Basis b), HasTrie (Basis a)) => (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.+distrib :: ( HasBasis a s, HasTrie (Basis a)+           , VectorSpace b s, VectorSpace c s, VectorSpace u s) =>+           (b -> c -> u) -> (a :> b) -> (a :> c) -> (a :> u)++distrib op u@(D u0 u') v@(D v0 v') =+  D (u0 `op` v0) (trie (\ da -> distrib op u (v' `untrie` da) ^+^+                                distrib op (u' `untrie` da) v))++-- TODO: look for a simpler definition of distrib.  See inTrie2.++-- TODO: This distrib is exponential in increasing degree.  Switch to the+-- Horner representation.  See /The Music of Streams/ by Doug McIlroy.++ -- I'm not sure about the next three, which discard information  instance Show b => Show (a :> b) where show    = noOv "show" instance Eq   b => Eq   (a :> b) where (==)    = noOv "(==)" instance Ord  b => Ord  (a :> b) where compare = noOv "compare" -instance (LMapDom a s, VectorSpace u s) => AdditiveGroup (a :> u) where+instance (HasBasis a s, HasTrie (Basis a), VectorSpace u s) => AdditiveGroup (a :> u) where   zeroV   = pureD  zeroV    -- or dZero   negateV = fmapD  negateV   (^+^)   = liftD2 (^+^) -instance (LMapDom a s, VectorSpace u s) => VectorSpace (a :> u) s where+{-+instance (HasBasis a s, HasTrie (Basis a), VectorSpace u s) => VectorSpace (a :> u) s where   (*^) s = fmapD  ((*^) s)+-} -(**^) :: (VectorSpace c s, VectorSpace s s, LMapDom a s) =>+(**^) :: (HasBasis a s, HasTrie (Basis a), VectorSpace c s, VectorSpace s s) =>          (a :> s) -> (a :> c) -> (a :> c) (**^) = distrib (*^)  -- ouch!  InnerSpace one won't work at all, for the same reason as for functions.-                  + -- instance (InnerSpace u s) => InnerSpace (a :> u) s where --   (<.>) = distrib (<.>) -(<*.>) :: (LMapDom a s, InnerSpace b s, VectorSpace s s) =>+(<*.>) :: (HasBasis a s, HasTrie (Basis a), InnerSpace b s, VectorSpace s s) =>           (a :> b) -> (a :> b) -> (a :> s)-(<*.>) s = distrib (<.>) s+(<*.>) = distrib (<.>)   -- The instances below are the one I think we'll want externally. -- However, the ones above allow the definition of @a:>b@ to work out. -- The module "Data.Mac" rewraps to provide the alternate instances. --- instance (LMapDom a s, VectorSpace u s, VectorSpace s s)---     => VectorSpace (a :> u) (a :> s) where---   (*^) = (**^)+instance (HasBasis a s, HasTrie (Basis a), VectorSpace u s, VectorSpace s s)+         => VectorSpace (a :> u) (a :> s) where+  (*^) = (**^) --- instance (InnerSpace u s, InnerSpace s s', VectorSpace s s, LMapDom a s) =>---      InnerSpace (a :> u) (a :> s) where---   (<.>) = (<*.>)+instance ( InnerSpace u s, InnerSpace s s', VectorSpace s s+         , HasBasis a s, HasTrie (Basis a)) =>+     InnerSpace (a :> u) (a :> s) where+  (<.>) = (<*.>)  --- | Chain rule.  See also '(>-<)'.-(@.) :: (LMapDom b s, LMapDom a s, 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+-- 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 '(\@.)'-(>-<) :: (LMapDom a s, VectorSpace s s, VectorSpace u s) =>+(>-<) :: (HasBasis a s, HasTrie (Basis a), VectorSpace s s, VectorSpace u s) =>          (u -> u) -> ((a :> u) -> (a :> s))       -> (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) ((f' u **^) <$> u')  -- TODO: express '(>-<)' in terms of '(@.)'.  If I can't, then understand why not. -instance (LMapDom a b, Num b, VectorSpace b b) => Num (a:>b) where+instance (HasBasis a s, HasTrie (Basis a), Num s, VectorSpace s s) => Num (a:>s) where   fromInteger = pureD . fromInteger   (+) = liftD2  (+)   (-) = liftD2  (-)@@ -224,14 +286,16 @@   abs    = abs    >-< signum   signum = signum >-< 0  -- derivative wrong at zero -instance (LMapDom a b, Fractional b, VectorSpace b b) => Fractional (a:>b) where+instance (HasBasis a s, HasTrie (Basis a), Fractional s, VectorSpace s s)+         => Fractional (a:>s) where   fromRational = pureD . fromRational   recip        = recip >-< recip sqr  sqr :: Num a => a -> a sqr x = x*x -instance (LMapDom a b, Floating b, VectorSpace b b) => Floating (a:>b) where+instance (HasBasis a s, HasTrie (Basis a), Floating s, VectorSpace s s)+         => Floating (a:>s) where   pi    = pureD pi   exp   = exp   >-< exp   log   = log   >-< recip
src/Data/VectorSpace.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies -           , FlexibleInstances, UndecidableInstances+           , TypeOperators, FlexibleInstances, UndecidableInstances  #-} ---------------------------------------------------------------------- -- |@@ -13,6 +13,12 @@ -- Vector spaces ---------------------------------------------------------------------- +-- 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@@ -24,6 +30,7 @@ import Data.Complex hiding (magnitude)  import Data.AdditiveGroup+import Data.MemoTrie  infixr 7 *^, ^/, <.> infixl 7 ^*@@ -74,7 +81,7 @@ instance (RealFloat v, VectorSpace v s) => VectorSpace (Complex v) s where   s*^(u :+ v) = s*^u :+ s*^v -instance (RealFloat v, InnerSpace v s, VectorSpace s s')+instance (RealFloat v, InnerSpace v s, AdditiveGroup s)      => InnerSpace (Complex v) s where   (u :+ v) <.> (u' :+ v') = (u <.> u') ^+^ (v <.> v') @@ -82,31 +89,31 @@ -- questionable decision to place 'RealFloat' into the definition of the -- 'Complex' /type/, rather than in functions and instances as needed. --- With UndecidableInstances, I get---   Illegal instance declaration for `VectorSpace (u, v) s' (the---   Coverage Condition fails for one of the functional dependencies ...)- instance (VectorSpace u s,VectorSpace v s) => VectorSpace (u,v) s where   s *^ (u,v) = (s*^u,s*^v) -instance (InnerSpace u s,InnerSpace v s, VectorSpace s s')+instance (InnerSpace u s,InnerSpace v s, AdditiveGroup s)     => InnerSpace (u,v) s where   (u,v) <.> (u',v') = (u <.> u') ^+^ (v <.> v') --- We could use @Num s@ and @(+)@ in place of @VectorSpace s s'@ and @(^+^)@--- in the @InnerSpace@ instances for pairs and triples.- instance (VectorSpace u s,VectorSpace v s,VectorSpace w s)     => VectorSpace (u,v,w) s where   s *^ (u,v,w) = (s*^u,s*^v,s*^w) -instance (InnerSpace u s,InnerSpace v s,InnerSpace w s, VectorSpace s s')+instance (InnerSpace u s,InnerSpace v s,InnerSpace w s, AdditiveGroup s)     => InnerSpace (u,v,w) s where   (u,v,w) <.> (u',v',w') = u<.>u' ^+^ v<.>v' ^+^ w<.>w'  --- -- Standard instance for an applicative functor applied to a vector space.--- instance VectorSpace v s => VectorSpace (a->v) s where---   (*^) s = fmap (s *^)+-- Standard instance for an applicative functor applied to a vector space.+instance VectorSpace v s => VectorSpace (a->v) s where+  (*^) s = fmap (s *^)  -- No 'InnerSpace' instance for @(a->v)@.++instance (HasTrie u, VectorSpace v s, AdditiveGroup (u :->: v))+         => VectorSpace (u :->: v) s where+  (*^) s = fmap (s *^)++-- The 'AdditiveGroup' constraint is implied by the others, thanks to the+-- instance in Data.AdditiveGroup.  Why isn't ghc figuring it out?
tests/src/Perf.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeOperators, MultiParamTypeClasses, UndecidableInstances, FlexibleInstances+           , TypeFamilies, FlexibleContexts   #-}  @@ -15,6 +16,8 @@ import Data.VectorSpace import Data.Cross import Data.Derivative+import Data.Basis+import Data.MemoTrie import Data.LinearMap  type Surf s        = (s,s) -> (s,s,s)@@ -142,8 +145,10 @@ 		  else loop msg fun t (count + length points) pss 	    loop _ _ _ _ _ = return () +	let samples = samples_2d+ 	sequence_ [ do t <- getClockTime-		       loop msg fun t 0 (progressive_filter samples_2d)+		       loop msg fun t 0 samples 		  | (fun,msg) <- concat [ surfs, surfs, surfs, surfs2, surfs3 ] 	 	  ] @@ -160,13 +165,14 @@  type SurfPt s = (s,s) :> (s,s,s) -toVN3 :: (LMapDom s s,Floating s, InnerSpace s s) => SurfPt s -> ((s,s,s),(s,s,s))+toVN3 :: (HasBasis s s, Basis s ~ (), Floating s, InnerSpace s s)+         => SurfPt s -> ((s,s,s),(s,s,s)) toVN3 v = ( powVal v 	  , powVal (normal v) 	  )-vector3D :: (LMapDom a s,VectorSpace s s) => (a :> s,a :> s,a :> s) -> (a :> (s,s,s))+vector3D :: (HasBasis a s, HasTrie (Basis a), VectorSpace s s) => (a :> s,a :> s,a :> s) -> (a :> (s,s,s)) vector3D (u,v,w) = liftD3 (,,) u v w-unvector2D :: (Data.LinearMap.LMapDom a s,VectorSpace s s) => (a :> (s,s)) -> (a :> s,a :> s) +unvector2D :: (HasBasis a s, HasTrie (Basis a), VectorSpace s s) => (a :> (s,s)) -> (a :> s,a :> s)  unvector2D d = ( (\ (x,_) -> x) <$>> d 	       , (\ (_,y) -> y) <$>> d 	       )
vector-space.cabal view
@@ -1,15 +1,18 @@ Name:                vector-space-Version:             0.2.0+Version:             0.3 Cabal-Version:       >= 1.2-Synopsis:            Vector & affine spaces, plus derivatives+Synopsis:            Vector & affine spaces, linear maps, and derivatives Category:            math Description:-  vector-space provides classes and generic operations for vector+  '''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,+  and requires ghc version at least 6.9.+  .   Project wiki page: <http://haskell.org/haskellwiki/vector-space>   .   The module documentation pages have links to colorized source code and@@ -20,19 +23,20 @@ Maintainer:          conal@conal.net Homepage:            http://haskell.org/haskellwiki/vector-space Package-Url:         http://code.haskell.org/vector-space-Copyright:           (c) 2007-2008 by Conal Elliott+Copyright:           (c) 2008 by Conal Elliott License:             BSD3 Stability:           experimental build-type:          Simple-Build-Depends:       base, OpenGL   Library-  Hs-Source-Dirs:      src+  hs-Source-Dirs:      src   Extensions:          +  Build-Depends:       base, MemoTrie   Exposed-Modules:                           Data.AdditiveGroup                      Data.VectorSpace+                     Data.Basis                      Data.LinearMap                      Data.Maclaurin                      Data.Derivative@@ -42,12 +46,14 @@   ghc-options:         -Wall -O2   ghc-prof-options:    -prof -auto-all  -Executable Perf-  main-is:           Perf.hs-  build-depends:     base, OpenGL, old-time-  Hs-Source-Dirs:    src, tests/src-  ghc-options:       -Wall -O2-  ghc-prof-options:    -prof -auto-all   +--  -fno-method-sharing +-- Executable Perf+--   main-is:           Perf.hs+--   build-depends:     base, OpenGL, old-time+--   Hs-Source-Dirs:    src, tests/src+--   ghc-options:       -Wall -O2+--   ghc-prof-options:    -prof -auto-all   + --                   Data.Horner--- The OpenGL dependency is a temporary workaround for a ghc-6.8.2 type family bug.+-- For ghc-options: -ddump-simpl-stats -ddump-rules -ddump-simpl -ddump-simpl-phases