linearmap-category 0.4.3.0 → 0.5.0.0
raw patch · 7 files changed
+260/−194 lines, 7 files
Files
- Math/LinearMap/Category.hs +1/−1
- Math/LinearMap/Category/Class.hs +148/−104
- Math/LinearMap/Category/Instances.hs +26/−25
- Math/LinearMap/Category/Instances/Deriving.hs +64/−61
- Math/LinearMap/Coercion.hs +15/−0
- Math/VectorSpace/Docile.hs +4/−2
- linearmap-category.cabal +2/−1
Math/LinearMap/Category.hs view
@@ -418,7 +418,7 @@ -- v '<.>^' (w |&> 'euclideanNorm') ≡ v '<.>' w -- @ (|&>) :: LSpace v => DualVector v -> Variance v -> v-dv |&> Norm m = GHC.sym coerceDoubleDual $ m-+$>dv+dv |&> Norm m = symVSC coerceDoubleDual $ m-+$>dv -- | 'spanNorm' / 'spanVariance' are inefficient if the number of vectors
Math/LinearMap/Category/Class.hs view
@@ -47,6 +47,7 @@ import Math.VectorSpace.ZeroDimensional import Data.VectorSpace.Free +import Data.Kind (Type) import qualified GHC.Generics as Gnrx import GHC.Generics (Generic, (:*:)((:*:))) @@ -73,6 +74,41 @@ BoundarylessWitness v -> #endif LinearManifoldWitness v++-- | A coercion that is compatible with the vector space structure of the types.+-- Intended to be used for lossless conversion between newtype wrappers around+-- vector spaces, under the requirement that they internally use the same basis+-- (if any). Note that this does not mean they also need to have the same inner+-- product / dual space.+data VSCCoercion a b where+ VSCCoercion :: Coercible a b+ => VSCCoercion a b++getVSCCoercion :: VSCCoercion a b -> Coercion a b+getVSCCoercion VSCCoercion = Coercion++symVSC :: VSCCoercion a b -> VSCCoercion b a+symVSC VSCCoercion = VSCCoercion++firstVSC :: VSCCoercion a b -> VSCCoercion (a,c) (b,c)+firstVSC VSCCoercion = VSCCoercion++secondVSC :: VSCCoercion a b -> VSCCoercion (c,a) (c,b)+secondVSC VSCCoercion = VSCCoercion++unsafeFollowVSC :: Coercible a b => c a b -> VSCCoercion a b+unsafeFollowVSC _ = VSCCoercion++unsafeFloutVSC :: Coercible a b => c b a -> VSCCoercion a b+unsafeFloutVSC _ = VSCCoercion++instance Category VSCCoercion where+ id = VSCCoercion+ VSCCoercion . VSCCoercion = VSCCoercion+instance EnhancedCat Coercion VSCCoercion where+ arr = getVSCCoercion+instance EnhancedCat (->) VSCCoercion where+ arr VSCCoercion x = coerce x class (VectorSpace v, PseudoAffine v) => TensorSpace v where -- | The internal representation of a 'Tensor' product.@@ -80,7 +116,7 @@ -- For Euclidean spaces, this is generally constructed by replacing each @s@ -- scalar field in the @v@ vector with an entire @w@ vector. I.e., you have -- then a “nested vector” or, if @v@ is a @DualVector@ / “row vector”, a matrix.- type TensorProduct v w :: *+ type TensorProduct v w :: Type scalarSpaceWitness :: ScalarSpaceWitness v linearManifoldWitness :: LinearManifoldWitness v zeroTensor :: (TensorSpace w, Scalar w ~ Scalar v)@@ -120,7 +156,7 @@ , Scalar u ~ Scalar v, Scalar w ~ Scalar v, Scalar x ~ Scalar v ) => Bilinear ((w,x) -+> u) (v⊗w, v⊗x) (v⊗u) coerceFmapTensorProduct :: Hask.Functor p- => p v -> Coercion a b -> Coercion (TensorProduct v a) (TensorProduct v b)+ => p v -> VSCCoercion a b -> VSCCoercion (TensorProduct v a) (TensorProduct v b) -- | “Sanity-check” a vector. This typically amounts to detecting any NaN components, -- which should trigger a @Nothing@ result. Otherwise, the result should be @Just@ -- the input, but may also be optimised / memoised if applicable (i.e. for@@ -151,7 +187,7 @@ -- (In this case, a dual vector will be just a “row vector” if you consider -- @v@-vectors as “column vectors”. 'LinearMap' will then effectively have -- a matrix layout.)- type DualVector v :: *+ type DualVector v :: Type dualSpaceWitness :: DualSpaceWitness v @@ -178,9 +214,9 @@ , dualSpaceWitness :: DualSpaceWitness v ) of (ScalarSpaceWitness,DualSpaceWitness) -> arr asTensor >>> fromFlatTensor - coerceDoubleDual :: Coercion v (DualVector (DualVector v))+ coerceDoubleDual :: VSCCoercion v (DualVector (DualVector v)) coerceDoubleDual = case dualSpaceWitness :: DualSpaceWitness v of- DualSpaceWitness -> Coercion+ DualSpaceWitness -> VSCCoercion trace :: (v+>v) -+> Scalar v trace = case scalarSpaceWitness :: ScalarSpaceWitness v of@@ -261,7 +297,7 @@ transposeTensor = const0 fmapTensor = biConst0 fzipTensorWith = biConst0- coerceFmapTensorProduct _ Coercion = Coercion+ coerceFmapTensorProduct _ VSCCoercion = VSCCoercion wellDefinedVector Origin = Just Origin wellDefinedTensor (Tensor Origin) = Just (Tensor Origin) instance Num' s => LinearSpace (ZeroDim s) where@@ -273,7 +309,7 @@ tensorId = LinearMap Origin toLinearForm = LinearFunction . const $ LinearMap Origin fromLinearForm = const0- coerceDoubleDual = Coercion+ coerceDoubleDual = VSCCoercion contractTensorMap = const0 contractMapTensor = const0 contractLinearMapAgainst = biConst0@@ -310,28 +346,28 @@ -- linear mappings, but they also form a useful vector space on their own right. newtype Tensor s v w = Tensor {getTensorProduct :: TensorProduct v w} -asTensor :: Coercion (LinearMap s v w) (Tensor s (DualVector v) w)-asTensor = Coercion-fromTensor :: Coercion (Tensor s (DualVector v) w) (LinearMap s v w)-fromTensor = Coercion+asTensor :: VSCCoercion (LinearMap s v w) (Tensor s (DualVector v) w)+asTensor = VSCCoercion+fromTensor :: VSCCoercion (Tensor s (DualVector v) w) (LinearMap s v w)+fromTensor = VSCCoercion asLinearMap :: ∀ s v w . (LinearSpace v, Scalar v ~ s)- => Coercion (Tensor s v w) (LinearMap s (DualVector v) w)+ => VSCCoercion (Tensor s v w) (LinearMap s (DualVector v) w) asLinearMap = case dualSpaceWitness :: DualSpaceWitness v of- DualSpaceWitness -> Coercion+ DualSpaceWitness -> VSCCoercion fromLinearMap :: ∀ s v w . (LinearSpace v, Scalar v ~ s)- => Coercion (LinearMap s (DualVector v) w) (Tensor s v w)+ => VSCCoercion (LinearMap s (DualVector v) w) (Tensor s v w) fromLinearMap = case dualSpaceWitness :: DualSpaceWitness v of- DualSpaceWitness -> Coercion+ DualSpaceWitness -> VSCCoercion pseudoFmapTensorLHS :: (TensorProduct v w ~ TensorProduct v' w)- => c v v' -> Coercion (Tensor s v w) (Tensor s v' w)-pseudoFmapTensorLHS _ = Coercion+ => c v v' -> VSCCoercion (Tensor s v w) (Tensor s v' w)+pseudoFmapTensorLHS _ = VSCCoercion pseudoPrecomposeLinmap :: (TensorProduct (DualVector v) w ~ TensorProduct (DualVector v') w)- => c v' v -> Coercion (LinearMap s v w) (LinearMap s v' w)-pseudoPrecomposeLinmap _ = Coercion+ => c v' v -> VSCCoercion (LinearMap s v w) (LinearMap s v' w)+pseudoPrecomposeLinmap _ = VSCCoercion envTensorLHSCoercion :: ( TensorProduct v w ~ TensorProduct v' w , TensorProduct v w' ~ TensorProduct v' w' )@@ -513,9 +549,11 @@ subtractTensors (Tensor (fu, fv)) (Tensor (fu', fv')) = (fu ^-^ fu') <⊕ (fv ^-^ fv') toFlatTensor = case scalarSpaceWitness :: ScalarSpaceWitness u of- ScalarSpaceWitness -> follow Tensor <<< toFlatTensor *** toFlatTensor+ ScalarSpaceWitness -> LinearFunction coerce+ <<< toFlatTensor *** toFlatTensor fromFlatTensor = case scalarSpaceWitness :: ScalarSpaceWitness u of- ScalarSpaceWitness -> flout Tensor >>> fromFlatTensor *** fromFlatTensor+ ScalarSpaceWitness -> LinearFunction coerce+ >>> fromFlatTensor *** fromFlatTensor tensorProduct = bilinearFunction $ \(u,v) w -> Tensor ((tensorProduct-+$>u)-+$>w, (tensorProduct-+$>v)-+$>w) transposeTensor = LinearFunction $ \(Tensor (uw,vw))@@ -529,7 +567,7 @@ coerceFmapTensorProduct p cab = case ( coerceFmapTensorProduct (fst<$>p) cab , coerceFmapTensorProduct (snd<$>p) cab ) of- (Coercion, Coercion) -> Coercion+ (VSCCoercion, VSCCoercion) -> VSCCoercion wellDefinedVector (u,v) = liftA2 (,) (wellDefinedVector u) (wellDefinedVector v) wellDefinedTensor (Tensor (u,v)) = liftA2 ((Tensor.) . (,)) (wellDefinedTensor u) (wellDefinedTensor v)@@ -607,31 +645,31 @@ -- | @((v'⊗w)+>x) -> ((v+>w)+>x) argFromTensor :: ∀ s v w x . (LinearSpace v, LinearSpace w, Scalar v ~ s, Scalar w ~ s)- => Coercion (LinearMap s (Tensor s (DualVector v) w) x)+ => VSCCoercion (LinearMap s (Tensor s (DualVector v) w) x) (LinearMap s (LinearMap s v w) x) argFromTensor = case dualSpaceWitness :: DualSpaceWitness v of DualSpaceWitness -> curryLinearMap >>> fromLinearMap >>> coUncurryLinearMap -- | @((v+>w)+>x) -> ((v'⊗w)+>x)@ argAsTensor :: ∀ s v w x . (LinearSpace v, LinearSpace w, Scalar v ~ s, Scalar w ~ s)- => Coercion (LinearMap s (LinearMap s v w) x)+ => VSCCoercion (LinearMap s (LinearMap s v w) x) (LinearMap s (Tensor s (DualVector v) w) x) argAsTensor = case dualSpaceWitness :: DualSpaceWitness v of DualSpaceWitness -> uncurryLinearMap <<< asLinearMap <<< coCurryLinearMap -- | @(u+>(v⊗w)) -> (u+>v)⊗w@-deferLinearMap :: Coercion (LinearMap s u (Tensor s v w)) (Tensor s (LinearMap s u v) w)-deferLinearMap = Coercion+deferLinearMap :: VSCCoercion (LinearMap s u (Tensor s v w)) (Tensor s (LinearMap s u v) w)+deferLinearMap = VSCCoercion -- | @(u+>v)⊗w -> u+>(v⊗w)@-hasteLinearMap :: Coercion (Tensor s (LinearMap s u v) w) (LinearMap s u (Tensor s v w))-hasteLinearMap = Coercion+hasteLinearMap :: VSCCoercion (Tensor s (LinearMap s u v) w) (LinearMap s u (Tensor s v w))+hasteLinearMap = VSCCoercion -lassocTensor :: Coercion (Tensor s u (Tensor s v w)) (Tensor s (Tensor s u v) w)-lassocTensor = Coercion-rassocTensor :: Coercion (Tensor s (Tensor s u v) w) (Tensor s u (Tensor s v w))-rassocTensor = Coercion+lassocTensor :: VSCCoercion (Tensor s u (Tensor s v w)) (Tensor s (Tensor s u v) w)+lassocTensor = VSCCoercion+rassocTensor :: VSCCoercion (Tensor s (Tensor s u v) w) (Tensor s u (Tensor s v w))+rassocTensor = VSCCoercion instance ∀ s u v . ( LinearSpace u, TensorSpace v, Scalar u ~ s, Scalar v ~ s ) => TensorSpace (LinearMap s u v) where@@ -687,21 +725,21 @@ -> arr deferLinearMap <<< fzipWith (fzipWith f) <<< arr hasteLinearMap *** arr hasteLinearMap coerceFmapTensorProduct = cftlp dualSpaceWitness- where cftlp :: ∀ a b p . DualSpaceWitness u -> p (LinearMap s u v) -> Coercion a b- -> Coercion (TensorProduct (DualVector u) (Tensor s v a))+ where cftlp :: ∀ a b p . DualSpaceWitness u -> p (LinearMap s u v) -> VSCCoercion a b+ -> VSCCoercion (TensorProduct (DualVector u) (Tensor s v a)) (TensorProduct (DualVector u) (Tensor s v b)) cftlp DualSpaceWitness _ c = coerceFmapTensorProduct ([]::[DualVector u])- (fmap c :: Coercion (v⊗a) (v⊗b))+ (fmap c :: VSCCoercion (v⊗a) (v⊗b)) wellDefinedVector = case dualSpaceWitness :: DualSpaceWitness u of- DualSpaceWitness -> arr asTensor >>> wellDefinedTensor >>> arr (fmap fromTensor)+ DualSpaceWitness -> arr asTensor >>> wellDefinedTensor >>> arr (fmap (getVSCCoercion fromTensor)) wellDefinedTensor- = arr hasteLinearMap >>> wellDefinedVector >>> arr (fmap deferLinearMap)+ = arr hasteLinearMap >>> wellDefinedVector >>> arr (fmap (getVSCCoercion deferLinearMap)) -- | @((u+>v)+>w) -> u⊗(v+>w)@ coCurryLinearMap :: ∀ s u v w . ( LinearSpace u, Scalar u ~ s , LinearSpace v, Scalar v ~ s ) =>- Coercion (LinearMap s (LinearMap s u v) w) (Tensor s u (LinearMap s v w))+ VSCCoercion (LinearMap s (LinearMap s u v) w) (Tensor s u (LinearMap s v w)) coCurryLinearMap = case ( dualSpaceWitness :: DualSpaceWitness u , dualSpaceWitness :: DualSpaceWitness v ) of (DualSpaceWitness, DualSpaceWitness)@@ -710,7 +748,7 @@ -- | @(u⊗(v+>w)) -> (u+>v)+>w@ coUncurryLinearMap :: ∀ s u v w . ( LinearSpace u, Scalar u ~ s , LinearSpace v, Scalar v ~ s ) =>- Coercion (Tensor s u (LinearMap s v w)) (LinearMap s (LinearMap s u v) w)+ VSCCoercion (Tensor s u (LinearMap s v w)) (LinearMap s (LinearMap s u v) w) coUncurryLinearMap = case ( dualSpaceWitness :: DualSpaceWitness u , dualSpaceWitness :: DualSpaceWitness v ) of (DualSpaceWitness, DualSpaceWitness)@@ -718,17 +756,17 @@ -- | @((u⊗v)+>w) -> (u+>(v+>w))@ curryLinearMap :: ∀ u v w s . ( LinearSpace u, Scalar u ~ s )- => Coercion (LinearMap s (Tensor s u v) w) (LinearMap s u (LinearMap s v w))+ => VSCCoercion (LinearMap s (Tensor s u v) w) (LinearMap s u (LinearMap s v w)) curryLinearMap = case dualSpaceWitness :: DualSpaceWitness u of- DualSpaceWitness -> (Coercion :: Coercion ((u⊗v)+>w)+ DualSpaceWitness -> (VSCCoercion :: VSCCoercion ((u⊗v)+>w) ((DualVector u)⊗(Tensor s (DualVector v) w)) ) >>> fmap fromTensor >>> fromTensor -- | @(u+>(v+>w)) -> ((u⊗v)+>w)@ uncurryLinearMap :: ∀ u v w s . ( LinearSpace u, Scalar u ~ s )- => Coercion (LinearMap s u (LinearMap s v w)) (LinearMap s (Tensor s u v) w)+ => VSCCoercion (LinearMap s u (LinearMap s v w)) (LinearMap s (Tensor s u v) w) uncurryLinearMap = case dualSpaceWitness :: DualSpaceWitness u of- DualSpaceWitness -> (Coercion :: Coercion + DualSpaceWitness -> (VSCCoercion :: VSCCoercion ((DualVector u)⊗(Tensor s (DualVector v) w)) ((u⊗v)+>w) ) <<< fmap asTensor <<< asTensor@@ -751,7 +789,7 @@ tensorId = uncurryLinearMap . coUncurryLinearMap . fmap curryLinearMap . coCurryLinearMap . fmap deferLinearMap $ id coerceDoubleDual = case dualSpaceWitness :: DualSpaceWitness v of- DualSpaceWitness -> Coercion+ DualSpaceWitness -> VSCCoercion applyLinear = case dualSpaceWitness :: DualSpaceWitness u of DualSpaceWitness -> bilinearFunction $ \f g -> let tf = argAsTensor $ f@@ -821,13 +859,14 @@ -> arr lassocTensor <<< fzipWith (fzipWith f) <<< arr rassocTensor *** arr rassocTensor coerceFmapTensorProduct = cftlp- where cftlp :: ∀ a b p . p (Tensor s u v) -> Coercion a b- -> Coercion (TensorProduct u (Tensor s v a))+ where cftlp :: ∀ a b p . p (Tensor s u v) -> VSCCoercion a b+ -> VSCCoercion (TensorProduct u (Tensor s v a)) (TensorProduct u (Tensor s v b)) cftlp _ c = coerceFmapTensorProduct ([]::[u])- (fmap c :: Coercion (v⊗a) (v⊗b))+ (fmap c :: VSCCoercion (v⊗a) (v⊗b)) wellDefinedVector = wellDefinedTensor- wellDefinedTensor = arr rassocTensor >>> wellDefinedTensor >>> arr (fmap lassocTensor)+ wellDefinedTensor = arr (getVSCCoercion rassocTensor)+ >>> wellDefinedTensor >>> arr (fmap (getVSCCoercion lassocTensor)) instance ∀ s u v . (LinearSpace u, LinearSpace v, Scalar u ~ s, Scalar v ~ s) => LinearSpace (Tensor s u v) where type DualVector (Tensor s u v) = LinearMap s u (DualVector v)@@ -836,7 +875,7 @@ . fmap curryLinearMap . curryLinearMap $ tensorId coerceDoubleDual = case ( dualSpaceWitness :: DualSpaceWitness u , dualSpaceWitness :: DualSpaceWitness v ) of- (DualSpaceWitness, DualSpaceWitness) -> Coercion+ (DualSpaceWitness, DualSpaceWitness) -> VSCCoercion dualSpaceWitness = case ( dualSpaceWitness :: DualSpaceWitness u , dualSpaceWitness :: DualSpaceWitness v ) of (DualSpaceWitness, DualSpaceWitness) -> DualSpaceWitness@@ -895,22 +934,22 @@ DualSpaceWitness -> \f -> arr asTensor *** arr asTensor >>> fzipWith f >>> arr fromTensor instance (TensorSpace v, Scalar v ~ s)- => Functor (Tensor s v) Coercion Coercion where+ => Functor (Tensor s v) VSCCoercion VSCCoercion where fmap = crcFmap where crcFmap :: ∀ s v a b . (TensorSpace v, Scalar v ~ s)- => Coercion a b -> Coercion (Tensor s v a) (Tensor s v b)+ => VSCCoercion a b -> VSCCoercion (Tensor s v a) (Tensor s v b) crcFmap f = case coerceFmapTensorProduct ([]::[v]) f of- Coercion -> Coercion+ VSCCoercion -> VSCCoercion instance (LinearSpace v, Scalar v ~ s)- => Functor (LinearMap s v) Coercion Coercion where+ => Functor (LinearMap s v) VSCCoercion VSCCoercion where fmap = crcFmap dualSpaceWitness where crcFmap :: ∀ s v a b . (LinearSpace v, Scalar v ~ s)- => DualSpaceWitness v -> Coercion a b- -> Coercion (LinearMap s v a) (LinearMap s v b)+ => DualSpaceWitness v -> VSCCoercion a b+ -> VSCCoercion (LinearMap s v a) (LinearMap s v b) crcFmap DualSpaceWitness f = case coerceFmapTensorProduct ([]::[DualVector v]) f of- Coercion -> Coercion+ VSCCoercion -> VSCCoercion instance Category (LinearFunction s) where type Object (LinearFunction s) v = (TensorSpace v, Scalar v ~ s)@@ -931,8 +970,8 @@ terminal = const0 instance EnhancedCat (->) (LinearFunction s) where arr = getLinearFunction-instance EnhancedCat (LinearFunction s) Coercion where- arr = LinearFunction . coerceWith+instance EnhancedCat (LinearFunction s) VSCCoercion where+ arr VSCCoercion = LinearFunction coerce instance (LinearSpace w, Num' s, Scalar w ~ s) => Functor (LinearFunction s w) (LinearFunction s) (LinearFunction s) where@@ -945,13 +984,13 @@ sampleLinearFunctionFn = LinearFunction $ \f -> sampleLinearFunction -+$> f . applyLinear -fromLinearFn :: Coercion (LinearFunction s (LinearFunction s u v) w)+fromLinearFn :: VSCCoercion (LinearFunction s (LinearFunction s u v) w) (Tensor s (LinearFunction s v u) w)-fromLinearFn = Coercion+fromLinearFn = VSCCoercion -asLinearFn :: Coercion (Tensor s (LinearFunction s u v) w)+asLinearFn :: VSCCoercion (Tensor s (LinearFunction s u v) w) (LinearFunction s (LinearFunction s v u) w)-asLinearFn = Coercion+asLinearFn = VSCCoercion instance ∀ s u v . (LinearSpace u, LinearSpace v, Scalar u ~ s, Scalar v ~ s)@@ -977,7 +1016,7 @@ #endif zeroTensor = fromLinearFn $ const0 toFlatTensor = case scalarSpaceWitness :: ScalarSpaceWitness u of- ScalarSpaceWitness -> fmap fromLinearFn $ applyDualVector+ ScalarSpaceWitness -> fmap (getVSCCoercion fromLinearFn) $ applyDualVector fromFlatTensor = case ( scalarSpaceWitness :: ScalarSpaceWitness u , dualSpaceWitness :: DualSpaceWitness u ) of (ScalarSpaceWitness, DualSpaceWitness)@@ -1010,7 +1049,7 @@ fzipTensorWith = case scalarSpaceWitness :: ScalarSpaceWitness u of ScalarSpaceWitness -> bilinearFunction $ \f (g,h) -> fromLinearFn $ f . ((asLinearFn$g)&&&(asLinearFn$h))- coerceFmapTensorProduct _ Coercion = Coercion+ coerceFmapTensorProduct _ VSCCoercion = VSCCoercion wellDefinedVector = arr sampleLinearFunction >>> wellDefinedVector >>> fmap (arr applyLinear) wellDefinedTensor = arr asLinearFn >>> (. applyLinear)@@ -1020,9 +1059,9 @@ -> sampleLinearFunction >>> getLinearFunction applyLinear m) -exposeLinearFn :: Coercion (LinearMap s (LinearFunction s u v) w)+exposeLinearFn :: VSCCoercion (LinearMap s (LinearFunction s u v) w) (LinearFunction s (LinearFunction s u v) w)-exposeLinearFn = Coercion+exposeLinearFn = VSCCoercion instance (LinearSpace u, LinearSpace v, Scalar u ~ s, Scalar v ~ s) => LinearSpace (LinearFunction s u v) where@@ -1030,11 +1069,11 @@ dualSpaceWitness = case ( dualSpaceWitness :: DualSpaceWitness u , dualSpaceWitness :: DualSpaceWitness v ) of (DualSpaceWitness, DualSpaceWitness) -> DualSpaceWitness- linearId = sym exposeLinearFn $ id- tensorId = uncurryLinearMap . sym exposeLinearFn+ linearId = symVSC exposeLinearFn $ id+ tensorId = uncurryLinearMap . symVSC exposeLinearFn $ LinearFunction $ \f -> sampleLinearFunction-+$>tensorProduct-+$>f- coerceDoubleDual = Coercion- sampleLinearFunction = LinearFunction . arr $ sym exposeLinearFn+ coerceDoubleDual = VSCCoercion+ sampleLinearFunction = LinearFunction . arr $ symVSC exposeLinearFn applyDualVector = case scalarSpaceWitness :: ScalarSpaceWitness u of ScalarSpaceWitness -> bilinearFunction $ \f g -> trace . sampleLinearFunction -+$> f . g@@ -1105,7 +1144,7 @@ instance ∀ v s . TensorSpace v => TensorSpace (Gnrx.Rec0 v s) where type TensorProduct (Gnrx.Rec0 v s) w = TensorProduct v w wellDefinedVector = fmap Gnrx.K1 . wellDefinedVector . Gnrx.unK1- wellDefinedTensor = arr (fmap $ pseudoFmapTensorLHS Gnrx.K1)+ wellDefinedTensor = arr (fmap . getVSCCoercion $ pseudoFmapTensorLHS Gnrx.K1) . wellDefinedTensor . arr (pseudoFmapTensorLHS Gnrx.unK1) scalarSpaceWitness = genericTensorspaceError linearManifoldWitness = genericTensorspaceError@@ -1128,8 +1167,8 @@ where tT :: ∀ w . (TensorSpace w, Scalar w ~ Scalar v) => (Gnrx.Rec0 v s ⊗ w) -+> (w ⊗ Gnrx.Rec0 v s) tT = LinearFunction- $ arr (Coercion . coerceFmapTensorProduct ([]::[w])- (Coercion :: Coercion v (Gnrx.Rec0 v s)) . Coercion)+ $ arr (VSCCoercion . coerceFmapTensorProduct ([]::[w])+ (VSCCoercion :: VSCCoercion v (Gnrx.Rec0 v s)) . VSCCoercion) . getLinearFunction transposeTensor . arr (pseudoFmapTensorLHS Gnrx.unK1) fmapTensor = LinearFunction $ \f -> envTensorLHSCoercion Gnrx.K1 (fmapTensor-+$>f)@@ -1140,16 +1179,16 @@ , pseudoFmapTensorLHS Gnrx.unK1 $ xt ) coerceFmapTensorProduct = cmtp where cmtp :: ∀ p a b . Hask.Functor p- => p (Gnrx.Rec0 v s) -> Coercion a b- -> Coercion (TensorProduct (Gnrx.Rec0 v s) a)+ => p (Gnrx.Rec0 v s) -> VSCCoercion a b+ -> VSCCoercion (TensorProduct (Gnrx.Rec0 v s) a) (TensorProduct (Gnrx.Rec0 v s) b) cmtp p crc = case coerceFmapTensorProduct ([]::[v]) crc of- Coercion -> Coercion+ VSCCoercion -> VSCCoercion instance ∀ i c f p . TensorSpace (f p) => TensorSpace (Gnrx.M1 i c f p) where type TensorProduct (Gnrx.M1 i c f p) w = TensorProduct (f p) w wellDefinedVector = fmap Gnrx.M1 . wellDefinedVector . Gnrx.unM1- wellDefinedTensor = arr (fmap $ pseudoFmapTensorLHS Gnrx.M1)+ wellDefinedTensor = arr (fmap . getVSCCoercion $ pseudoFmapTensorLHS Gnrx.M1) . wellDefinedTensor . arr (pseudoFmapTensorLHS Gnrx.unM1) scalarSpaceWitness = genericTensorspaceError linearManifoldWitness = genericTensorspaceError@@ -1172,8 +1211,8 @@ where tT :: ∀ w . (TensorSpace w, Scalar w ~ Scalar (f p)) => (Gnrx.M1 i c f p ⊗ w) -+> (w ⊗ Gnrx.M1 i c f p) tT = LinearFunction- $ arr (Coercion . coerceFmapTensorProduct ([]::[w])- (Coercion :: Coercion (f p) (Gnrx.M1 i c f p)) . Coercion)+ $ arr (VSCCoercion . coerceFmapTensorProduct ([]::[w])+ (VSCCoercion :: VSCCoercion (f p) (Gnrx.M1 i c f p)) . VSCCoercion) . getLinearFunction transposeTensor . arr (pseudoFmapTensorLHS Gnrx.unM1) fmapTensor = LinearFunction $ \f -> envTensorLHSCoercion Gnrx.M1 (fmapTensor-+$>f)@@ -1184,11 +1223,11 @@ , pseudoFmapTensorLHS Gnrx.unM1 $ xt ) coerceFmapTensorProduct = cmtp where cmtp :: ∀ ぴ a b . Hask.Functor ぴ- => ぴ (Gnrx.M1 i c f p) -> Coercion a b- -> Coercion (TensorProduct (Gnrx.M1 i c f p) a)+ => ぴ (Gnrx.M1 i c f p) -> VSCCoercion a b+ -> VSCCoercion (TensorProduct (Gnrx.M1 i c f p) a) (TensorProduct (Gnrx.M1 i c f p) b) cmtp p crc = case coerceFmapTensorProduct ([]::[f p]) crc of- Coercion -> Coercion+ VSCCoercion -> VSCCoercion instance ∀ f g p . ( TensorSpace (f p), TensorSpace (g p), Scalar (f p) ~ Scalar (g p) ) => TensorSpace ((f:*:g) p) where@@ -1224,7 +1263,7 @@ coerceFmapTensorProduct p cab = case ( coerceFmapTensorProduct ((\(u:*:_)->u)<$>p) cab , coerceFmapTensorProduct ((\(_:*:v)->v)<$>p) cab ) of- (Coercion, Coercion) -> Coercion+ (VSCCoercion, VSCCoercion) -> VSCCoercion wellDefinedVector (u:*:v) = liftA2 (:*:) (wellDefinedVector u) (wellDefinedVector v) wellDefinedTensor (Tensor (u,v)) = liftA2 ((Tensor.) . (,)) (wellDefinedTensor u) (wellDefinedTensor v)@@ -1235,7 +1274,7 @@ => TensorSpace (GenericNeedle m) where type TensorProduct (GenericNeedle m) w = TensorProduct (Needle (VRep m)) w wellDefinedVector = fmap GenericNeedle . wellDefinedVector . getGenericNeedle- wellDefinedTensor = arr (fmap $ pseudoFmapTensorLHS GenericNeedle)+ wellDefinedTensor = arr (fmap . getVSCCoercion $ pseudoFmapTensorLHS GenericNeedle) . wellDefinedTensor . arr (pseudoFmapTensorLHS getGenericNeedle) scalarSpaceWitness = case scalarSpaceWitness :: ScalarSpaceWitness (Needle (VRep m)) of@@ -1271,9 +1310,9 @@ where tT :: ∀ w . (TensorSpace w, Scalar w ~ Scalar (Needle m)) => (GenericNeedle m ⊗ w) -+> (w ⊗ GenericNeedle m) tT = LinearFunction- $ arr (Coercion . coerceFmapTensorProduct ([]::[w])- (Coercion :: Coercion (Needle (VRep m))- (GenericNeedle m)) . Coercion)+ $ arr (VSCCoercion . coerceFmapTensorProduct ([]::[w])+ (VSCCoercion :: VSCCoercion (Needle (VRep m))+ (GenericNeedle m)) . VSCCoercion) . getLinearFunction transposeTensor . arr (pseudoFmapTensorLHS getGenericNeedle) fmapTensor = LinearFunction $ \f -> envTensorLHSCoercion GenericNeedle (fmapTensor-+$>f)@@ -1284,17 +1323,18 @@ , pseudoFmapTensorLHS getGenericNeedle $ xt ) coerceFmapTensorProduct = cmtp where cmtp :: ∀ p a b . Hask.Functor p- => p (GenericNeedle m) -> Coercion a b- -> Coercion (TensorProduct (GenericNeedle m) a)+ => p (GenericNeedle m) -> VSCCoercion a b+ -> VSCCoercion (TensorProduct (GenericNeedle m) a) (TensorProduct (GenericNeedle m) b) cmtp p crc = case coerceFmapTensorProduct ([]::[Needle (VRep m)]) crc of- Coercion -> Coercion+ VSCCoercion -> VSCCoercion instance (LinearSpace v, Num (Scalar v)) => LinearSpace (Gnrx.Rec0 v s) where type DualVector (Gnrx.Rec0 v s) = DualVector v dualSpaceWitness = genericTensorspaceError linearId = pseudoPrecomposeLinmap Gnrx.unK1- . fmap (follow Gnrx.K1) $ linearId+ . fmap VSCCoercion+ $ linearId applyDualVector = bilinearFunction $ \dv (Gnrx.K1 v) -> (applyDualVector-+$>dv)-+$>v applyLinear = bilinearFunction $ \(LinearMap f) (Gnrx.K1 v) -> (applyLinear-+$>LinearMap f)-+$>v@@ -1310,7 +1350,8 @@ type DualVector (Gnrx.M1 i c f p) = DualVector (f p) dualSpaceWitness = genericTensorspaceError linearId = pseudoPrecomposeLinmap Gnrx.unM1- . fmap (follow Gnrx.M1) $ linearId+ . fmap VSCCoercion+ $ linearId applyDualVector = bilinearFunction $ \dv (Gnrx.M1 v) -> (applyDualVector-+$>dv)-+$>v applyLinear = bilinearFunction $ \(LinearMap f) (Gnrx.M1 v) -> (applyLinear-+$>LinearMap f)-+$>v@@ -1368,8 +1409,10 @@ , dualSpaceWitness :: DualSpaceWitness (g p) ) of (DualSpaceWitness, DualSpaceWitness) -> \(Tensor (ft, gt))- -> Tensor <$> liftA2 (,) (fmap fromTensor $ wellDefinedTensor (fromLinearMap $ ft))- (fmap fromTensor $ wellDefinedTensor (fromLinearMap $ gt))+ -> Tensor <$> liftA2 (,) (fmap (getVSCCoercion fromTensor)+ $ wellDefinedTensor (fromLinearMap $ ft))+ (fmap (getVSCCoercion fromTensor)+ $ wellDefinedTensor (fromLinearMap $ gt)) scalarSpaceWitness = case scalarSpaceWitness :: ScalarSpaceWitness (f p) of ScalarSpaceWitness -> ScalarSpaceWitness linearManifoldWitness = LinearManifoldWitness@@ -1436,7 +1479,7 @@ (DualSpaceWitness, DualSpaceWitness) -> case ( coerceFmapTensorProduct ((\(GenericTupleDual u _)->u)<$>p) cab , coerceFmapTensorProduct ((\(GenericTupleDual _ v)->v)<$>p) cab ) of- (Coercion, Coercion) -> Coercion+ (VSCCoercion, VSCCoercion) -> VSCCoercion @@ -1537,7 +1580,7 @@ type TensorProduct (GenericNeedle' m) w = TensorProduct (DualVector (Needle (VRep m))) w wellDefinedVector = fmap GenericNeedle' . wellDefinedVector . getGenericNeedle'- wellDefinedTensor = arr (fmap $ pseudoFmapTensorLHS GenericNeedle')+ wellDefinedTensor = arr (fmap . getVSCCoercion $ pseudoFmapTensorLHS GenericNeedle') . wellDefinedTensor . arr (pseudoFmapTensorLHS getGenericNeedle') scalarSpaceWitness = case scalarSpaceWitness :: ScalarSpaceWitness (DualVector (Needle (VRep m))) of@@ -1573,9 +1616,9 @@ where tT :: ∀ w . (TensorSpace w, Scalar w ~ Scalar (Needle m)) => (GenericNeedle' m ⊗ w) -+> (w ⊗ GenericNeedle' m) tT = LinearFunction- $ arr (Coercion . coerceFmapTensorProduct ([]::[w])- (Coercion :: Coercion (DualVector (Needle (VRep m)))- (GenericNeedle' m)) . Coercion)+ $ arr (VSCCoercion . coerceFmapTensorProduct ([]::[w])+ (VSCCoercion :: VSCCoercion (DualVector (Needle (VRep m)))+ (GenericNeedle' m)) . VSCCoercion) . getLinearFunction transposeTensor . arr (pseudoFmapTensorLHS getGenericNeedle') fmapTensor = LinearFunction $ \f -> envTensorLHSCoercion GenericNeedle' (fmapTensor-+$>f)@@ -1586,12 +1629,12 @@ , pseudoFmapTensorLHS getGenericNeedle' $ xt ) coerceFmapTensorProduct = cmtp where cmtp :: ∀ p a b . Hask.Functor p- => p (GenericNeedle' m) -> Coercion a b- -> Coercion (TensorProduct (GenericNeedle' m) a)+ => p (GenericNeedle' m) -> VSCCoercion a b+ -> VSCCoercion (TensorProduct (GenericNeedle' m) a) (TensorProduct (GenericNeedle' m) b) cmtp p crc = case coerceFmapTensorProduct ([]::[DualVector (Needle (VRep m))]) crc of- Coercion -> Coercion+ VSCCoercion -> VSCCoercion instance ∀ s m . ( Num' s@@ -1600,7 +1643,8 @@ , Scalar (Needle (VRep m)) ~ s ) => LinearSpace (GenericNeedle m) where type DualVector (GenericNeedle m) = GenericNeedle' m- linearId = fmap (follow GenericNeedle) . pseudoPrecomposeLinmap getGenericNeedle+ linearId = fmap VSCCoercion+ . pseudoPrecomposeLinmap getGenericNeedle $ linearId dualSpaceWitness = case ( closedScalarWitness :: ClosedScalarWitness s , dualSpaceWitness :: DualSpaceWitness (Needle (VRep m)) ) of@@ -1629,7 +1673,7 @@ => LinearSpace (GenericNeedle' m) where type DualVector (GenericNeedle' m) = GenericNeedle m linearId = case dualSpaceWitness :: DualSpaceWitness (Needle (VRep m)) of- DualSpaceWitness -> fmap (follow GenericNeedle')+ DualSpaceWitness -> fmap VSCCoercion . pseudoPrecomposeLinmap getGenericNeedle' $ linearId dualSpaceWitness = case ( closedScalarWitness :: ClosedScalarWitness s , dualSpaceWitness :: DualSpaceWitness (Needle (VRep m)) ) of
Math/LinearMap/Category/Instances.hs view
@@ -107,26 +107,27 @@ scaleTensor = bilinearFunction $ \μ (Tensor t) -> Tensor $ μ*^t; \ addTensors (Tensor v) (Tensor w) = Tensor $ v ^+^ w; \ subtractTensors (Tensor v) (Tensor w) = Tensor $ v ^-^ w; \- negateTensor = pretendLike Tensor lNegateV; \- toFlatTensor = follow Tensor; \- fromFlatTensor = flout Tensor; \- tensorProduct = LinearFunction $ \μ -> follow Tensor . scaleWith μ; \- transposeTensor = toFlatTensor . flout Tensor; \- fmapTensor = LinearFunction $ pretendLike Tensor; \- fzipTensorWith = LinearFunction \- $ \f -> follow Tensor <<< f <<< flout Tensor *** flout Tensor; \- coerceFmapTensorProduct _ Coercion = Coercion; \+ negateTensor = LinearFunction $ \(Tensor v) -> Tensor (negateV v); \+ toFlatTensor = LinearFunction $ follow Tensor; \+ fromFlatTensor = LinearFunction $ flout Tensor; \+ tensorProduct = bilinearFunction $ \μ \+ -> follow Tensor . getLinearFunction (scaleWith μ); \+ transposeTensor = toFlatTensor . LinearFunction (flout Tensor); \+ fmapTensor = bilinearFunction $ \f (Tensor t) -> Tensor (f-+$>t); \+ fzipTensorWith = bilinearFunction \+ $ \(LinearFunction f) -> follow Tensor <<< f <<< flout Tensor *** flout Tensor; \+ coerceFmapTensorProduct _ VSCCoercion = VSCCoercion; \ wellDefinedTensor (Tensor w) = Tensor <$> wellDefinedVector w }; \ instance LinearSpace (S) where { \ type DualVector (S) = (S); \ dualSpaceWitness = DualSpaceWitness; \ linearId = LinearMap 1; \- tensorId = uncurryLinearMap $ LinearMap $ fmap (follow Tensor) -+$> id; \+ tensorId = uncurryLinearMap $ LinearMap $ fmap (LinearFunction $ follow Tensor) -+$> id; \ idTensor = Tensor 1; \- fromLinearForm = flout LinearMap; \- coerceDoubleDual = Coercion; \- contractTensorMap = flout Tensor . flout LinearMap; \- contractMapTensor = flout LinearMap . flout Tensor; \+ fromLinearForm = LinearFunction $ flout LinearMap; \+ coerceDoubleDual = VSCCoercion; \+ contractTensorMap = LinearFunction $ flout Tensor . flout LinearMap; \+ contractMapTensor = LinearFunction $ flout LinearMap . flout Tensor; \ applyDualVector = scale; \ applyLinear = LinearFunction $ \(LinearMap w) -> scaleV w; \ applyTensorFunctional = bilinearFunction $ \(LinearMap du) (Tensor u) -> du<.>^u; \@@ -168,9 +169,9 @@ scaleTensor = bilinearFunction \ $ \μ -> Tensor . fmap (μ*^) . getTensorProduct; \ toFlatTensor = case closedScalarWitness :: ClosedScalarWitness s of{ \- ClosedScalarWitness -> follow Tensor}; \+ ClosedScalarWitness -> LinearFunction $ follow Tensor}; \ fromFlatTensor = case closedScalarWitness :: ClosedScalarWitness s of{ \- ClosedScalarWitness -> flout Tensor}; \+ ClosedScalarWitness -> LinearFunction $ flout Tensor}; \ tensorProduct = bilinearFunction $ \w v -> Tensor $ fmap (*^v) w; \ transposeTensor = LinearFunction (tp); \ fmapTensor = bilinearFunction $ \@@ -178,7 +179,7 @@ fzipTensorWith = bilinearFunction $ \ \(LinearFunction f) (Tensor vw, Tensor vx) \ -> Tensor $ liftA2 (curry f) vw vx; \- coerceFmapTensorProduct _ Coercion = Coercion; \+ coerceFmapTensorProduct _ VSCCoercion = VSCCoercion; \ wellDefinedTensor = getTensorProduct >>> Hask.traverse wellDefinedVector \ >>> fmap Tensor }; \ instance ∀ s . (Num' s, Eq s) => LinearSpace (V s) where { \@@ -192,9 +193,9 @@ ; ti DualSpaceWitness = LinearMap $ \ fmap (\f -> fmap (LinearFunction $ Tensor . f)-+$>asTensor $ id) \ (tenid :: V (w -> V w)) }; \- coerceDoubleDual = Coercion; \+ coerceDoubleDual = VSCCoercion; \ fromLinearForm = case closedScalarWitness :: ClosedScalarWitness s of{ \- ClosedScalarWitness -> flout LinearMap}; \+ ClosedScalarWitness -> LinearFunction $ flout LinearMap}; \ contractTensorMap = LinearFunction $ (contraction) . coerce . getLinearMap; \ contractMapTensor = LinearFunction $ (contraction) . coerce . getTensorProduct; \ {-contractTensorWith = bilinearFunction $ \@@ -332,7 +333,7 @@ fmapTensor = bilinearFunction $ \f (Tensor a) -> Tensor $ map (f$) a fzipTensorWith = bilinearFunction $ \f (Tensor a, Tensor b) -> Tensor $ zipWith (curry $ arr f) a b- coerceFmapTensorProduct _ Coercion = Coercion+ coerceFmapTensorProduct _ VSCCoercion = VSCCoercion wellDefinedTensor (Tensor a) = Tensor <$> Hask.traverse wellDefinedVector a @@ -372,7 +373,7 @@ fmapTensor = bilinearFunction $ \f (Tensor a) -> Tensor $ map (f$) a fzipTensorWith = bilinearFunction $ \f (Tensor a, Tensor b) -> Tensor $ zipWith (curry $ arr f) a b- coerceFmapTensorProduct _ Coercion = Coercion+ coerceFmapTensorProduct _ VSCCoercion = VSCCoercion instance (Num' n, UArr.Unbox n) => LinearSpace (Sequence n) where type DualVector (Sequence n) = FinSuppSeq n@@ -490,7 +491,7 @@ tensorProduct = bilinearFunction $ \(SymTensor t) g -> Tensor $ fmap (LinearFunction (⊗g)) $ t transposeTensor = LinearFunction $ \(Tensor f) -> getLinearFunction (- arr (fmap Coercion) . transposeTensor . arr lassocTensor) f+ arr (fmap VSCCoercion) . transposeTensor . arr lassocTensor) f fmapTensor = bilinearFunction $ \f (Tensor t) -> Tensor $ fmap (fmap f) $ t fzipTensorWith = bilinearFunction $ \f (Tensor s, Tensor t) -> Tensor $ fzipWith (fzipWith f) $ (s,t)@@ -504,11 +505,11 @@ (ClosedScalarWitness, DualSpaceWitness) -> DualSpaceWitness linearId = case dualSpaceWitness :: DualSpaceWitness v of DualSpaceWitness -> LinearMap $ rassocTensor . asTensor- . fmap (follow SymTensor . asTensor) $ id+ . fmap (unsafeFollowVSC SymTensor . asTensor) $ id tensorId = LinearMap $ asTensor . fmap asTensor . curryLinearMap . fmap asTensor . curryLinearMap- . fmap (follow $ \t -> Tensor $ rassocTensor $ t)+ . fmap (unsafeFollowVSC $ \t -> Tensor $ rassocTensor $ t) $ id applyLinear = case dualSpaceWitness :: DualSpaceWitness v of DualSpaceWitness -> bilinearFunction $ \(LinearMap f) (SymTensor t)@@ -545,7 +546,7 @@ type v⊗〃+>w = LinearMap (Scalar v) (SymmetricTensor (Scalar v) v) w currySymBilin :: LinearSpace v => (v⊗〃+>w) -+> (v+>(v+>w))-currySymBilin = LinearFunction . arr $ fmap fromTensor . fromTensor . flout LinearMap+currySymBilin = LinearFunction . arr $ fmap fromTensor . fromTensor . VSCCoercion
Math/LinearMap/Category/Instances/Deriving.hs view
@@ -191,7 +191,7 @@ $(varP 'fzipTensorWith) = bilinearFunction $ \(LinearFunction f) (Tensor tv, Tensor tw) -> Tensor $ liftA2 (curry f) tv tw- $(varP 'coerceFmapTensorProduct) = \_ Coercion+ $(varP 'coerceFmapTensorProduct) = \_ VSCCoercion -> error "Cannot yet coerce tensors defined from a `HasBasis` instance. This would require `RoleAnnotations` on `:->:`. Cf. https://gitlab.haskell.org/ghc/ghc/-/issues/8177" |] , InstanceD Nothing <$> cxt <*> [t|BasisGeneratedSpace $v|] <*> do@@ -439,7 +439,7 @@ fzipTensorWith = bilinearFunction $ \(LinearFunction f) (Tensor tv, Tensor tw) -> Tensor $ liftA2 (curry f) tv tw- coerceFmapTensorProduct _ Coercion+ coerceFmapTensorProduct _ VSCCoercion = error "Cannot yet coerce tensors defined from a `HasBasis` instance. This would require `RoleAnnotations` on `:->:`. Cf. https://gitlab.haskell.org/ghc/ghc/-/issues/8177" @@ -623,7 +623,7 @@ #endif ) => AbstractTensorSpace v where abstractTensorProductsCoercion- :: Coercion (TensorProduct v w)+ :: VSCCoercion (TensorProduct v w) (TensorProduct (VectorSpaceImplementation v) w) class ( AbstractTensorSpace v, LinearSpace (VectorSpaceImplementation v)@@ -641,30 +641,30 @@ DualSpaceWitness -> scalarsSameInAbstraction @v φ abstractDualVectorCoercion :: ∀ a- . Coercion (AbstractDualVector a (VectorSpaceImplementation a))+ . VSCCoercion (AbstractDualVector a (VectorSpaceImplementation a)) (DualVector (VectorSpaceImplementation a))-abstractDualVectorCoercion = Coercion+abstractDualVectorCoercion = VSCCoercion abstractTensorsCoercion :: ∀ a c w . ( AbstractVectorSpace a, LinearSpace c , c ~ VectorSpaceImplementation a, TensorSpace w )- => Coercion (AbstractDualVector a c⊗w) (DualVector c⊗w)-abstractTensorsCoercion = Coercion+ => VSCCoercion (AbstractDualVector a c⊗w) (DualVector c⊗w)+abstractTensorsCoercion = VSCCoercion abstractLinmapCoercion :: ∀ a c w . ( AbstractLinearSpace a, LinearSpace c , c ~ VectorSpaceImplementation a, TensorSpace w )- => Coercion (AbstractDualVector a c+>w) (DualVector c+>w)+ => VSCCoercion (AbstractDualVector a c+>w) (DualVector c+>w) abstractLinmapCoercion = case ( dualSpaceWitness @c , abstractTensorProductsCoercion @a @w ) of- (DualSpaceWitness, Coercion) -> Coercion+ (DualSpaceWitness, VSCCoercion) -> VSCCoercion coerceLinearMapCodomain :: ∀ v w x . ( LinearSpace v, Coercible w x ) => (v+>w) -> (v+>x) coerceLinearMapCodomain = case dualSpaceWitness @v of DualSpaceWitness -> \(LinearMap m) -> LinearMap $ (coerceFmapTensorProduct ([]::[DualVector v])- (Coercion :: Coercion w x) $ m)+ (VSCCoercion :: VSCCoercion w x) $ m) instance (Show (DualVector c)) => Show (AbstractDualVector a c) where showsPrec p (AbstractDualVector_ φ) = showParen (p>10)@@ -774,8 +774,8 @@ , Scalar (DualVector c) ~ Scalar a ) => (AbstractDualVector a c ⊗ w) -+> (w ⊗ AbstractDualVector a c) tt = case coerceFmapTensorProduct @w []- (Coercion @(DualVector c) @(AbstractDualVector a c)) of- Coercion -> coerce (transposeTensor @(DualVector c) @w)+ (VSCCoercion @(DualVector c) @(AbstractDualVector a c)) of+ VSCCoercion -> coerce (transposeTensor @(DualVector c) @w) fmapTensor = ft where ft :: ∀ w x . ( TensorSpace w, Scalar w ~ Scalar a , TensorSpace x, Scalar x ~ Scalar a )@@ -813,7 +813,7 @@ (DualSpaceWitness, ScalarSpaceWitness) -> scalarsSameInAbstraction @a DualSpaceWitness linearId = witnessAbstractDualVectorTensorSpacyness @a @c- (sym (abstractLinmapCoercion @a)+ (symVSC (abstractLinmapCoercion @a) $ sampleLinearFunction @(DualVector c) -+$> linearFunction AbstractDualVector) tensorId = tid@@ -824,10 +824,10 @@ -> witnessAbstractDualVectorTensorSpacyness @a ( let LinearMap ida = linearId :: (DualVector c ⊗ w) +> (DualVector c ⊗ w) in LinearMap $ - sym (abstractTensorProductsCoercion @a+ symVSC (abstractTensorProductsCoercion @a @(DualVector w ⊗ (AbstractDualVector a c⊗w)) ) . coerceFmapTensorProduct ([]::[c ⊗ DualVector w])- (Coercion @(DualVector c ⊗ w) @(AbstractDualVector a c ⊗ w))+ (VSCCoercion @(DualVector c ⊗ w) @(AbstractDualVector a c ⊗ w)) $ ida ) applyDualVector = scalarsSameInAbstraction @a ( bilinearFunction $ \v (AbstractDualVector d) -> (applyDualVector -+$> d)-+$>(coerce v::c) )@@ -883,14 +883,14 @@ => (AbstractDualVector a c +> w) -> (SubBasis (AbstractDualVector a c), DList w) dclm = case (dualFinitenessWitness @c, abstractTensorProductsCoercion @a @w) of- (DualFinitenessWitness DualSpaceWitness, Coercion)+ (DualFinitenessWitness DualSpaceWitness, VSCCoercion) -> coerce (decomposeLinMap @(DualVector c) @w) decomposeLinMapWithin = scalarsSameInAbstraction @a dclm where dclm :: ∀ w . (LSpace w, Scalar w ~ Scalar c) => SubBasis (AbstractDualVector a c) -> (AbstractDualVector a c +> w) -> Either (SubBasis (AbstractDualVector a c), DList w) (DList w) dclm = case (dualFinitenessWitness @c, abstractTensorProductsCoercion @a @w) of- (DualFinitenessWitness DualSpaceWitness, Coercion)+ (DualFinitenessWitness DualSpaceWitness, VSCCoercion) -> coerce (decomposeLinMapWithin @(DualVector c) @w) recomposeSB = case dualFinitenessWitness @c of DualFinitenessWitness DualSpaceWitness -> scalarsSameInAbstraction @a@@ -907,13 +907,13 @@ => SubBasis (AbstractDualVector a c) -> [w] -> (AbstractDualVector a c +> w, [w]) rlm = case (dualFinitenessWitness @c, abstractTensorProductsCoercion @a @w) of- (DualFinitenessWitness DualSpaceWitness, Coercion)+ (DualFinitenessWitness DualSpaceWitness, VSCCoercion) -> coerce (recomposeLinMap @(DualVector c) @w) recomposeContraLinMap = scalarsSameInAbstraction @a rclm where rclm :: ∀ f w . (LinearSpace w, Scalar w ~ Scalar c, Hask.Functor f) => (f (Scalar w) -> w) -> f a -> AbstractDualVector a c +> w rclm = case (dualFinitenessWitness @c, abstractTensorProductsCoercion @a @w) of- (DualFinitenessWitness DualSpaceWitness, Coercion) -> \f ->+ (DualFinitenessWitness DualSpaceWitness, VSCCoercion) -> \f -> (coerce $ recomposeContraLinMap @(DualVector c) @w @f) f . fmap (coerce :: a -> c) recomposeContraLinMapTensor = scalarsSameInAbstraction @a rclmt@@ -928,7 +928,7 @@ , abstractTensorProductsCoercion @a @(DualVector u) , abstractTensorProductsCoercion @a @(Tensor (Scalar a) (DualVector u) w) ) of- (DualFinitenessWitness DualSpaceWitness, Coercion, Coercion) -> \f ->+ (DualFinitenessWitness DualSpaceWitness, VSCCoercion, VSCCoercion) -> \f -> (coerce $ recomposeContraLinMapTensor @(DualVector c) @u @w @f) f . fmap (coerce :: (AbstractDualVector a c+>DualVector u) -> (DualVector c+>DualVector u))@@ -959,14 +959,14 @@ tdbc = case (dualSpaceWitness @c, dualSpaceWitness @w) of (DualSpaceWitness, DualSpaceWitness) -> case abstractTensorProductsCoercion @a @(DualVector w) of- Coercion -> coerce (tensorDualBasisCandidates @(DualVector c) @w)+ VSCCoercion -> coerce (tensorDualBasisCandidates @(DualVector c) @w) symTensorDualBasisCandidates = scalarsSameInAbstraction @a- ( case ( coerceFmapTensorProduct @c [] (Coercion @a @c)+ ( case ( coerceFmapTensorProduct @c [] (VSCCoercion @a @c) . abstractTensorProductsCoercion @a @a , coerceFmapTensorProduct @(DualVector c) []- (Coercion @(AbstractDualVector a c) @(DualVector c))+ (VSCCoercion @(AbstractDualVector a c) @(DualVector c)) , dualSpaceWitness @c ) of- (Coercion, Coercion, DualSpaceWitness)+ (VSCCoercion, VSCCoercion, DualSpaceWitness) -> coerce (symTensorDualBasisCandidates @(DualVector c)) ) @@ -1112,14 +1112,14 @@ abstractVS_wellDefinedTensor = scalarsSameInAbstraction @v (case abstractTensorProductsCoercion @v @w of- Coercion -> coerce (wellDefinedTensor @(VectorSpaceImplementation v) @w))+ VSCCoercion -> coerce (wellDefinedTensor @(VectorSpaceImplementation v) @w)) abstractVS_tensorProduct :: ∀ v w . ( AbstractTensorSpace v , TensorSpace w, Scalar w ~ Scalar v ) => Bilinear v w (v ⊗ w) abstractVS_tensorProduct = scalarsSameInAbstraction @v ( case ( abstractTensorProductsCoercion @v @w ) of- Coercion -> coerce (tensorProduct @(VectorSpaceImplementation v) @w) )+ VSCCoercion -> coerce (tensorProduct @(VectorSpaceImplementation v) @w) ) abstractVS_transposeTensor :: ∀ v w . ( AbstractTensorSpace v , TensorSpace w, Scalar w ~ Scalar v@@ -1128,8 +1128,8 @@ = scalarsSameInAbstraction @v ( case ( abstractTensorProductsCoercion @v @w , coerceFmapTensorProduct @w []- (Coercion @(VectorSpaceImplementation v) @(v)) ) of- (Coercion, Coercion) -> scalarsSameInAbstraction @v+ (VSCCoercion @(VectorSpaceImplementation v) @(v)) ) of+ (VSCCoercion, VSCCoercion) -> scalarsSameInAbstraction @v (coerce (transposeTensor @(VectorSpaceImplementation v) @w)) ) @@ -1141,7 +1141,7 @@ = scalarsSameInAbstraction @v ( case ( abstractTensorProductsCoercion @v @u , abstractTensorProductsCoercion @v @w ) of- (Coercion, Coercion)+ (VSCCoercion, VSCCoercion) -> coerce (fmapTensor @(VectorSpaceImplementation v) @u @w) ) abstractVS_fzipTensorsWith :: ∀ v u w x . ( AbstractTensorSpace v@@ -1153,18 +1153,18 @@ ( case ( abstractTensorProductsCoercion @v @u , abstractTensorProductsCoercion @v @w , abstractTensorProductsCoercion @v @x ) of- (Coercion, Coercion, Coercion)+ (VSCCoercion, VSCCoercion, VSCCoercion) -> coerce (fzipTensorWith @(VectorSpaceImplementation v) @u @w @x) ) abstractVS_coerceFmapTensorProduct :: ∀ v u w p . ( AbstractTensorSpace v- ) => p v -> Coercion u w -> Coercion (TensorProduct v u) (TensorProduct v w)+ ) => p v -> VSCCoercion u w -> VSCCoercion (TensorProduct v u) (TensorProduct v w) abstractVS_coerceFmapTensorProduct _ crc = case ( abstractTensorProductsCoercion @v @u , abstractTensorProductsCoercion @v @w , coerceFmapTensorProduct @(VectorSpaceImplementation v) [] crc ) of- (Coercion, Coercion, Coercion) -> Coercion+ (VSCCoercion, VSCCoercion, VSCCoercion) -> VSCCoercion abstractVS_dualSpaceWitness :: ∀ v . (AbstractLinearSpace v , LinearSpace v@@ -1182,8 +1182,8 @@ abstractVS_linearId = case dualSpaceWitness @(VectorSpaceImplementation v) of DualSpaceWitness -> case coerceFmapTensorProduct @(DualVector (VectorSpaceImplementation v)) []- (Coercion @v @(VectorSpaceImplementation v)) of- Coercion -> coerce (linearId @(VectorSpaceImplementation v))+ (VSCCoercion @v @(VectorSpaceImplementation v)) of+ VSCCoercion -> coerce (linearId @(VectorSpaceImplementation v)) abstractVS_tensorId :: ∀ v w . ( AbstractLinearSpace v , LinearSpace (VectorSpaceImplementation v)@@ -1193,21 +1193,21 @@ (case (dualSpaceWitness @w, dualSpaceWitness @(VectorSpaceImplementation v)) of (DualSpaceWitness, DualSpaceWitness) -> case coerceFmapTensorProduct @(DualVector w) []- $ Coercion @(TensorProduct (VectorSpaceImplementation v) w)+ $ VSCCoercion @(TensorProduct (VectorSpaceImplementation v) w) @(VectorSpaceImplementation v ⊗ w) . abstractTensorProductsCoercion @v @w- . Coercion @(v ⊗ w) @(TensorProduct v w) of- Coercion+ . VSCCoercion @(v ⊗ w) @(TensorProduct v w) of+ VSCCoercion -> case ( coerceFmapTensorProduct @(DualVector (VectorSpaceImplementation v)) []- (Coercion :: Coercion+ (VSCCoercion :: VSCCoercion (Tensor (Scalar v) (DualVector w) (Tensor (Scalar v) v w)) (Tensor (Scalar v) (DualVector w) (Tensor (Scalar v) (VectorSpaceImplementation v) w))) ) of- Coercion+ VSCCoercion -> coerce (tensorId @(VectorSpaceImplementation v) @w) ) @@ -1233,7 +1233,7 @@ => Bilinear (DualVector (v⊗u)) (v⊗u) (Scalar v) abstractVS_applyTensorFunctional = scalarsSameInAbstraction @v (case abstractTensorProductsCoercion @v @u of- Coercion -> coerce (applyTensorFunctional @(VectorSpaceImplementation v) @u))+ VSCCoercion -> coerce (applyTensorFunctional @(VectorSpaceImplementation v) @u)) abstractVS_applyTensorLinMap :: ∀ v u w . ( AbstractLinearSpace v@@ -1243,12 +1243,12 @@ => Bilinear ((v⊗u)+>w) (v⊗u) w abstractVS_applyTensorLinMap = scalarsSameInAbstraction @v ( case abstractTensorProductsCoercion @v @u of- Coercion -> coerce (applyTensorLinMap @(VectorSpaceImplementation v) @u @w) )+ VSCCoercion -> coerce (applyTensorLinMap @(VectorSpaceImplementation v) @u @w) ) abstractSubbasisCoercion :: ∀ v . Coercible (SubBasis v) (SubBasis (VectorSpaceImplementation v))- => Coercion (SubBasis v) (SubBasis (VectorSpaceImplementation v))-abstractSubbasisCoercion = Coercion+ => VSCCoercion (SubBasis v) (SubBasis (VectorSpaceImplementation v))+abstractSubbasisCoercion = VSCCoercion precomposeCoercion :: Coercion a b -> Coercion (b -> c) (a -> c) precomposeCoercion Coercion = Coercion@@ -1276,14 +1276,15 @@ ( AbstractLinearSpace v, FiniteDimensional (VectorSpaceImplementation v) , Coercible (SubBasis v) (SubBasis (VectorSpaceImplementation v)) ) => SubBasis v-abstractVS_entireBasis = sym (abstractSubbasisCoercion @v)+abstractVS_entireBasis = symVSC (abstractSubbasisCoercion @v) $ entireBasis @(VectorSpaceImplementation v) abstractVS_enumerateSubBasis :: ∀ v . ( AbstractLinearSpace v, FiniteDimensional (VectorSpaceImplementation v) , Coercible (SubBasis v) (SubBasis (VectorSpaceImplementation v)) ) => SubBasis v -> [v]-abstractVS_enumerateSubBasis = precomposeCoercion (abstractSubbasisCoercion @v)+abstractVS_enumerateSubBasis = precomposeCoercion+ (getVSCCoercion $ abstractSubbasisCoercion @v) $ coerce (enumerateSubBasis @(VectorSpaceImplementation v)) abstractVS_decomposeLinMap :: ∀ v w .@@ -1293,9 +1294,10 @@ , LSpace w, Scalar w ~ Scalar v ) => (v +> w) -> (SubBasis v, DList w) abstractVS_decomposeLinMap = scalarsSameInAbstraction @v- ( postcomposeCoercion (firstCoercion $ sym (abstractSubbasisCoercion @v))+ ( postcomposeCoercion (firstCoercion $ sym+ (getVSCCoercion $ abstractSubbasisCoercion @v)) $ case abstractTensorProductsCoercion @v @w of- Coercion -> ( coerce (decomposeLinMap @(VectorSpaceImplementation v) @w)+ VSCCoercion -> ( coerce (decomposeLinMap @(VectorSpaceImplementation v) @w) :: (v +> w) -> ( SubBasis (VectorSpaceImplementation v) , DList w ) ) )@@ -1306,9 +1308,10 @@ , LSpace w, Scalar w ~ Scalar v ) => SubBasis v -> (v +> w) -> Either (SubBasis v, DList w) (DList w) abstractVS_decomposeLinMapWithin = scalarsSameInAbstraction @v- ( precomposeCoercion (abstractSubbasisCoercion @v)+ ( precomposeCoercion (getVSCCoercion $ abstractSubbasisCoercion @v) . postcomposeCoercion (postcomposeCoercion- . leftCoercion . firstCoercion $ sym (abstractSubbasisCoercion @v))+ . leftCoercion . firstCoercion $ sym+ (getVSCCoercion $ abstractSubbasisCoercion @v)) $ coerce (decomposeLinMapWithin @(VectorSpaceImplementation v) @w) ) @@ -1317,7 +1320,7 @@ , Coercible (SubBasis v) (SubBasis (VectorSpaceImplementation v)) ) => SubBasis v -> [Scalar v] -> (v, [Scalar v]) abstractVS_recomposeSB = scalarsSameInAbstraction @v- ( precomposeCoercion (abstractSubbasisCoercion @v)+ ( precomposeCoercion (getVSCCoercion $ abstractSubbasisCoercion @v) $ coerce (recomposeSB @(VectorSpaceImplementation v)) ) @@ -1327,9 +1330,9 @@ , FiniteDimensional w, Scalar w ~ Scalar v ) => SubBasis v -> SubBasis w -> [Scalar v] -> (v ⊗ w, [Scalar v]) abstractVS_recomposeSBTensor = scalarsSameInAbstraction @v- ( precomposeCoercion (abstractSubbasisCoercion @v)+ ( precomposeCoercion (getVSCCoercion $ abstractSubbasisCoercion @v) $ case abstractTensorProductsCoercion @v @w of- Coercion -> coerce (recomposeSBTensor @(VectorSpaceImplementation v) @w)+ VSCCoercion -> coerce (recomposeSBTensor @(VectorSpaceImplementation v) @w) ) abstractVS_recomposeLinMap :: ∀ v w . ( AbstractLinearSpace v@@ -1338,7 +1341,7 @@ , LSpace w, Scalar w ~ Scalar v ) => SubBasis v -> [w] -> (v +> w, [w]) abstractVS_recomposeLinMap = scalarsSameInAbstraction @v- ( precomposeCoercion (abstractSubbasisCoercion @v)+ ( precomposeCoercion (getVSCCoercion $ abstractSubbasisCoercion @v) $ coerce (recomposeLinMap @(VectorSpaceImplementation v) @w) ) @@ -1371,7 +1374,7 @@ => DualVector v -+> v abstractVS_uncanonicallyFromDual = scalarsSameInAbstraction @v ( case abstractDualVectorCoercion @v of- Coercion -> coerce (uncanonicallyFromDual @(VectorSpaceImplementation v))+ VSCCoercion -> coerce (uncanonicallyFromDual @(VectorSpaceImplementation v)) ) abstractVS_uncanonicallyToDual :: ∀ v . ( AbstractLinearSpace v@@ -1379,7 +1382,7 @@ => v -+> DualVector v abstractVS_uncanonicallyToDual = scalarsSameInAbstraction @v ( case abstractDualVectorCoercion @v of- Coercion -> coerce (uncanonicallyToDual @(VectorSpaceImplementation v))+ VSCCoercion -> coerce (uncanonicallyToDual @(VectorSpaceImplementation v)) ) abstractVS_tensorEquality :: ∀ v w . ( AbstractLinearSpace v@@ -1388,7 +1391,7 @@ => (v ⊗ w) -> (v ⊗ w) -> Bool abstractVS_tensorEquality = scalarsSameInAbstraction @v ( case abstractTensorProductsCoercion @v @w of- Coercion -> coerce (tensorEquality @(VectorSpaceImplementation v) @w)+ VSCCoercion -> coerce (tensorEquality @(VectorSpaceImplementation v) @w) ) abstractVS_dualBasisCandidates :: ∀ v . ( AbstractLinearSpace v@@ -1396,7 +1399,7 @@ => [(Int, v)] -> Forest (Int, DualVector v) abstractVS_dualBasisCandidates = scalarsSameInAbstraction @v ( case abstractDualVectorCoercion @v of- Coercion -> coerce (dualBasisCandidates @(VectorSpaceImplementation v))+ VSCCoercion -> coerce (dualBasisCandidates @(VectorSpaceImplementation v)) ) abstractVS_tensorDualBasisCandidates :: ∀ v w . ( AbstractLinearSpace v@@ -1412,7 +1415,7 @@ , abstractTensorProductsCoercion @v @(DualVector w) , abstractTensorProductsCoercion @v @w ) of- (Coercion, Coercion, Coercion)+ (VSCCoercion, VSCCoercion, VSCCoercion) -> coerce (tensorDualBasisCandidates @(VectorSpaceImplementation v) @w) ) @@ -1432,9 +1435,9 @@ , coerceFmapTensorProduct @(VectorSpaceImplementation v) [] crdv , coerceFmapTensorProduct @(VectorSpaceImplementation v) []- (Coercion @v @(VectorSpaceImplementation v))+ (VSCCoercion @v @(VectorSpaceImplementation v)) ) of- (Coercion, Coercion, Coercion, Coercion)+ (VSCCoercion, VSCCoercion, VSCCoercion, VSCCoercion) -> coerce (symTensorDualBasisCandidates @(VectorSpaceImplementation v)) ) @@ -1566,7 +1569,7 @@ "AbstractTensorSpace" -> InstanceD Nothing <$> cxt <*> [t|AbstractTensorSpace $a|] <*> [d| $(varP 'abstractTensorProductsCoercion)- = Coercion+ = VSCCoercion |] "LinearSpace" -> InstanceD Nothing <$> cxt <*> [t|LinearSpace $a|] <*> [d|
+ Math/LinearMap/Coercion.hs view
@@ -0,0 +1,15 @@+-- |+-- Module : Math.LinearMap.Coercion+-- Copyright : (c) Justus Sagemüller 2022+-- License : GPL v3+-- +-- Maintainer : (@) jsag $ hvl.no+-- Stability : experimental+-- Portability : portable+-- ++module Math.LinearMap.Coercion+ ( VSCCoercion(..)+ ) where++import Math.LinearMap.Category.Class
Math/VectorSpace/Docile.hs view
@@ -54,6 +54,8 @@ import Prelude () import qualified Prelude as Hask +import Data.Kind (Type)+ import Control.Category.Constrained.Prelude hiding ((^)) import Control.Arrow.Constrained import Control.Monad.Trans.State@@ -498,7 +500,7 @@ -- need to contain any information, it can simply have the full finite -- basis as its only value. Even for large sparse spaces, it should only -- have a very coarse structure that can be shared by many vectors.- data SubBasis v :: *+ data SubBasis v :: Type entireBasis :: SubBasis v @@ -955,7 +957,7 @@ = case ( dualFinitenessWitness :: DualFinitenessWitness u , dualSpaceWitness :: DualSpaceWitness v ) of (DualFinitenessWitness DualSpaceWitness, DualSpaceWitness) -> \(LinMapBasis bu bv)- -> arr (fmap asLinearMap) . enumerateSubBasis $ TensorBasis bu bv+ -> arr (fmap $ getVSCCoercion asLinearMap) . enumerateSubBasis $ TensorBasis bu bv subbasisDimension (LinMapBasis bu bv) = case ( dualFinitenessWitness :: DualFinitenessWitness u ) of (DualFinitenessWitness _) -> subbasisDimension bu * subbasisDimension bv
linearmap-category.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: linearmap-category-version: 0.4.3.0+version: 0.5.0.0 synopsis: Native, complete, matrix-free linear algebra. description: The term /numerical linear algebra/ is often used almost synonymous with /matrix modifications/. However, what's interesting@@ -40,6 +40,7 @@ library exposed-modules: Math.LinearMap.Category Math.LinearMap.Category.Instances.Deriving+ Math.LinearMap.Coercion Math.VectorSpace.ZeroDimensional Math.VectorSpace.Dual Math.VectorSpace.MiscUtil.MultiConstraints