linearmap-category-0.6.0.1: Math/LinearMap/Category/Instances.hs
-- |
-- Module : Math.LinearMap.Category.Instances
-- Copyright : (c) Justus Sagemüller 2016-2019
-- License : GPL v3
--
-- Maintainer : (@) jsag $ hvl.no
-- Stability : experimental
-- Portability : portable
--
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE TypeApplications #-}
module Math.LinearMap.Category.Instances where
import Math.VectorSpace.DimensionAware
import Math.LinearMap.Category.Class
import Data.VectorSpace
import Data.Basis
#if MIN_VERSION_manifolds_core(0,6,0)
import Math.Manifold.Core.Types (EmptyMfd)
#endif
import Math.Manifold.Core.PseudoAffine
import Prelude ()
import qualified Prelude as Hask
import Control.Category.Constrained.Prelude
import Control.Arrow.Constrained
import Data.Coerce
import Data.Type.Coercion
import Data.Tagged
import Data.Proxy
import Data.Foldable (foldl')
import Data.VectorSpace.Free
import Data.VectorSpace.Free.FiniteSupportedSequence
import Data.VectorSpace.Free.Sequence as Seq
import qualified Linear.Matrix as Mat
import qualified Linear.Vector as Mat
import qualified Linear.Metric as Mat
import Linear ( V0(V0), V1(V1), V2(V2), V3(V3), V4(V4)
, _x, _y, _z, _w )
import Control.Lens ((^.))
import Control.Monad.ST (ST)
import qualified Data.Vector as Arr
import qualified Data.Vector.Unboxed as UArr
import qualified Data.Vector.Generic as GArr
import Math.LinearMap.Asserted
import Math.VectorSpace.ZeroDimensional
import qualified Math.VectorSpace.DimensionAware.Theorems.MaybeNat as Maybe
import qualified Test.QuickCheck as QC
import GHC.TypeNats (natVal)
import qualified GHC.Exts as GHC
import qualified GHC.Generics as GHC
import Data.Singletons (SingI, sing, Sing)
#if MIN_VERSION_singletons(3,0,0)
import GHC.TypeLits.Singletons (withKnownNat)
#else
import Data.Singletons.TypeLits (withKnownNat)
#endif
#if MIN_VERSION_manifolds_core(0,6,0)
instance LinearSpace v => Semimanifold (EmptyMfd v) where
type Needle (EmptyMfd v) = v
p .+~^ _ = case p of {}
p .-~^ _ = case p of {}
semimanifoldWitness = case linearManifoldWitness @v of
LinearManifoldWitness -> SemimanifoldWitness
instance LinearSpace v => PseudoAffine (EmptyMfd v) where
p .-~. _ = case p of {}
p .-~! _ = case p of {}
#endif
infixr 7 <.>^
(<.>^) :: LinearSpace v => DualVector v -> v -> Scalar v
f<.>^v = (applyDualVector-+$>f)-+$>v
type ℝ = Double
autoLinearManifoldWitness :: (Semimanifold v, AffineSpace v, v ~ Needle v, v ~ Diff v
#if !MIN_VERSION_manifolds_core(0,6,0)
, v ~ Interior v
#endif
)
=> LinearManifoldWitness v
autoLinearManifoldWitness = LinearManifoldWitness
#if !MIN_VERSION_manifolds_core(0,6,0)
BoundarylessWitness
#endif
#define LinearScalarSpace(S) \
instance Num' (S) where {closedScalarWitness = ClosedScalarWitness}; \
instance TensorSpace (S) where { \
type TensorProduct (S) w = w; \
scalarSpaceWitness = ScalarSpaceWitness; \
linearManifoldWitness = autoLinearManifoldWitness; \
zeroTensor = Tensor zeroV; \
scaleTensor = bilinearFunction $ \μ (Tensor t) -> Tensor $ μ*^t; \
addTensors (Tensor v) (Tensor w) = Tensor $ v ^+^ w; \
subtractTensors (Tensor v) (Tensor w) = Tensor $ v ^-^ w; \
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; \
tensorUnsafeFromArrayWithOffset i ar \
= Tensor (unsafeFromArrayWithOffset i ar); \
tensorUnsafeWriteArrayWithOffset ar i (Tensor v) \
= unsafeWriteArrayWithOffset ar i v; \
coerceFmapTensorProduct _ VSCCoercion = Coercion; \
wellDefinedTensor (Tensor w) = Tensor <$> wellDefinedVector w }; \
instance LinearSpace (S) where { \
type DualVector (S) = (S); \
dualSpaceWitness = DualSpaceWitness; \
linearId = LinearMap 1; \
tensorId = uncurryLinearMap $ LinearMap $ fmap (LinearFunction $ follow Tensor) -+$> id; \
idTensor = Tensor 1; \
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; \
applyTensorLinMap = bilinearFunction $ \fℝuw (Tensor u) \
-> let LinearMap fuw = curryLinearMap $ fℝuw \
in (applyLinear-+$>fuw) -+$> u; \
composeLinear = bilinearFunction $ \f (LinearMap g) \
-> LinearMap $ (applyLinear-+$>f)-+$>g; \
useTupleLinearSpaceComponents _ = usingNonTupleTypeAsTupleError }
LinearScalarSpace(ℝ)
LinearScalarSpace(Float)
LinearScalarSpace(Rational)
{-# INLINE tensorUnsafeFromArrayWithOffsetViaList #-}
tensorUnsafeFromArrayWithOffsetViaList
:: ∀ v w n m α . ( n`Dimensional`v
, m`Dimensional`w
, Scalar v ~ Scalar w
, GArr.Vector α (Scalar v) )
=> ([w] -> TensorProduct v w) -> Int -> α (Scalar v) -> (v⊗w)
tensorUnsafeFromArrayWithOffsetViaList l2v i ar
= Tensor $ l2v [ unsafeFromArrayWithOffset
(i + j * dimension @w) ar
| j <- [0 .. dimension @v - 1] ]
{-# INLINE tensorUnsafeWriteArrayWithOffsetViaList #-}
tensorUnsafeWriteArrayWithOffsetViaList
:: ∀ v w n m α σ . ( n`Dimensional`v
, m`Dimensional`w
, Scalar v ~ Scalar w
, GArr.Vector α (Scalar v) )
=> (TensorProduct v w -> [w]) -> GArr.Mutable α σ (Scalar v)
-> Int -> (v⊗w) -> ST σ ()
tensorUnsafeWriteArrayWithOffsetViaList v2l ar i (Tensor t)
= forM_ (zip [0..] $ v2l t) $ \(j, v)
-> unsafeWriteArrayWithOffset ar
(i + j * dimension @w) v
#if MIN_VERSION_manifolds_core(0,6,0)
#define FreeLinSpaceInteriorDecls
#else
#define FreeLinSpaceInteriorDecls \
toInterior = pure; fromInterior = id; translateP = Tagged (^+^);
#endif
#define FreeLinearSpace( V, d, LV, tp \
, tenspl, tenid, dspan \
, contraction, contraaction \
, frls, tols ) \
instance Num s => Semimanifold (V s) where { \
type Needle (V s) = V s; \
FreeLinSpaceInteriorDecls \
(.+~^) = (^+^) }; \
instance Num s => PseudoAffine (V s) where { \
v.-~.w = pure (v^-^w); (.-~!) = (^-^) }; \
instance ∀ s . (Num' s, Eq s) => DimensionAware (V s) where { \
type StaticDimension (V s) = 'Just (d); \
dimensionalityWitness = IsStaticDimensional }; \
instance ∀ s . (Num' s, Eq s) => (d)`Dimensional`V (s) where { \
unsafeFromArrayWithOffset \
= unsafeFromArrayWithOffsetViaList (frls); \
unsafeWriteArrayWithOffset \
= unsafeWriteArrayWithOffsetViaList (tols) \
}; \
instance ∀ s . (Num' s, Eq s) => TensorSpace (V s) where { \
type TensorProduct (V s) w = V w; \
scalarSpaceWitness = case closedScalarWitness :: ClosedScalarWitness s of{ \
ClosedScalarWitness -> ScalarSpaceWitness}; \
linearManifoldWitness = autoLinearManifoldWitness; \
zeroTensor = Tensor $ pure zeroV; \
addTensors (Tensor m) (Tensor n) = Tensor $ liftA2 (^+^) m n; \
subtractTensors (Tensor m) (Tensor n) = Tensor $ liftA2 (^-^) m n; \
negateTensor = LinearFunction $ Tensor . fmap negateV . getTensorProduct; \
scaleTensor = bilinearFunction \
$ \μ -> Tensor . fmap (μ*^) . getTensorProduct; \
toFlatTensor = case closedScalarWitness :: ClosedScalarWitness s of{ \
ClosedScalarWitness -> LinearFunction $ follow Tensor}; \
fromFlatTensor = case closedScalarWitness :: ClosedScalarWitness s of{ \
ClosedScalarWitness -> LinearFunction $ flout Tensor}; \
tensorProduct = bilinearFunction $ \w v -> Tensor $ fmap (*^v) w; \
transposeTensor = LinearFunction (tp); \
fmapTensor = bilinearFunction $ \
\(LinearFunction f) -> pretendLike Tensor $ fmap f; \
fzipTensorWith = bilinearFunction $ \
\(LinearFunction f) (Tensor vw, Tensor vx) \
-> Tensor $ liftA2 (curry f) vw vx; \
tensorUnsafeFromArrayWithOffset \
= tensorUnsafeFromArrayWithOffsetViaList (frls); \
tensorUnsafeWriteArrayWithOffset \
= tensorUnsafeWriteArrayWithOffsetViaList (tols); \
coerceFmapTensorProduct _ VSCCoercion = Coercion; \
wellDefinedTensor = getTensorProduct >>> Hask.traverse wellDefinedVector \
>>> fmap Tensor }; \
instance ∀ s . (Num' s, Eq s) => LinearSpace (V s) where { \
type DualVector (V s) = V s; \
dualSpaceWitness = case closedScalarWitness :: ClosedScalarWitness s of \
{ClosedScalarWitness -> DualSpaceWitness}; \
linearId = LV Mat.identity; \
idTensor = Tensor Mat.identity; \
tensorId = ti dualSpaceWitness where \
{ ti :: ∀ w . (LinearSpace w, Scalar w ~ s) => DualSpaceWitness w -> (V s⊗w)+>(V s⊗w) \
; ti DualSpaceWitness = LinearMap $ \
fmap (\f -> fmap (LinearFunction $ Tensor . f)-+$>asTensor $ id) \
(tenid :: V (w -> V w)) }; \
coerceDoubleDual = VSCCoercion; \
fromLinearForm = case closedScalarWitness :: ClosedScalarWitness s of{ \
ClosedScalarWitness -> LinearFunction $ flout LinearMap}; \
contractTensorMap = LinearFunction $ (contraction) . coerce . getLinearMap; \
contractMapTensor = LinearFunction $ (contraction) . coerce . getTensorProduct; \
{-contractTensorWith = bilinearFunction $ \
\(Tensor wv) dw -> fmap (arr $ applyDualVector $ dw) wv; -} \
contractLinearMapAgainst = bilinearFunction $ getLinearMap >>> (contraaction); \
applyDualVector = bilinearFunction Mat.dot; \
applyLinear = bilinearFunction $ \(LV m) \
-> foldl' (^+^) zeroV . liftA2 (^*) m; \
applyTensorFunctional = bilinearFunction $ \(LinearMap f) (Tensor t) \
-> sum $ liftA2 (<.>^) f t; \
applyTensorLinMap = bilinearFunction $ \(LinearMap f) (Tensor t) \
-> foldl' (^+^) zeroV $ liftA2 ((fromTensor-+$=>) >>> \
getLinearFunction . getLinearFunction applyLinear) f t; \
composeLinear = bilinearFunction $ \
\f (LinearMap g) -> LinearMap $ fmap ((applyLinear-+$>f)-+$>) g; \
useTupleLinearSpaceComponents _ = usingNonTupleTypeAsTupleError }
FreeLinearSpace( V0, 0
, LinearMap
, \(Tensor V0) -> zeroV
, \_ -> LinearMap V0
, V0
, LinearMap V0
, \V0 -> zeroV
, \V0 _ -> 0
, \[] -> V0
, \V0 -> []
)
FreeLinearSpace( V1, 1
, LinearMap
, \(Tensor (V1 w₀)) -> w₀⊗V1 1
, \w -> LinearMap $ V1 (Tensor $ V1 w)
, V1 V1
, LinearMap . V1 . blockVectSpan $ V1 1
, \(V1 (V1 w)) -> w
, \(V1 x) f -> (f$x)^._x
, \[x] -> V1 x
, \(V1 x) -> [x]
)
FreeLinearSpace( V2, 2
, LinearMap
, \(Tensor (V2 w₀ w₁)) -> w₀⊗V2 1 0
^+^ w₁⊗V2 0 1
, \w -> LinearMap $ V2 (Tensor $ V2 w zeroV)
(Tensor $ V2 zeroV w)
, V2 (`V2`zeroV) (V2 zeroV)
, LinearMap $ V2 (blockVectSpan $ V2 1 0)
(blockVectSpan $ V2 0 1)
, \(V2 (V2 w₀ _)
(V2 _ w₁)) -> w₀^+^w₁
, \(V2 x y) f -> (f$x)^._x + (f$y)^._y
, \(x:y:[]) -> V2 x y
, \(V2 x y) -> (x:y:[])
)
FreeLinearSpace( V3, 3
, LinearMap
, \(Tensor (V3 w₀ w₁ w₂)) -> w₀⊗V3 1 0 0
^+^ w₁⊗V3 0 1 0
^+^ w₂⊗V3 0 0 1
, \w -> LinearMap $ V3 (Tensor $ V3 w zeroV zeroV)
(Tensor $ V3 zeroV w zeroV)
(Tensor $ V3 zeroV zeroV w)
, V3 (\w -> V3 w zeroV zeroV)
(\w -> V3 zeroV w zeroV)
(\w -> V3 zeroV zeroV w)
, LinearMap $ V3 (blockVectSpan $ V3 1 0 0)
(blockVectSpan $ V3 0 1 0)
(blockVectSpan $ V3 0 0 1)
, \(V3 (V3 w₀ _ _)
(V3 _ w₁ _)
(V3 _ _ w₂)) -> w₀^+^w₁^+^w₂
, \(V3 x y z) f -> (f$x)^._x + (f$y)^._y + (f$z)^._z
, \(x:y:z:[]) -> V3 x y z
, \(V3 x y z) -> x:y:z:[]
)
FreeLinearSpace( V4, 4
, LinearMap
, \(Tensor (V4 w₀ w₁ w₂ w₃)) -> w₀⊗V4 1 0 0 0
^+^ w₁⊗V4 0 1 0 0
^+^ w₂⊗V4 0 0 1 0
^+^ w₃⊗V4 0 0 0 1
, \w -> V4 (LinearMap $ V4 w zeroV zeroV zeroV)
(LinearMap $ V4 zeroV w zeroV zeroV)
(LinearMap $ V4 zeroV zeroV w zeroV)
(LinearMap $ V4 zeroV zeroV zeroV w)
, V4 (\w -> V4 w zeroV zeroV zeroV)
(\w -> V4 zeroV w zeroV zeroV)
(\w -> V4 zeroV zeroV w zeroV)
(\w -> V4 zeroV zeroV zeroV w)
, LinearMap $ V4 (blockVectSpan $ V4 1 0 0 0)
(blockVectSpan $ V4 0 1 0 0)
(blockVectSpan $ V4 0 0 1 0)
(blockVectSpan $ V4 0 0 0 1)
, \(V4 (V4 w₀ _ _ _)
(V4 _ w₁ _ _)
(V4 _ _ w₂ _)
(V4 _ _ _ w₃)) -> w₀^+^w₁^+^w₂^+^w₃
, \(V4 x y z w) f -> (f$x)^._x + (f$y)^._y + (f$z)^._z + (f$w)^._w
, \(x:y:z:w:[]) -> V4 x y z w
, \(V4 x y z w) -> x:y:z:w:[]
)
instance (Num' n, TensorProduct (DualVector n) n ~ n) => Num (LinearMap n n n) where
LinearMap n + LinearMap m = LinearMap $ n + m
LinearMap n - LinearMap m = LinearMap $ n - m
LinearMap n * LinearMap m = LinearMap $ n * m
abs (LinearMap n) = LinearMap $ abs n
signum (LinearMap n) = LinearMap $ signum n
fromInteger = LinearMap . fromInteger
instance (Fractional' n, TensorProduct (DualVector n) n ~ n)
=> Fractional (LinearMap n n n) where
LinearMap n / LinearMap m = LinearMap $ n / m
recip (LinearMap n) = LinearMap $ recip n
fromRational = LinearMap . fromRational
instance (Num' n, UArr.Unbox n) => Semimanifold (FinSuppSeq n) where
type Needle (FinSuppSeq n) = FinSuppSeq n
(.+~^) = (.+^)
#if !MIN_VERSION_manifolds_core(0,6,0)
translateP = Tagged (.+^); toInterior = pure; fromInterior = id
#endif
instance (Num' n, UArr.Unbox n) => PseudoAffine (FinSuppSeq n) where
v.-~.w = Just $ v.-.w; (.-~!) = (.-.)
instance (Num' n, UArr.Unbox n) => DimensionAware (FinSuppSeq n) where
type StaticDimension (FinSuppSeq n) = 'Nothing
dimensionalityWitness = IsFlexibleDimensional
instance (Num' n, UArr.Unbox n) => TensorSpace (FinSuppSeq n) where
type TensorProduct (FinSuppSeq n) v = [v]
wellDefinedVector (FinSuppSeq v) = FinSuppSeq <$> UArr.mapM wellDefinedVector v
scalarSpaceWitness = case closedScalarWitness :: ClosedScalarWitness n of
ClosedScalarWitness -> ScalarSpaceWitness
linearManifoldWitness = autoLinearManifoldWitness
zeroTensor = Tensor []
toFlatTensor = LinearFunction $ Tensor . UArr.toList . getFiniteSeq
fromFlatTensor = LinearFunction $ FinSuppSeq . UArr.fromList . getTensorProduct
addTensors (Tensor s) (Tensor t) = Tensor $ Mat.liftU2 (^+^) s t
subtractTensors (Tensor s) (Tensor t) = Tensor $ Mat.liftU2 (^-^) s t
scaleTensor = bilinearFunction $ \μ (Tensor t) -> Tensor $ (μ*^)<$>t
negateTensor = LinearFunction $ \(Tensor t) -> Tensor $ negateV<$>t
tensorProduct = bilinearFunction
$ \(FinSuppSeq v) w -> Tensor $ (*^w)<$>UArr.toList v
transposeTensor = LinearFunction $ \(Tensor a)
-> let n = length a
in foldl' (^+^) zeroV
$ zipWith ( \i w -> getLinearFunction tensorProduct w $ basisValue i )
[0..] a
fmapTensor = bilinearFunction $ \f (Tensor a) -> Tensor $ map (f$) a
fzipTensorWith = bilinearFunction $ \f (Tensor a, Tensor b)
-> Tensor $ zipWith (curry $ arr f) a b
tensorUnsafeFromArrayWithOffset
= notStaticDimensionalContradiction @(FinSuppSeq n)
tensorUnsafeWriteArrayWithOffset
= notStaticDimensionalContradiction @(FinSuppSeq n)
coerceFmapTensorProduct _ VSCCoercion = Coercion
wellDefinedTensor (Tensor a) = Tensor <$> Hask.traverse wellDefinedVector a
instance (Num' n, UArr.Unbox n) => Semimanifold (Sequence n) where
type Needle (Sequence n) = Sequence n
(.+~^) = (.+^)
#if !MIN_VERSION_manifolds_core(0,6,0)
translateP = Tagged (.+^); toInterior = pure; fromInterior = id
#endif
instance (Num' n, UArr.Unbox n) => PseudoAffine (Sequence n) where
v.-~.w = Just $ v.-.w; (.-~!) = (.-.)
instance (Num' n, UArr.Unbox n) => DimensionAware (Sequence n) where
type StaticDimension (Sequence n) = 'Nothing
dimensionalityWitness = IsFlexibleDimensional
instance (Num' n, UArr.Unbox n) => TensorSpace (Sequence n) where
type TensorProduct (Sequence n) v = [v]
wellDefinedVector (SoloChunk n c) = SoloChunk n <$> UArr.mapM wellDefinedVector c
wellDefinedVector (Sequence h r) = Sequence <$> UArr.mapM wellDefinedVector h
<*> wellDefinedVector r
wellDefinedTensor (Tensor a) = Tensor <$> Hask.traverse wellDefinedVector a
scalarSpaceWitness = case closedScalarWitness :: ClosedScalarWitness n of
ClosedScalarWitness -> ScalarSpaceWitness
linearManifoldWitness = autoLinearManifoldWitness
zeroTensor = Tensor []
toFlatTensor = LinearFunction $ Tensor . GHC.toList
fromFlatTensor = LinearFunction $ GHC.fromList . getTensorProduct
addTensors (Tensor s) (Tensor t) = Tensor $ Mat.liftU2 (^+^) s t
subtractTensors (Tensor s) (Tensor t) = Tensor $ Mat.liftU2 (^-^) s t
scaleTensor = bilinearFunction $ \μ (Tensor t) -> Tensor $ (μ*^)<$>t
negateTensor = LinearFunction $ \(Tensor t) -> Tensor $ negateV<$>t
tensorProduct = bilinearFunction
$ \v w -> Tensor $ (*^w)<$>GHC.toList v
transposeTensor = LinearFunction $ \(Tensor a)
-> let n = length a
in foldl' (^+^) zeroV
$ zipWith (\i w -> (getLinearFunction tensorProduct w) $ basisValue i)
[0..] a
fmapTensor = bilinearFunction $ \f (Tensor a) -> Tensor $ map (f$) a
fzipTensorWith = bilinearFunction $ \f (Tensor a, Tensor b)
-> Tensor $ zipWith (curry $ arr f) a b
tensorUnsafeFromArrayWithOffset
= notStaticDimensionalContradiction @(Sequence n)
tensorUnsafeWriteArrayWithOffset
= notStaticDimensionalContradiction @(Sequence n)
coerceFmapTensorProduct _ VSCCoercion = Coercion
instance ∀ n . (Num' n, UArr.Unbox n) => LinearSpace (Sequence n) where
type DualVector (Sequence n) = FinSuppSeq n
dualSpaceWitness = case closedScalarWitness :: ClosedScalarWitness n of
ClosedScalarWitness -> DualSpaceWitness
linearId = LinearMap [basisValue i | i<-[0..]]
tensorId = LinearMap [asTensor -+$=> fmap (LinearFunction $
\w -> Tensor $ replicate (i-1) zeroV ++ [w]) $ id | i<-[0..]]
applyDualVector = bilinearFunction $ adv Seq.minimumChunkSize
where adv _ (FinSuppSeq v) (Seq.SoloChunk o q)
= UArr.sum $ UArr.zipWith (*) (UArr.drop o v) q
adv chunkSize (FinSuppSeq v) (Sequence c r)
| UArr.length v > chunkSize
= UArr.sum (UArr.zipWith (*) v c)
+ adv (chunkSize*2) (FinSuppSeq $ UArr.drop chunkSize v) r
| otherwise = UArr.sum $ UArr.zipWith (*) v c
applyLinear = bilinearFunction $ apl Seq.minimumChunkSize
where apl _ (LinearMap m) (Seq.SoloChunk o q)
= sumV $ zipWith (*^) (UArr.toList q) (drop o m)
apl chunkSize (LinearMap m) (Sequence c r)
| null mr = sumV $ zipWith (*^) (UArr.toList c) mc
| otherwise = foldl' (^+^) (apl (chunkSize*2) (LinearMap mr) r)
(zipWith (*^) (UArr.toList c) mc)
where (mc, mr) = splitAt chunkSize m
applyTensorFunctional = bilinearFunction
$ \(LinearMap m) (Tensor t) -> sum $ zipWith (<.>^) m t
applyTensorLinMap = bilinearFunction $ arr curryLinearMap >>>
\(LinearMap m) (Tensor t)
-> sumV $ zipWith (getLinearFunction . getLinearFunction applyLinear) m t
useTupleLinearSpaceComponents _ = usingNonTupleTypeAsTupleError
coerceDoubleDual = case scalarSpaceWitness @n of
ScalarSpaceWitness -> VSCCoercion
instance ∀ n . (Num' n, UArr.Unbox n) => LinearSpace (FinSuppSeq n) where
type DualVector (FinSuppSeq n) = Sequence n
dualSpaceWitness = case closedScalarWitness :: ClosedScalarWitness n of
ClosedScalarWitness -> DualSpaceWitness
linearId = LinearMap [basisValue i | i<-[0..]]
tensorId = LinearMap [asTensor -+$=> fmap (LinearFunction $
\w -> Tensor $ replicate (i-1) zeroV ++ [w]) $ id | i<-[0..]]
applyDualVector = bilinearFunction $ adv Seq.minimumChunkSize
where adv _ (Seq.SoloChunk o q) (FinSuppSeq v)
= UArr.sum $ UArr.zipWith (*) q (UArr.drop o v)
adv chunkSize (Sequence c r) (FinSuppSeq v)
| UArr.length v > chunkSize
= UArr.sum (UArr.zipWith (*) c v)
+ adv (chunkSize*2) r (FinSuppSeq $ UArr.drop chunkSize v)
| otherwise = UArr.sum $ UArr.zipWith (*) c v
applyLinear = bilinearFunction $ \(LinearMap m) (FinSuppSeq v)
-> foldl' (^+^) zeroV $ zipWith (*^) (UArr.toList v) m
applyTensorFunctional = bilinearFunction
$ \(LinearMap m) (Tensor t) -> sum $ zipWith (<.>^) m t
applyTensorLinMap = bilinearFunction $ arr curryLinearMap >>>
\(LinearMap m) (Tensor t)
-> sumV $ zipWith (getLinearFunction . getLinearFunction applyLinear) m t
useTupleLinearSpaceComponents _ = usingNonTupleTypeAsTupleError
coerceDoubleDual = case scalarSpaceWitness @n of
ScalarSpaceWitness -> VSCCoercion
instance GHC.IsList (Tensor s (Sequence s) v) where
type Item (Tensor s (Sequence s) v) = v
fromList = Tensor
toList = getTensorProduct
instance GHC.IsList (Tensor s (FinSuppSeq s) v) where
type Item (Tensor s (FinSuppSeq s) v) = v
fromList = Tensor
toList = getTensorProduct
newtype SymmetricTensor s v
= SymTensor { getSymmetricTensor :: Tensor s v v }
deriving instance (Show (Tensor s v v)) => Show (SymmetricTensor s v)
instance (TensorSpace v, Scalar v ~ s) => AffineSpace (SymmetricTensor s v) where
type Diff (SymmetricTensor s v) = SymmetricTensor s v
(.+^) = (^+^)
(.-.) = (^-^)
instance (TensorSpace v, Scalar v ~ s) => AdditiveGroup (SymmetricTensor s v) where
SymTensor s ^+^ SymTensor t = SymTensor $ s ^+^ t
zeroV = SymTensor zeroV
negateV (SymTensor t) = SymTensor $ negateV t
instance (TensorSpace v, Scalar v ~ s)
=> VectorSpace (SymmetricTensor s v) where
type Scalar (SymmetricTensor s v) = s
μ *^ SymTensor f = SymTensor $ μ*^f
instance (TensorSpace v, Scalar v ~ s) => Semimanifold (SymmetricTensor s v) where
type Needle (SymmetricTensor s v) = SymmetricTensor s v
(.+~^) = (^+^)
#if !MIN_VERSION_manifolds_core(0,6,0)
fromInterior = id
toInterior = pure
translateP = Tagged (^+^)
#endif
instance (TensorSpace v, Scalar v ~ s) => PseudoAffine (SymmetricTensor s v) where
(.-~!) = (^-^)
p.-~.q = pure (p^-^q)
instance ∀ s v . (Num' s, TensorSpace v, Scalar v ~ s)
=> DimensionAware (SymmetricTensor s v) where
type StaticDimension (SymmetricTensor s v)
= Maybe.FmapTriangularNum (StaticDimension v)
dimensionalityWitness = case dimensionalityWitness @v of
IsFlexibleDimensional -> IsFlexibleDimensional
IsStaticDimensional
-> withKnownNat (Maybe.triangularNumSing (dimensionalitySing @v))
IsStaticDimensional
instance ∀ s v n m . ( Num' s, n`Dimensional`v, TensorSpace v, Scalar v ~ s
, m ~ Maybe.TriangularNum n )
=> m`Dimensional`(SymmetricTensor s v) where
knownDimensionalitySing = Maybe.triangularNumSing $ dimensionalitySing @v
instance (Num' s, TensorSpace v, Scalar v ~ s) => TensorSpace (SymmetricTensor s v) where
type TensorProduct (SymmetricTensor s v) x = Tensor s v (Tensor s v x)
wellDefinedVector (SymTensor t) = SymTensor <$> wellDefinedVector t
scalarSpaceWitness = case closedScalarWitness :: ClosedScalarWitness s of
ClosedScalarWitness -> ScalarSpaceWitness
linearManifoldWitness = autoLinearManifoldWitness
zeroTensor = Tensor zeroV
toFlatTensor = case closedScalarWitness :: ClosedScalarWitness s of
ClosedScalarWitness -> LinearFunction $ \(SymTensor t)
-> Tensor $ fmap toFlatTensor $ t
fromFlatTensor = case closedScalarWitness :: ClosedScalarWitness s of
ClosedScalarWitness -> LinearFunction $ \(Tensor t)
-> SymTensor $ fmap fromFlatTensor $ t
addTensors (Tensor f) (Tensor g) = Tensor $ f^+^g
subtractTensors (Tensor f) (Tensor g) = Tensor $ f^-^g
negateTensor = LinearFunction $ \(Tensor f) -> Tensor $ negateV f
scaleTensor = bilinearFunction $ \μ (Tensor f) -> Tensor $ μ *^ f
tensorProduct = bilinearFunction $ \(SymTensor t) g
-> Tensor $ fmap (LinearFunction (⊗g)) $ t
transposeTensor = LinearFunction $ \(Tensor f) -> getLinearFunction (
undefined -- 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)
coerceFmapTensorProduct _ crc = undefined -- case fmap (fmap crc) :: VSCCoercion of
-- VSCCoercion -> Coercion
wellDefinedTensor (Tensor t) = Tensor <$> wellDefinedVector t
instance ∀ s v . (Num' s, LinearSpace v, Scalar v ~ s)
=> LinearSpace (SymmetricTensor s v) where
type DualVector (SymmetricTensor s v) = SymmetricTensor s (DualVector v)
dualSpaceWitness = case ( closedScalarWitness :: ClosedScalarWitness s
, dualSpaceWitness :: DualSpaceWitness v ) of
(ClosedScalarWitness, DualSpaceWitness) -> DualSpaceWitness
linearId = case dualSpaceWitness :: DualSpaceWitness v of
DualSpaceWitness -> LinearMap undefined
-- LinearMap $ rassocTensor . asTensor
-- . fmap (unsafeFollowVSC SymTensor . asTensor) $ id
tensorId = LinearMap undefined
-- LinearMap $ asTensor . fmap asTensor . curryLinearMap
-- . fmap asTensor
-- . curryLinearMap
-- . fmap (unsafeFollowVSC $ \t -> Tensor $ rassocTensor $ t)
-- $ id
applyLinear = case dualSpaceWitness :: DualSpaceWitness v of
DualSpaceWitness -> bilinearFunction $ \(LinearMap f) (SymTensor t)
-> (getLinearFunction applyLinear
$ fromTensor . deferLinearMap . asLinearMap $ f) $ t
applyDualVector = bilinearFunction $ \(SymTensor f) (SymTensor v)
-> getLinearFunction
(getLinearFunction applyDualVector $ fromTensor -+$=> f) v
applyTensorFunctional :: ∀ u . (LinearSpace u, Scalar u ~ s)
=> LinearFunction s
(LinearMap s (SymmetricTensor s v) (DualVector u))
(LinearFunction s (Tensor s (SymmetricTensor s v) u) s)
applyTensorFunctional = case (dualSpaceWitness @v, dualSpaceWitness @u) of
(DualSpaceWitness, DualSpaceWitness)
-> bilinearFunction $ \(LinearMap f) (Tensor t)
-> getLinearFunction
(getLinearFunction applyTensorFunctional
$ fromTensor . fmap fromTensor -+$=> f) t
applyTensorLinMap :: ∀ u w . ( LinearSpace u, Scalar u ~ s
, TensorSpace w, Scalar w ~ s )
=> LinearFunction s
(LinearMap s (Tensor s (SymmetricTensor s v) u) w)
(LinearFunction s (Tensor s (SymmetricTensor s v) u) w)
applyTensorLinMap = case (dualSpaceWitness @v, dualSpaceWitness @u) of
(DualSpaceWitness, DualSpaceWitness)
-> bilinearFunction $ \(LinearMap (Tensor f)) (Tensor t)
-> getLinearFunction (getLinearFunction applyTensorLinMap
$ uncurryLinearMap
. fmap (uncurryLinearMap . fromTensor . fmap fromTensor)
-+$=> LinearMap f) t
useTupleLinearSpaceComponents _ = usingNonTupleTypeAsTupleError
coerceDoubleDual = case (dualSpaceWitness @v, scalarSpaceWitness @s) of
(DualSpaceWitness, ScalarSpaceWitness) -> VSCCoercion
squareV :: (Num' s, s ~ Scalar v)
=> TensorSpace v => v -> SymmetricTensor s v
squareV v = SymTensor $ v⊗v
squareVs :: (Num' s, s ~ Scalar v)
=> TensorSpace v => [v] -> SymmetricTensor s v
squareVs vs = SymTensor $ tensorProducts [(v,v) | v<-vs]
type v⊗〃+>w = LinearMap (Scalar v) (SymmetricTensor (Scalar v) v) w
currySymBilin :: LinearSpace v => (v⊗〃+>w) -+> (v+>(v+>w))
currySymBilin = undefined -- LinearFunction . arr $ fmap fromTensor . fromTensor . VSCCoercion
newtype LinearApplicativeSpace f y
= LinearApplicativeSpace { getLinearApplicativeSpace :: f y }
instance ( GHC.Generic1 f, TensorSpace y
, TensorSpace (f y), Scalar (f y) ~ Scalar y
, Monoidal f (LinearFunction (Scalar y)) (LinearFunction (Scalar y)) )
=> AffineSpace (LinearApplicativeSpace f y) where
type Diff (LinearApplicativeSpace f y) = LinearApplicativeSpace f y
(.+^) = (^+^)
(.-.) = (^-^)
instance ∀ f y . ( GHC.Generic1 f, TensorSpace y
, TensorSpace (f y), Scalar (f y) ~ Scalar y
, Monoidal f (LinearFunction (Scalar y)) (LinearFunction (Scalar y)) )
=> AdditiveGroup (LinearApplicativeSpace f y) where
zeroV = LinearApplicativeSpace $ getLinearFunction
( fmap zeroV
. (pureUnit :: LinearFunction (Scalar y) (ZeroDim (Scalar y))
(f (ZeroDim (Scalar y)))) ) zeroV
LinearApplicativeSpace a^+^LinearApplicativeSpace b
= LinearApplicativeSpace
$ getLinearFunction
(fzipWith (LinearFunction $ uncurry (^+^)))
(a,b)
LinearApplicativeSpace a^-^LinearApplicativeSpace b
= LinearApplicativeSpace
$ getLinearFunction
(fzipWith (LinearFunction $ uncurry (^-^)))
(a,b)
negateV (LinearApplicativeSpace a) = LinearApplicativeSpace
$ getLinearFunction (fmap $ LinearFunction negateV) a
instance ( GHC.Generic1 f, TensorSpace y
, TensorSpace (f y), Scalar (f y) ~ Scalar y
, Monoidal f (LinearFunction (Scalar y)) (LinearFunction (Scalar y)) )
=> VectorSpace (LinearApplicativeSpace f y) where
type Scalar (LinearApplicativeSpace f y) = Scalar y
(*^) = undefined
instance ( GHC.Generic1 f, TensorSpace y
, TensorSpace (f y), Scalar (f y) ~ Scalar y
, Monoidal f (LinearFunction (Scalar y)) (LinearFunction (Scalar y)) )
=> Semimanifold (LinearApplicativeSpace f y) where
type Needle (LinearApplicativeSpace f y) = LinearApplicativeSpace f y
#if !MIN_VERSION_manifolds_core(0,6,0)
type Interior (LinearApplicativeSpace f y) = LinearApplicativeSpace f y
toInterior = Just; fromInterior = id
translateP = Tagged (^+^)
#endif
(.+~^) = (^+^)
instance ( GHC.Generic1 f, TensorSpace y
, TensorSpace (f y), Scalar (f y) ~ Scalar y
, Monoidal f (LinearFunction (Scalar y)) (LinearFunction (Scalar y)) )
=> PseudoAffine (LinearApplicativeSpace f y) where
(.-~!) = (.-.)
p.-~.q = pure (p.-.q)
instance (InnerSpace v, Scalar v ~ ℝ, TensorSpace v)
=> InnerSpace (Tensor ℝ ℝ v) where
Tensor t <.> Tensor u = t <.> u
instance (InnerSpace v, TensorSpace v, Scalar v ~ ℝ)
=> InnerSpace (LinearMap ℝ ℝ v) where
LinearMap f <.> LinearMap g = f<.>g
instance ( TensorSpace u, TensorSpace v, TensorSpace w
, Num s, Scalar u ~ s, Scalar v ~ s, Scalar w ~ s
, InnerSpace (Tensor s u w), InnerSpace (Tensor s v w) )
=> InnerSpace (Tensor s (u,v) w) where
Tensor (uw,vw) <.> Tensor (uw',vw') = uw<.>uw' + vw<.>vw'
instance ( LinearSpace u, LinearSpace v, TensorSpace w
, Num s, Scalar u ~ s, Scalar v ~ s, Scalar w ~ s
, InnerSpace (LinearMap s u w), InnerSpace (LinearMap s v w) )
=> InnerSpace (LinearMap s (u,v) w) where
(<.>) = case (dualSpaceWitness @u, dualSpaceWitness @v) of
(DualSpaceWitness, DualSpaceWitness)
-> \(LinearMap (uw,vw)) (LinearMap (uw',vw'))
-> (asLinearMap$uw)<.>(asLinearMap$uw')
+ (asLinearMap$vw)<.>(asLinearMap$vw')
instance ( TensorSpace u, TensorSpace v, TensorSpace w
, Num s, Scalar u ~ s, Scalar v ~ s, Scalar w ~ s
, InnerSpace (Tensor s u (Tensor s v w)) )
=> InnerSpace (Tensor s (Tensor s u v) w) where
s <.> t = (rassocTensor$s)<.>(rassocTensor$t)
instance ( LinearSpace u, TensorSpace v, TensorSpace w
, Num s, Scalar u ~ s, Scalar v ~ s, Scalar w ~ s
, InnerSpace (LinearMap s u (Tensor s v w)) )
=> InnerSpace (Tensor s (LinearMap s u v) w) where
s <.> t = (hasteLinearMap$s)<.>(hasteLinearMap$t)
instance ( LinearSpace u, LinearSpace v, TensorSpace w
, Num s, Scalar u ~ s, Scalar v ~ s, Scalar w ~ s
, InnerSpace (LinearMap s u (LinearMap s v w)) )
=> InnerSpace (LinearMap s (Tensor s u v) w) where
s <.> t = (curryLinearMap$s)<.>(curryLinearMap$t)
instance ( LinearSpace u, LinearSpace v, TensorSpace w
, Num s, Scalar u ~ s, Scalar v ~ s, Scalar w ~ s
, InnerSpace (Tensor s u (LinearMap s v w)) )
=> InnerSpace (LinearMap s (LinearMap s u v) w) where
s <.> t = (coCurryLinearMap$s)<.>(coCurryLinearMap$t)
instance (Show v) => Show (Tensor ℝ ℝ v) where
showsPrec p (Tensor t) = showParen (p>9) $ ("Tensor "++) . showsPrec 10 t
instance (QC.Arbitrary v, Scalar v ~ ℝ) => QC.Arbitrary (Tensor ℝ ℝ v) where
arbitrary = Tensor <$> QC.arbitrary
shrink (Tensor t) = Tensor <$> QC.shrink t
instance (QC.Arbitrary v, Scalar v ~ ℝ) => QC.Arbitrary (LinearMap ℝ ℝ v) where
arbitrary = LinearMap <$> QC.arbitrary
shrink (LinearMap t) = LinearMap <$> QC.shrink t
#define FreeArbitrarySpace(S) \
instance (QC.Arbitrary v, Scalar v ~ ℝ) => QC.Arbitrary (Tensor ℝ (S ℝ) v) where { \
arbitrary = Tensor <$> Hask.traverse (const QC.arbitrary) zeroV }; \
instance (QC.Arbitrary v, Scalar v ~ ℝ) => QC.Arbitrary (LinearMap ℝ (S ℝ) v) where { \
arbitrary = LinearMap <$> Hask.traverse (const QC.arbitrary) zeroV }
FreeArbitrarySpace(V0)
FreeArbitrarySpace(V1)
FreeArbitrarySpace(V2)
FreeArbitrarySpace(V3)
FreeArbitrarySpace(V4)
instance ( QC.Arbitrary (Tensor s u w), QC.Arbitrary (Tensor s v w)
, Scalar u ~ s, Scalar v ~ s, Scalar w ~ s )
=> QC.Arbitrary (Tensor s (u,v) w) where
arbitrary = Tensor <$> QC.arbitrary
shrink (Tensor t) = Tensor <$> QC.shrink t
instance ( LinearSpace u, LinearSpace v, TensorSpace w
, QC.Arbitrary (LinearMap s u w), QC.Arbitrary (LinearMap s v w)
, Scalar u ~ s, Scalar v ~ s, Scalar w ~ s )
=> QC.Arbitrary (LinearMap s (u,v) w) where
arbitrary = case (dualSpaceWitness @u, dualSpaceWitness @v) of
(DualSpaceWitness, DualSpaceWitness) -> LinearMap <$> do
(,) <$> (arr fromLinearMap <$> QC.arbitrary)
<*> (arr fromLinearMap <$> QC.arbitrary)
shrink = case (dualSpaceWitness @u, dualSpaceWitness @v) of
(DualSpaceWitness, DualSpaceWitness) -> \(LinearMap (x,y)) -> LinearMap <$> do
(x',y') <- QC.shrink (asLinearMap $ x, asLinearMap $ y)
return (fromLinearMap $ x', fromLinearMap $ y')
instance ( TensorSpace u, TensorSpace v, TensorSpace w
, QC.Arbitrary (u⊗(v⊗w))
, Scalar u ~ s, Scalar v ~ s, Scalar w ~ s )
=> QC.Arbitrary (Tensor s (Tensor s u v) w) where
arbitrary = arr lassocTensor <$> QC.arbitrary
shrink (Tensor t) = arr lassocTensor <$> QC.shrink (Tensor t)
instance ( LinearSpace u, LinearSpace v, TensorSpace w
, QC.Arbitrary (u+>(v+>w))
, Scalar u ~ s, Scalar v ~ s, Scalar w ~ s )
=> QC.Arbitrary (LinearMap s (Tensor s u v) w) where
arbitrary = arr uncurryLinearMap <$> QC.arbitrary
shrink f = arr uncurryLinearMap <$> QC.shrink (curryLinearMap $ f)
instance ( LinearSpace u, TensorSpace v, TensorSpace w
, QC.Arbitrary (u+>(v⊗w))
, Scalar u ~ s, Scalar v ~ s, Scalar w ~ s )
=> QC.Arbitrary (Tensor s (LinearMap s u v) w) where
arbitrary = arr deferLinearMap <$> QC.arbitrary
shrink (Tensor t) = arr deferLinearMap <$> QC.shrink (LinearMap t)
instance ( LinearSpace u, LinearSpace v, TensorSpace w
, QC.Arbitrary (u⊗(v+>w))
, Scalar u ~ s, Scalar v ~ s, Scalar w ~ s )
=> QC.Arbitrary (LinearMap s (LinearMap s u v) w) where
arbitrary = arr coUncurryLinearMap <$> QC.arbitrary
shrink f = arr coUncurryLinearMap <$> QC.shrink (coCurryLinearMap $ f)