module Math.VectorSpace.Docile where
import Math.LinearMap.Category.Class
import Math.LinearMap.Category.Instances
import Math.LinearMap.Asserted
import Data.Tree (Tree(..), Forest)
import Data.List (sortBy, foldl', tails)
import qualified Data.Set as Set
import Data.Set (Set)
import Data.Ord (comparing)
import Data.List (maximumBy, unfoldr)
import qualified Data.Vector as Arr
import Data.Foldable (toList)
import Data.List (transpose)
import Data.Semigroup
import Data.VectorSpace
import Data.Basis
import Data.Void
import Prelude ()
import qualified Prelude as Hask
import Control.Category.Constrained.Prelude hiding ((^))
import Control.Arrow.Constrained
import Control.Monad.Trans.State
import Linear ( V0(V0), V1(V1), V2(V2), V3(V3), V4(V4)
, _x, _y, _z, _w, ex, ey, ez, ew )
import qualified Data.Vector.Unboxed as UArr
import Data.VectorSpace.Free
import Math.VectorSpace.ZeroDimensional
import qualified Linear.Matrix as Mat
import qualified Linear.Vector as Mat
import Control.Lens ((^.), Lens', lens, ReifiedLens', ReifiedLens(..))
import Data.Coerce
import Numeric.IEEE
class LinearSpace v => SemiInner v where
dualBasisCandidates :: [(Int,v)] -> Forest (Int, DualVector v)
tensorDualBasisCandidates :: (SemiInner w, Scalar w ~ Scalar v)
=> [(Int, vβw)] -> Forest (Int, DualVector (vβw))
symTensorDualBasisCandidates
:: [(Int, SymmetricTensor (Scalar v) v)]
-> Forest (Int, SymmetricTensor (Scalar v) (DualVector v))
symTensorTensorDualBasisCandidates :: β w . (SemiInner w, Scalar w ~ Scalar v)
=> [(Int, SymmetricTensor (Scalar v) v β w)]
-> Forest (Int, SymmetricTensor (Scalar v) v +> DualVector w)
symTensorTensorDualBasisCandidates
= case ( dualSpaceWitness :: DualSpaceWitness v
, dualSpaceWitness :: DualSpaceWitness w
, scalarSpaceWitness :: ScalarSpaceWitness v ) of
(DualSpaceWitness, DualSpaceWitness, ScalarSpaceWitness)
-> map (second $ getLinearFunction transposeTensor)
>>> dualBasisCandidates
>>> fmap (fmap . second $
arr asTensor >>> arr transposeTensor >>> arr fromTensor)
cartesianDualBasisCandidates
:: [DualVector v]
-> (v -> [β])
-> ([(Int,v)] -> Forest (Int, DualVector v))
cartesianDualBasisCandidates dvs abss vcas = go 0 0 sorted
where sorted = sortBy (comparing $ negate . snd . snd)
[ (i, (av, maximum av)) | (i,v)<-vcas, let av = abss v ]
go k nDelay scs@((i,(av,_)):scs')
| k<n = Node (i, dv) (go (k+1) 0 [(i',(zeroAt j av',m)) | (i',(av',m))<-scs'])
: go k (nDelay+1) (bringToFront (nDelay+1) scs)
where (j,_) = maximumBy (comparing snd) $ zip jfus av
dv = dvs !! j
go _ _ _ = []
jfus = [0 .. n1]
n = length dvs
zeroAt :: Int -> [β] -> [β]
zeroAt _ [] = []
zeroAt 0 (_:l) = (1/0):l
zeroAt j (e:l) = e : zeroAt (j1) l
bringToFront :: Int -> [a] -> [a]
bringToFront i l = case splitAt i l of
(_,[]) -> []
(f,s:l') -> s : f++l'
instance (Fractional' s, SemiInner s) => SemiInner (ZeroDim s) where
dualBasisCandidates _ = []
tensorDualBasisCandidates _ = []
symTensorDualBasisCandidates _ = []
instance (Fractional' s, SemiInner s) => SemiInner (V0 s) where
dualBasisCandidates _ = []
tensorDualBasisCandidates _ = []
symTensorDualBasisCandidates _ = []
orthonormaliseDuals :: β v . (SemiInner v, RealFrac' (Scalar v))
=> Scalar v -> [(v, DualVector v)]
-> [(v,Maybe (DualVector v))]
orthonormaliseDuals = od dualSpaceWitness
where od _ _ [] = []
od (DualSpaceWitness :: DualSpaceWitness v) Ξ΅ ((v,v'β):ws)
| abs ovlβ > 0, abs ovlβ > Ξ΅
= (v,Just v')
: [ (w, fmap (\w' -> w' ^-^ (w'<.>^v)*^v') w's)
| (w,w's)<-wssys ]
| otherwise = (v,Nothing) : wssys
where wssys = orthonormaliseDuals Ξ΅ ws
v'β = foldl' (\v'iβ (w,w's)
-> foldl' (\v'i w' -> v'i ^-^ (v'i<.>^w)*^w') v'iβ w's)
(v'β ^/ ovlβ) wssys
v' = v'β ^/ ovlβ
ovlβ = v'β<.>^v
ovlβ = v'β<.>^v
dualBasis :: β v . (SemiInner v, RealFrac' (Scalar v))
=> [v] -> [Maybe (DualVector v)]
dualBasis vs = snd <$> result
where zip' ((i,v):vs) ((j,v'):ds)
| i<j = zip' vs ((j,v'):ds)
| i==j = (v,v') : zip' vs ds
zip' _ _ = []
result :: [(v, Maybe (DualVector v))]
result = case findBest n n $ dualBasisCandidates vsIxed of
Right bestCandidates
-> orthonormaliseDuals epsilon
(zip' vsIxed $ sortBy (comparing fst) bestCandidates)
Left (_, bestCompromise)
-> let survivors :: [(Int, DualVector v)]
casualties :: [Int]
(casualties, survivors)
= second (sortBy $ comparing fst)
$ mapEither (\case
(i,Nothing) -> Left i
(i,Just v') -> Right (i,v')
) bestCompromise
bestEffort = orthonormaliseDuals epsilon
[ (lookupArr Arr.! i, v')
| (i,v') <- survivors ]
in map snd . sortBy (comparing fst)
$ zipWith ((,) . fst) survivors bestEffort
++ [ (i,(lookupArr Arr.! i, Nothing))
| i <- casualties ]
where findBest :: Int
-> Int
-> Forest (Int, DualVector v)
-> Either (Int, [(Int, Maybe (DualVector v))])
[(Int, DualVector v)]
findBest 0 _ _ = Right []
findBest nMissing _ [] = Left (nMissing, [])
findBest n maxCompromises (Node (i,v') bv' : alts)
| Just _ <- guardedv'
, Right best' <- straightContinue = Right $ (i,v') : best'
| maxCompromises > 0
, Right goodAlt <- alternative = Right goodAlt
| otherwise = case straightContinue of
Right goodOtherwise -> Left (1, second Just <$> goodOtherwise)
Left (nBad, badAnyway)
| maxCompromises > 0
, Left (nBadAlt, badAlt) <- alternative
, nBadAlt < nBad + myBadness
-> Left (nBadAlt, badAlt)
| otherwise -> Left ( nBad + myBadness
, (i, guardedv') : badAnyway )
where guardedv' = case v'<.>^(lookupArr Arr.! i) of
0 -> Nothing
_ -> Just v'
myBadness = case guardedv' of
Nothing -> 1
Just _ -> 0
straightContinue = findBest (n1) (maxCompromises1) bv'
alternative = findBest n (maxCompromises1) alts
vsIxed = zip [0..] vs
lookupArr = Arr.fromList vs
n = Arr.length lookupArr
zipTravWith :: Hask.Traversable t => (a->b->c) -> t a -> [b] -> Maybe (t c)
zipTravWith f = evalStateT . Hask.traverse zp
where zp a = do
bs <- get
case bs of
[] -> StateT $ const Nothing
(b:bs') -> put bs' >> return (f a b)
embedFreeSubspace :: β v t r . (SemiInner v, RealFrac' (Scalar v), Hask.Traversable t)
=> t v -> Maybe (ReifiedLens' v (t (Scalar v)))
embedFreeSubspace vs = fmap (\(g,s) -> Lens (lens g s)) result
where vsList = toList vs
result = fmap (genGet&&&genSet) . sequenceA $ dualBasis vsList
genGet vsDuals u = case zipTravWith (\_v dv -> dv<.>^u) vs vsDuals of
Just cs -> cs
genSet vsDuals u coefs = case zipTravWith (,) coefs $ zip vsList vsDuals of
Just updators -> foldl' (\ur (c,(v,v')) -> ur ^+^ v^*(c v'<.>^ur))
u updators
instance SemiInner β where
dualBasisCandidates = fmap ((`Node`[]) . second recip)
. sortBy (comparing $ negate . abs . snd)
. filter ((/=0) . snd)
tensorDualBasisCandidates = map (second getTensorProduct)
>>> dualBasisCandidates
>>> fmap (fmap $ second LinearMap)
symTensorDualBasisCandidates = map (second getSymmetricTensor)
>>> dualBasisCandidates
>>> fmap (fmap $ second (arr asTensor >>> SymTensor))
instance (Fractional' s, Ord s, SemiInner s) => SemiInner (V1 s) where
dualBasisCandidates = fmap ((`Node`[]) . second recip)
. sortBy (comparing $ negate . abs . snd)
. filter ((/=0) . snd)
tensorDualBasisCandidates = map (second $ \(Tensor (V1 w)) -> w)
>>> dualBasisCandidates
>>> fmap (fmap . second $ LinearMap . V1)
symTensorDualBasisCandidates = map (second getSymmetricTensor)
>>> dualBasisCandidates
>>> fmap (fmap $ second (arr asTensor >>> SymTensor))
instance SemiInner (V2 β) where
dualBasisCandidates = cartesianDualBasisCandidates Mat.basis (toList . fmap abs)
tensorDualBasisCandidates = map (second $ \(Tensor (V2 x y)) -> (x,y))
>>> dualBasisCandidates
>>> map (fmap . second $ LinearMap . \(dx,dy) -> V2 dx dy)
symTensorDualBasisCandidates = cartesianDualBasisCandidates
(SymTensor . Tensor<$>[ V2 (V2 1 0) zeroV
, V2 (V2 0 sqrtΒΉβ) (V2 sqrtΒΉβ 0)
, V2 zeroV (V2 0 1)])
(\(SymTensor (Tensor (V2 (V2 xx xy)
(V2 yx yy))))
-> abs <$> [xx, (xy+yx)*sqrtΒΉβ, yy])
where sqrtΒΉβ = sqrt 0.5
instance SemiInner (V3 β) where
dualBasisCandidates = cartesianDualBasisCandidates Mat.basis (toList . fmap abs)
tensorDualBasisCandidates = map (second $ \(Tensor (V3 x y z)) -> (x,(y,z)))
>>> dualBasisCandidates
>>> map (fmap . second $ LinearMap . \(dx,(dy,dz)) -> V3 dx dy dz)
symTensorDualBasisCandidates = cartesianDualBasisCandidates
(SymTensor . Tensor<$>[ V3 (V3 1 0 0) zeroV zeroV
, V3 (V3 0 sqrtΒΉβ 0) (V3 sqrtΒΉβ 0 0) zeroV
, V3 (V3 0 0 sqrtΒΉβ) zeroV (V3 sqrtΒΉβ 0 0)
, V3 zeroV (V3 0 1 0) zeroV
, V3 zeroV (V3 0 0 sqrtΒΉβ) (V3 0 sqrtΒΉβ 0)
, V3 zeroV zeroV (V3 0 0 1)])
(\(SymTensor (Tensor (V3 (V3 xx xy xz)
(V3 yx yy yz)
(V3 zx zy zz))))
-> abs <$> [ xx, (xy+yx)*sqrtΒΉβ, (xz+zx)*sqrtΒΉβ
, yy , (yz+zy)*sqrtΒΉβ
, zz ])
where sqrtΒΉβ = sqrt 0.5
instance SemiInner (V4 β) where
dualBasisCandidates = cartesianDualBasisCandidates Mat.basis (toList . fmap abs)
tensorDualBasisCandidates = map (second $ \(Tensor (V4 x y z w)) -> ((x,y),(z,w)))
>>> dualBasisCandidates
>>> map (fmap . second $ LinearMap . \((dx,dy),(dz,dw)) -> V4 dx dy dz dw)
symTensorDualBasisCandidates = cartesianDualBasisCandidates
(SymTensor . Tensor<$>[ V4 (V4 1 0 0 0) zeroV zeroV zeroV
, V4 (V4 0 sqrtΒΉβ 0 0) (V4 sqrtΒΉβ 0 0 0) zeroV zeroV
, V4 (V4 0 0 sqrtΒΉβ 0) zeroV (V4 sqrtΒΉβ 0 0 0) zeroV
, V4 (V4 0 0 0 sqrtΒΉβ) zeroV zeroV (V4 sqrtΒΉβ 0 0 0)
, V4 zeroV (V4 0 1 0 0) zeroV zeroV
, V4 zeroV (V4 0 0 sqrtΒΉβ 0) (V4 0 sqrtΒΉβ 0 0) zeroV
, V4 zeroV (V4 0 0 0 sqrtΒΉβ) zeroV (V4 0 sqrtΒΉβ 0 0)
, V4 zeroV zeroV (V4 0 0 1 0) zeroV
, V4 zeroV zeroV (V4 0 0 0 sqrtΒΉβ) (V4 0 0 sqrtΒΉβ 0)
, V4 zeroV zeroV zeroV (V4 0 0 0 1)])
(\(SymTensor (Tensor (V4 (V4 xx xy xz xw)
(V4 yx yy yz yw)
(V4 zx zy zz zw)
(V4 wx wy wz ww))))
-> abs <$> [ xx, (xy+yx)*sqrtΒΉβ, (xz+zx)*sqrtΒΉβ, (xw+wx)*sqrtΒΉβ
, yy , (yz+zy)*sqrtΒΉβ, (yw+wy)*sqrtΒΉβ
, zz , (zw+wz)*sqrtΒΉβ
, ww ])
where sqrtΒΉβ = sqrt 0.5
infixl 4 β<$>
(β<$>) :: ( Num' s
, Object (LinearFunction s) u
, Object (LinearFunction s) v
, Object (LinearFunction s) w )
=> LinearFunction s v w -> Tensor s u v -> Tensor s u w
fβ<$>t = fmap f $ t
instance β u v . ( SemiInner u, SemiInner v, Scalar u ~ Scalar v, Num' (Scalar u) )
=> SemiInner (u,v) where
dualBasisCandidates = fmap (\(i,(u,v))->((i,u),(i,v))) >>> unzip
>>> dualBasisCandidates *** dualBasisCandidates
>>> combineBaseis (dualSpaceWitness,dualSpaceWitness) False mempty
where combineBaseis :: (DualSpaceWitness u, DualSpaceWitness v)
-> Bool
-> Set Int
-> ( Forest (Int, DualVector u)
, Forest (Int, DualVector v) )
-> Forest (Int, (DualVector u, DualVector v))
combineBaseis _ _ _ ([], []) = []
combineBaseis wit@(DualSpaceWitness,DualSpaceWitness)
False forbidden (Node (i,du) bu' : abu, bv)
| i`Set.member`forbidden = combineBaseis wit False forbidden (abu, bv)
| otherwise
= Node (i, (du, zeroV))
(combineBaseis wit True (Set.insert i forbidden) (bu', bv))
: combineBaseis wit False forbidden (abu, bv)
combineBaseis wit@(DualSpaceWitness,DualSpaceWitness)
True forbidden (bu, Node (i,dv) bv' : abv)
| i`Set.member`forbidden = combineBaseis wit True forbidden (bu, abv)
| otherwise
= Node (i, (zeroV, dv))
(combineBaseis wit False (Set.insert i forbidden) (bu, bv'))
: combineBaseis wit True forbidden (bu, abv)
combineBaseis wit _ forbidden (bu, []) = combineBaseis wit False forbidden (bu,[])
combineBaseis wit _ forbidden ([], bv) = combineBaseis wit True forbidden ([],bv)
symTensorDualBasisCandidates = fmap (\(i,SymTensor (Tensor (u_uv, v_uv)))
-> ( (i, snd β<$> u_uv)
,((i, SymTensor $ fst β<$> u_uv)
, (i, SymTensor $ snd β<$> v_uv))) )
>>> unzip >>> second unzip
>>> dualBasisCandidates *** dualBasisCandidates *** dualBasisCandidates
>>> combineBaseis (dualSpaceWitness,dualSpaceWitness) (Just False) mempty
where combineBaseis :: (DualSpaceWitness u, DualSpaceWitness v)
-> Maybe Bool
-> Set Int
-> ( Forest (Int, LinearMap (Scalar u) u (DualVector v))
,(Forest (Int, SymmetricTensor (Scalar u) (DualVector u))
, Forest (Int, SymmetricTensor (Scalar v) (DualVector v))) )
-> Forest (Int, SymmetricTensor (Scalar u) (DualVector u, DualVector v))
combineBaseis _ _ _ ([], ([],[])) = []
combineBaseis wit@(DualSpaceWitness,DualSpaceWitness)
Nothing forbidden
(Node (i, duv) buv' : abuv, (bu, bv))
| i`Set.member`forbidden
= combineBaseis wit Nothing forbidden (abuv, (bu, bv))
| otherwise
= Node (i, SymTensor $ Tensor
( (zeroV&&&id)β<$>(asTensor$duv)
, (id&&&zeroV)β<$>(transposeTensor$asTensor$duv) ) )
(combineBaseis wit (Just False)
(Set.insert i forbidden) (buv', (bu, bv)))
: combineBaseis wit Nothing forbidden (abuv, (bu, bv))
combineBaseis wit Nothing forbidden ([], (bu, bv))
= combineBaseis wit (Just False) forbidden ([], (bu, bv))
combineBaseis wit@(DualSpaceWitness,DualSpaceWitness)
(Just False) forbidden
(buv, (Node (i,SymTensor du) bu' : abu, bv))
| i`Set.member`forbidden
= combineBaseis wit (Just False) forbidden (buv, (abu, bv))
| otherwise
= Node (i, SymTensor $ Tensor ((id&&&zeroV)β<$> du, zeroV))
(combineBaseis wit (Just True)
(Set.insert i forbidden) (buv, (bu', bv)))
: combineBaseis wit (Just False) forbidden (buv, (abu, bv))
combineBaseis wit (Just False) forbidden (buv, ([], bv))
= combineBaseis wit (Just True) forbidden (buv, ([], bv))
combineBaseis wit@(DualSpaceWitness,DualSpaceWitness)
(Just True) forbidden
(buv, (bu, Node (i,SymTensor dv) bv' : abv))
| i`Set.member`forbidden
= combineBaseis wit (Just True) forbidden (buv, (bu, abv))
| otherwise
= Node (i, SymTensor $ Tensor (zeroV, (zeroV&&&id)β<$> dv))
(combineBaseis wit Nothing
(Set.insert i forbidden) (buv, (bu, bv')))
: combineBaseis wit (Just True) forbidden (buv, (bu, abv))
combineBaseis wit (Just True) forbidden (buv, (bu, []))
= combineBaseis wit Nothing forbidden (buv, (bu, []))
tensorDualBasisCandidates = case scalarSpaceWitness :: ScalarSpaceWitness u of
ScalarSpaceWitness -> map (second $ \(Tensor (tu, tv)) -> (tu, tv))
>>> dualBasisCandidates
>>> map (fmap . second $ \(LinearMap lu, LinearMap lv)
-> LinearMap $ (Tensor lu, Tensor lv) )
instance β s u v . ( SemiInner u, SemiInner v, Scalar u ~ s, Scalar v ~ s )
=> SemiInner (Tensor s u v) where
dualBasisCandidates = tensorDualBasisCandidates
tensorDualBasisCandidates = map (second $ arr rassocTensor)
>>> tensorDualBasisCandidates
>>> map (fmap . second $ arr uncurryLinearMap)
instance β s v . ( Num' s, SemiInner v, Scalar v ~ s )
=> SemiInner (SymmetricTensor s v) where
dualBasisCandidates = symTensorDualBasisCandidates
tensorDualBasisCandidates = symTensorTensorDualBasisCandidates
symTensorTensorDualBasisCandidates = case () of {}
instance β s u v . ( LinearSpace u, SemiInner (DualVector u), SemiInner v
, Scalar u ~ s, Scalar v ~ s )
=> SemiInner (LinearMap s u v) where
dualBasisCandidates = case dualSpaceWitness :: DualSpaceWitness u of
DualSpaceWitness -> (coerce :: [(Int, LinearMap s u v)]
-> [(Int, Tensor s (DualVector u) v)])
>>> tensorDualBasisCandidates
>>> coerce
tensorDualBasisCandidates = map (second $ arr hasteLinearMap)
>>> dualBasisCandidates
>>> map (fmap . second $ arr coUncurryLinearMap)
(^/^) :: (InnerSpace v, Eq (Scalar v), Fractional (Scalar v)) => v -> v -> Scalar v
v^/^w = case (v<.>w) of
0 -> 0
vw -> vw / (w<.>w)
type DList x = [x]->[x]
class (LSpace v) => FiniteDimensional v where
data SubBasis v :: *
entireBasis :: SubBasis v
enumerateSubBasis :: SubBasis v -> [v]
subbasisDimension :: SubBasis v -> Int
subbasisDimension = length . enumerateSubBasis
decomposeLinMap :: (LSpace w, Scalar w ~ Scalar v) => (v+>w) -> (SubBasis v, DList w)
decomposeLinMapWithin :: (LSpace w, Scalar w ~ Scalar v)
=> SubBasis v -> (v+>w) -> Either (SubBasis v, DList w) (DList w)
recomposeSB :: SubBasis v -> [Scalar v] -> (v, [Scalar v])
recomposeSBTensor :: (FiniteDimensional w, Scalar w ~ Scalar v)
=> SubBasis v -> SubBasis w -> [Scalar v] -> (vβw, [Scalar v])
recomposeLinMap :: (LSpace w, Scalar w~Scalar v) => SubBasis v -> [w] -> (v+>w, [w])
recomposeContraLinMap :: (LinearSpace w, Scalar w ~ Scalar v, Hask.Functor f)
=> (f (Scalar w) -> w) -> f (DualVector v) -> v+>w
recomposeContraLinMapTensor
:: ( FiniteDimensional u, LinearSpace w
, Scalar u ~ Scalar v, Scalar w ~ Scalar v, Hask.Functor f )
=> (f (Scalar w) -> w) -> f (v+>DualVector u) -> (vβu)+>w
uncanonicallyFromDual :: DualVector v -+> v
uncanonicallyToDual :: v -+> DualVector v
instance (Num' s) => FiniteDimensional (ZeroDim s) where
data SubBasis (ZeroDim s) = ZeroBasis
entireBasis = ZeroBasis
enumerateSubBasis ZeroBasis = []
subbasisDimension ZeroBasis = 0
recomposeSB ZeroBasis l = (Origin, l)
recomposeSBTensor ZeroBasis _ l = (Tensor Origin, l)
recomposeLinMap ZeroBasis l = (LinearMap Origin, l)
decomposeLinMap _ = (ZeroBasis, id)
decomposeLinMapWithin ZeroBasis _ = pure id
recomposeContraLinMap _ _ = LinearMap Origin
recomposeContraLinMapTensor _ _ = LinearMap Origin
uncanonicallyFromDual = id
uncanonicallyToDual = id
instance (Num' s, Eq s, LinearSpace s) => FiniteDimensional (V0 s) where
data SubBasis (V0 s) = V0Basis
entireBasis = V0Basis
enumerateSubBasis V0Basis = []
subbasisDimension V0Basis = 0
recomposeSB V0Basis l = (V0, l)
recomposeSBTensor V0Basis _ l = (Tensor V0, l)
recomposeLinMap V0Basis l = (LinearMap V0, l)
decomposeLinMap _ = (V0Basis, id)
decomposeLinMapWithin V0Basis _ = pure id
recomposeContraLinMap _ _ = LinearMap V0
recomposeContraLinMapTensor _ _ = LinearMap V0
uncanonicallyFromDual = id
uncanonicallyToDual = id
instance FiniteDimensional β where
data SubBasis β = RealsBasis
entireBasis = RealsBasis
enumerateSubBasis RealsBasis = [1]
subbasisDimension RealsBasis = 1
recomposeSB RealsBasis [] = (0, [])
recomposeSB RealsBasis (ΞΌ:cs) = (ΞΌ, cs)
recomposeSBTensor RealsBasis bw = first Tensor . recomposeSB bw
recomposeLinMap RealsBasis (w:ws) = (LinearMap w, ws)
decomposeLinMap (LinearMap v) = (RealsBasis, (v:))
decomposeLinMapWithin RealsBasis (LinearMap v) = pure (v:)
recomposeContraLinMap fw = LinearMap . fw
recomposeContraLinMapTensor fw = arr uncurryLinearMap . LinearMap
. recomposeContraLinMap fw . fmap getLinearMap
uncanonicallyFromDual = id
uncanonicallyToDual = id
#define FreeFiniteDimensional(V, VB, dimens, take, give) \
instance (Num' s, Eq s, LSpace s) \
=> FiniteDimensional (V s) where { \
data SubBasis (V s) = VB deriving (Show); \
entireBasis = VB; \
enumerateSubBasis VB = toList $ Mat.identity; \
subbasisDimension VB = dimens; \
uncanonicallyFromDual = id; \
uncanonicallyToDual = id; \
recomposeSB _ (take:cs) = (give, cs); \
recomposeSB b cs = recomposeSB b $ cs ++ [0]; \
recomposeSBTensor VB bw cs = case recomposeMultiple bw dimens cs of \
{(take:[], cs') -> (Tensor (give), cs')}; \
recomposeLinMap VB (take:ws') = (LinearMap (give), ws'); \
decomposeLinMap (LinearMap m) = (VB, (toList m ++)); \
decomposeLinMapWithin VB (LinearMap m) = pure (toList m ++); \
recomposeContraLinMap fw mv \
= LinearMap $ (\v -> fw $ fmap (<.>^v) mv) <$> Mat.identity; \
recomposeContraLinMapTensor = rclmt dualSpaceWitness \
where {rclmt :: β u w f . ( FiniteDimensional u, LinearSpace w \
, Scalar u ~ s, Scalar w ~ s, Hask.Functor f ) => DualSpaceWitness u \
-> (f (Scalar w) -> w) -> f (V s+>DualVector u) -> (V sβu)+>w \
; rclmt DualSpaceWitness fw mv = LinearMap $ \
(\v -> fromLinearMap $ recomposeContraLinMap fw \
$ fmap (\(LinearMap q) -> foldl' (^+^) zeroV $ liftA2 (*^) v q) mv) \
<$> Mat.identity } }
FreeFiniteDimensional(V1, V1Basis, 1, cβ , V1 cβ )
FreeFiniteDimensional(V2, V2Basis, 2, cβ:cβ , V2 cβ cβ )
FreeFiniteDimensional(V3, V3Basis, 3, cβ:cβ:cβ , V3 cβ cβ cβ )
FreeFiniteDimensional(V4, V4Basis, 4, cβ:cβ:cβ:cβ, V4 cβ cβ cβ cβ)
recomposeMultiple :: FiniteDimensional w
=> SubBasis w -> Int -> [Scalar w] -> ([w], [Scalar w])
recomposeMultiple bw n dc
| n<1 = ([], dc)
| otherwise = case recomposeSB bw dc of
(w, dc') -> first (w:) $ recomposeMultiple bw (n1) dc'
deriving instance Show (SubBasis β)
instance β u v . ( FiniteDimensional u, FiniteDimensional v
, Scalar u ~ Scalar v, Scalar (DualVector u) ~ Scalar (DualVector v) )
=> FiniteDimensional (u,v) where
data SubBasis (u,v) = TupleBasis !(SubBasis u) !(SubBasis v)
entireBasis = TupleBasis entireBasis entireBasis
enumerateSubBasis (TupleBasis bu bv)
= ((,zeroV)<$>enumerateSubBasis bu) ++ ((zeroV,)<$>enumerateSubBasis bv)
subbasisDimension (TupleBasis bu bv) = subbasisDimension bu + subbasisDimension bv
decomposeLinMap = dclm dualSpaceWitness dualSpaceWitness dualSpaceWitness
where dclm :: β w . (LinearSpace w, Scalar w ~ Scalar u)
=> DualSpaceWitness u -> DualSpaceWitness v -> DualSpaceWitness w
-> ((u,v)+>w) -> (SubBasis (u,v), DList w)
dclm DualSpaceWitness DualSpaceWitness DualSpaceWitness (LinearMap (fu, fv))
= case (decomposeLinMap (asLinearMap$fu), decomposeLinMap (asLinearMap$fv)) of
((bu, du), (bv, dv)) -> (TupleBasis bu bv, du . dv)
decomposeLinMapWithin = dclm dualSpaceWitness dualSpaceWitness dualSpaceWitness
where dclm :: β w . (LinearSpace w, Scalar w ~ Scalar u)
=> DualSpaceWitness u -> DualSpaceWitness v -> DualSpaceWitness w
-> SubBasis (u,v) -> ((u,v)+>w)
-> Either (SubBasis (u,v), DList w) (DList w)
dclm DualSpaceWitness DualSpaceWitness DualSpaceWitness
(TupleBasis bu bv) (LinearMap (fu, fv))
= case ( decomposeLinMapWithin bu (asLinearMap$fu)
, decomposeLinMapWithin bv (asLinearMap$fv) ) of
(Left (bu', du), Left (bv', dv)) -> Left (TupleBasis bu' bv', du . dv)
(Left (bu', du), Right dv) -> Left (TupleBasis bu' bv, du . dv)
(Right du, Left (bv', dv)) -> Left (TupleBasis bu bv', du . dv)
(Right du, Right dv) -> Right $ du . dv
recomposeSB (TupleBasis bu bv) coefs = case recomposeSB bu coefs of
(u, coefs') -> case recomposeSB bv coefs' of
(v, coefs'') -> ((u,v), coefs'')
recomposeSBTensor (TupleBasis bu bv) bw cs = case recomposeSBTensor bu bw cs of
(tuw, cs') -> case recomposeSBTensor bv bw cs' of
(tvw, cs'') -> (Tensor (tuw, tvw), cs'')
recomposeLinMap (TupleBasis bu bv) ws = case recomposeLinMap bu ws of
(lmu, ws') -> first (lmuβ) $ recomposeLinMap bv ws'
recomposeContraLinMap fw dds
= recomposeContraLinMap fw (fst<$>dds)
β recomposeContraLinMap fw (snd<$>dds)
recomposeContraLinMapTensor fw dds = case ( scalarSpaceWitness :: ScalarSpaceWitness u
, dualSpaceWitness :: DualSpaceWitness u
, dualSpaceWitness :: DualSpaceWitness v ) of
(ScalarSpaceWitness,DualSpaceWitness,DualSpaceWitness) -> uncurryLinearMap
$ LinearMap ( fromLinearMap . curryLinearMap
$ recomposeContraLinMapTensor fw
(fmap (\(LinearMap(Tensor tu,_))->LinearMap tu) dds)
, fromLinearMap . curryLinearMap
$ recomposeContraLinMapTensor fw
(fmap (\(LinearMap(_,Tensor tv))->LinearMap tv) dds) )
uncanonicallyFromDual = case ( dualSpaceWitness :: DualSpaceWitness u
, dualSpaceWitness :: DualSpaceWitness v ) of
(DualSpaceWitness,DualSpaceWitness)
-> uncanonicallyFromDual *** uncanonicallyFromDual
uncanonicallyToDual = case ( dualSpaceWitness :: DualSpaceWitness u
, dualSpaceWitness :: DualSpaceWitness v ) of
(DualSpaceWitness,DualSpaceWitness)
-> uncanonicallyToDual *** uncanonicallyToDual
deriving instance (Show (SubBasis u), Show (SubBasis v))
=> Show (SubBasis (u,v))
instance β s u v .
( FiniteDimensional u, FiniteDimensional v
, Scalar u~s, Scalar v~s, Scalar (DualVector u)~s, Scalar (DualVector v)~s
, Fractional' (Scalar v) )
=> FiniteDimensional (Tensor s u v) where
data SubBasis (Tensor s u v) = TensorBasis !(SubBasis u) !(SubBasis v)
entireBasis = TensorBasis entireBasis entireBasis
enumerateSubBasis (TensorBasis bu bv)
= [ uβv | u <- enumerateSubBasis bu, v <- enumerateSubBasis bv ]
subbasisDimension (TensorBasis bu bv) = subbasisDimension bu * subbasisDimension bv
decomposeLinMap = dlm dualSpaceWitness
where dlm :: β w . (LSpace w, Scalar w ~ Scalar v)
=> DualSpaceWitness w -> ((uβv)+>w) -> (SubBasis (uβv), DList w)
dlm DualSpaceWitness muvw = case decomposeLinMap $ curryLinearMap $ muvw of
(bu, mvwsg) -> first (TensorBasis bu) . go $ mvwsg []
where (go, _) = tensorLinmapDecompositionhelpers
decomposeLinMapWithin = dlm dualSpaceWitness
where dlm :: β w . (LSpace w, Scalar w ~ Scalar v)
=> DualSpaceWitness w -> SubBasis (uβv)
-> ((uβv)+>w) -> Either (SubBasis (uβv), DList w) (DList w)
dlm DualSpaceWitness (TensorBasis bu bv) muvw
= case decomposeLinMapWithin bu $ curryLinearMap $ muvw of
Left (bu', mvwsg) -> let (_, (bv', ws)) = goWith bv id (mvwsg []) id
in Left (TensorBasis bu' bv', ws)
Right mvwsg -> let (changed, (bv', ws)) = goWith bv id (mvwsg []) id
in if changed
then Left (TensorBasis bu bv', ws)
else Right ws
where (_, goWith) = tensorLinmapDecompositionhelpers
recomposeSB (TensorBasis bu bv) = recomposeSBTensor bu bv
recomposeSBTensor = rst dualSpaceWitness
where rst :: β w . (FiniteDimensional w, Scalar w ~ s)
=> DualSpaceWitness w -> SubBasis (uβv)
-> SubBasis w -> [s] -> ((uβv)βw, [s])
rst DualSpaceWitness (TensorBasis bu bv) bw
= first (arr lassocTensor) . recomposeSBTensor bu (TensorBasis bv bw)
recomposeLinMap = rlm dualSpaceWitness
where rlm :: β w . (LSpace w, Scalar w ~ Scalar v)
=> DualSpaceWitness w -> SubBasis (uβv) -> [w]
-> ((uβv)+>w, [w])
rlm DualSpaceWitness (TensorBasis bu bv) ws
= ( uncurryLinearMap $ fst . recomposeLinMap bu
$ unfoldr (pure . recomposeLinMap bv) ws
, drop (subbasisDimension bu * subbasisDimension bv) ws )
recomposeContraLinMap = case dualSpaceWitness :: DualSpaceWitness u of
DualSpaceWitness -> recomposeContraLinMapTensor
recomposeContraLinMapTensor = rclt dualSpaceWitness dualSpaceWitness
where rclt :: β u' w f . ( FiniteDimensional u', Scalar u' ~ s
, LinearSpace w, Scalar w ~ s
, Hask.Functor f )
=> DualSpaceWitness u -> DualSpaceWitness u'
-> (f (Scalar w) -> w)
-> f (Tensor s u v +> DualVector u')
-> (Tensor s u v β u') +> w
rclt DualSpaceWitness DualSpaceWitness fw dds
= uncurryLinearMap . uncurryLinearMap
. fmap (curryLinearMap) . curryLinearMap
$ recomposeContraLinMapTensor fw $ fmap (arr curryLinearMap) dds
uncanonicallyToDual = case ( dualSpaceWitness :: DualSpaceWitness u
, dualSpaceWitness :: DualSpaceWitness v ) of
(DualSpaceWitness, DualSpaceWitness) -> fmap uncanonicallyToDual
>>> transposeTensor >>> fmap uncanonicallyToDual
>>> transposeTensor >>> arr fromTensor
uncanonicallyFromDual = case ( dualSpaceWitness :: DualSpaceWitness u
, dualSpaceWitness :: DualSpaceWitness v ) of
(DualSpaceWitness, DualSpaceWitness) -> arr asTensor
>>> fmap uncanonicallyFromDual
>>> transposeTensor >>> fmap uncanonicallyFromDual
>>> transposeTensor
tensorLinmapDecompositionhelpers
:: ( FiniteDimensional v, LSpace w , Scalar v~s, Scalar w~s )
=> ( [v+>w] -> (SubBasis v, DList w)
, SubBasis v -> DList w -> [v+>w] -> DList (v+>w)
-> (Bool, (SubBasis v, DList w)) )
tensorLinmapDecompositionhelpers = (go, goWith)
where go [] = decomposeLinMap zeroV
go (mvw:mvws) = case decomposeLinMap mvw of
(bv, cfs) -> snd (goWith bv cfs mvws (mvw:))
goWith bv prevdc [] prevs = (False, (bv, prevdc))
goWith bv prevdc (mvw:mvws) prevs = case decomposeLinMapWithin bv mvw of
Right cfs -> goWith bv (prevdc . cfs) mvws (prevs . (mvw:))
Left (bv', cfs) -> first (const True)
( goWith bv' (regoWith bv' (prevs[]) . cfs)
mvws (prevs . (mvw:)) )
regoWith _ [] = id
regoWith bv (mvw:mvws) = case decomposeLinMapWithin bv mvw of
Right cfs -> cfs . regoWith bv mvws
Left _ -> error $
"Misbehaved FiniteDimensional instance: `decomposeLinMapWithin` should,\
\\nif it cannot decompose in the given basis, do so in a proper\
\\nsuperbasis of the given one (so that any vector that could be\
\\ndecomposed in the old basis can also be decomposed in the new one)."
deriving instance (Show (SubBasis u), Show (SubBasis v))
=> Show (SubBasis (Tensor s u v))
instance β s v .
( FiniteDimensional v, Scalar v~s, Scalar (DualVector v)~s
, RealFloat' s )
=> FiniteDimensional (SymmetricTensor s v) where
newtype SubBasis (SymmetricTensor s v) = SymTensBasis (SubBasis v)
entireBasis = SymTensBasis entireBasis
enumerateSubBasis (SymTensBasis b) = do
v:vs <- tails $ enumerateSubBasis b
squareV v
: [ (squareV (v^+^w) ^-^ squareV v ^-^ squareV w) ^* sqrtΒΉβ | w <- vs ]
where sqrtΒΉβ = sqrt 0.5
subbasisDimension (SymTensBasis b) = ((n1)*n)`quot`2
where n = subbasisDimension b
decomposeLinMap = dclm dualSpaceWitness
where dclm (DualSpaceWitness :: DualSpaceWitness v) (LinearMap f)
= (SymTensBasis bf, rmRedundant 0 . symmetrise $ dlw [])
where rmRedundant _ [] = id
rmRedundant k (row:rest)
= (sclOffdiag (drop k row)++) . rmRedundant (k+1) rest
symmetrise l = zipWith (zipWith (^+^)) lm $ transpose lm
where lm = matr l
matr [] = []
matr l = case splitAt n l of
(row,rest) -> row : matr rest
n = case subbasisDimension bf of
nbf | nbf == subbasisDimension bf' -> nbf
(LinMapBasis bf bf', dlw)
= decomposeLinMap $ asLinearMap . lassocTensor $ f
sclOffdiag (d:o) = 0.5*^d : ((^*sqrtΒΉβ)<$>o)
sqrtΒΉβ = sqrt 0.5 :: s
recomposeSB = rclm dualSpaceWitness
where rclm (DualSpaceWitness :: DualSpaceWitness v) (SymTensBasis b) ws
= case recomposeSB (TensorBasis b b)
$ mkSym (subbasisDimension b) (repeat id) ws of
(t, remws) -> (SymTensor t, remws)
mkSym _ _ [] = []
mkSym 0 _ ws = ws
mkSym n (sdβ:sds) ws = let (d:o,rest) = splitAt n ws
oscld = (sqrt 0.5*)<$>o
in sdβ [] ++ [d] ++ oscld
++ mkSym (n1) (zipWith (.) sds $ (:)<$>oscld) rest
recomposeLinMap = rclm dualSpaceWitness
where rclm (DualSpaceWitness :: DualSpaceWitness v) (SymTensBasis b) ws
= case recomposeLinMap (LinMapBasis b b)
$ mkSym (subbasisDimension b) (repeat id) ws of
(f, remws) -> (LinearMap $ rassocTensor . asTensor $ f, remws)
mkSym _ _ [] = []
mkSym 0 _ ws = ws
mkSym n (sdβ:sds) ws = let (d:o,rest) = splitAt n ws
oscld = (sqrt 0.5*^)<$>o
in sdβ [] ++ [d] ++ oscld
++ mkSym (n1) (zipWith (.) sds $ (:)<$>oscld) rest
recomposeSBTensor = rcst
where rcst :: β w . (FiniteDimensional w, Scalar w ~ s)
=> SubBasis (SymmetricTensor s v) -> SubBasis w
-> [s] -> (Tensor s (SymmetricTensor s v) w, [s])
rcst (SymTensBasis b) bw ΞΌs
= case recomposeSBTensor (TensorBasis b b) bw
$ mkSym (subbasisDimension bw) (subbasisDimension b) (repeat id) ΞΌs of
(Tensor t, remws) -> ( Tensor $ Tensor t
:: Tensor s (SymmetricTensor s v) w
, remws )
mkSym _ _ _ [] = []
mkSym _ 0 _ ws = ws
mkSym nw n (sdβ:sds) ws = let (d:o,rest) = multiSplit nw n ws
oscld = map (sqrt 0.5*)<$>o
in concat (sdβ []) ++ d ++ concat oscld
++ mkSym nw (n1) (zipWith (.) sds $ (:)<$>oscld) rest
recomposeContraLinMap f tenss
= LinearMap . arr (rassocTensor . asTensor) . rcCLM dualSpaceWitness f
$ fmap getSymmetricTensor tenss
where rcCLM :: (Hask.Functor f, LinearSpace w, s~Scalar w)
=> DualSpaceWitness v
-> (f s->w) -> f (Tensor s (DualVector v) (DualVector v))
-> LinearMap s (LinearMap s (DualVector v) v) w
rcCLM DualSpaceWitness f = recomposeContraLinMap f
recomposeContraLinMapTensor = rcCLMT'
where rcCLMT' :: β f u w . (Hask.Functor f, LinearSpace w, s~Scalar w
, FiniteDimensional u, s~Scalar u)
=> (f s->w) -> f (SymmetricTensor s v +> DualVector u)
-> (SymmetricTensor s v β u) +> w
rcCLMT' f tenss
= LinearMap . arr (fmap rassocTensor . rassocTensor . asTensor)
. rcCLMT (dualSpaceWitness, dualSpaceWitness) f
$ fmap getLinearMap tenss
where rcCLMT :: (DualSpaceWitness v, DualSpaceWitness u)
-> (f s->w) -> f (Tensor s (DualVector v)
(Tensor s (DualVector v) (DualVector u)))
-> LinearMap s (LinearMap s (DualVector v)
(LinearMap s (DualVector v) u)) w
rcCLMT (DualSpaceWitness, DualSpaceWitness) f = recomposeContraLinMap f
uncanonicallyFromDual = case dualSpaceWitness :: DualSpaceWitness v of
DualSpaceWitness -> LinearFunction
$ \(SymTensor t) -> SymTensor $ arr fromLinearMap . uncanonicallyFromDual $ t
uncanonicallyToDual = case dualSpaceWitness :: DualSpaceWitness v of
DualSpaceWitness -> LinearFunction
$ \(SymTensor t) -> SymTensor $ uncanonicallyToDual . arr asLinearMap $ t
deriving instance (Show (SubBasis v)) => Show (SubBasis (SymmetricTensor s v))
instance β s u v .
( LSpace u, FiniteDimensional (DualVector u), FiniteDimensional v
, Scalar u~s, Scalar v~s, Scalar (DualVector v)~s, Fractional' (Scalar v) )
=> FiniteDimensional (LinearMap s u v) where
data SubBasis (LinearMap s u v) = LinMapBasis !(SubBasis (DualVector u)) !(SubBasis v)
entireBasis = case ( dualSpaceWitness :: DualSpaceWitness u
, dualSpaceWitness :: DualSpaceWitness v ) of
(DualSpaceWitness, DualSpaceWitness)
-> case entireBasis of TensorBasis bu bv -> LinMapBasis bu bv
enumerateSubBasis
= case ( dualSpaceWitness :: DualSpaceWitness u
, dualSpaceWitness :: DualSpaceWitness v ) of
(DualSpaceWitness, DualSpaceWitness) -> \(LinMapBasis bu bv)
-> arr (fmap asLinearMap) . enumerateSubBasis $ TensorBasis bu bv
subbasisDimension (LinMapBasis bu bv) = subbasisDimension bu * subbasisDimension bv
decomposeLinMap = case ( dualSpaceWitness :: DualSpaceWitness u
, dualSpaceWitness :: DualSpaceWitness v ) of
(DualSpaceWitness, DualSpaceWitness)
-> first (\(TensorBasis bu bv)->LinMapBasis bu bv)
. decomposeLinMap . coerce
decomposeLinMapWithin = case ( dualSpaceWitness :: DualSpaceWitness u
, dualSpaceWitness :: DualSpaceWitness v ) of
(DualSpaceWitness, DualSpaceWitness)
-> \(LinMapBasis bu bv) m
-> case decomposeLinMapWithin (TensorBasis bu bv) (coerce m) of
Right ws -> Right ws
Left (TensorBasis bu' bv', ws) -> Left (LinMapBasis bu' bv', ws)
recomposeSB = case ( dualSpaceWitness :: DualSpaceWitness u
, dualSpaceWitness :: DualSpaceWitness v ) of
(DualSpaceWitness, DualSpaceWitness) -> \(LinMapBasis bu bv)
-> recomposeSB (TensorBasis bu bv) >>> first (arr fromTensor)
recomposeSBTensor = case ( dualSpaceWitness :: DualSpaceWitness u
, dualSpaceWitness :: DualSpaceWitness v ) of
(DualSpaceWitness, DualSpaceWitness) -> \(LinMapBasis bu bv) bw
-> recomposeSBTensor (TensorBasis bu bv) bw >>> first coerce
recomposeLinMap = rlm dualSpaceWitness dualSpaceWitness
where rlm :: β w . (LSpace w, Scalar w ~ Scalar v)
=> DualSpaceWitness u -> DualSpaceWitness w -> SubBasis (u+>v) -> [w]
-> ((u+>v)+>w, [w])
rlm DualSpaceWitness DualSpaceWitness (LinMapBasis bu bv) ws
= ( coUncurryLinearMap . fromLinearMap $ fst . recomposeLinMap bu
$ unfoldr (pure . recomposeLinMap bv) ws
, drop (subbasisDimension bu * subbasisDimension bv) ws )
recomposeContraLinMap = case ( dualSpaceWitness :: DualSpaceWitness u
, dualSpaceWitness :: DualSpaceWitness v ) of
(DualSpaceWitness, DualSpaceWitness) -> \fw dds
-> argFromTensor $ recomposeContraLinMapTensor fw $ fmap (arr asLinearMap) dds
recomposeContraLinMapTensor = rclmt dualSpaceWitness dualSpaceWitness dualSpaceWitness
where rclmt :: β f u' w . ( LinearSpace w, FiniteDimensional u'
, Scalar w ~ s, Scalar u' ~ s
, Hask.Functor f )
=> DualSpaceWitness u -> DualSpaceWitness v -> DualSpaceWitness u'
-> (f (Scalar w) -> w) -> f ((u+>v)+>DualVector u') -> ((u+>v)βu')+>w
rclmt DualSpaceWitness DualSpaceWitness DualSpaceWitness fw dds
= uncurryLinearMap . coUncurryLinearMap
. fmap curryLinearMap . coCurryLinearMap . argFromTensor
$ recomposeContraLinMapTensor fw
$ fmap (arr $ asLinearMap . coCurryLinearMap) dds
uncanonicallyToDual = case ( dualSpaceWitness :: DualSpaceWitness u
, dualSpaceWitness :: DualSpaceWitness v ) of
(DualSpaceWitness, DualSpaceWitness)
-> arr asTensor >>> fmap uncanonicallyToDual >>> transposeTensor
>>> fmap uncanonicallyToDual >>> transposeTensor
uncanonicallyFromDual = case ( dualSpaceWitness :: DualSpaceWitness u
, dualSpaceWitness :: DualSpaceWitness v ) of
(DualSpaceWitness, DualSpaceWitness)
-> arr fromTensor <<< fmap uncanonicallyFromDual <<< transposeTensor
<<< fmap uncanonicallyFromDual <<< transposeTensor
deriving instance (Show (SubBasis (DualVector u)), Show (SubBasis v))
=> Show (SubBasis (LinearMap s u v))
infixr 0 \$
(\$) :: β u v . ( SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v )
=> (u+>v) -> v -> u
(\$) m
| du > dv = ((applyLinear-+$>unsafeRightInverse m)-+$>)
| du < dv = ((applyLinear-+$>unsafeLeftInverse m)-+$>)
| otherwise = let v's = dualBasis $ mdecomp []
(mbas, mdecomp) = decomposeLinMap m
in fst . \v -> recomposeSB mbas [ maybe 0 (<.>^v) v' | v' <- v's ]
where du = subbasisDimension (entireBasis :: SubBasis u)
dv = subbasisDimension (entireBasis :: SubBasis v)
pseudoInverse :: β u v . ( SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v )
=> (u+>v) -> v+>u
pseudoInverse m
| du > dv = unsafeRightInverse m
| du < dv = unsafeLeftInverse m
| otherwise = unsafeInverse m
where du = subbasisDimension (entireBasis :: SubBasis u)
dv = subbasisDimension (entireBasis :: SubBasis v)
unsafeLeftInverse :: β u v . ( SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v )
=> (u+>v) -> v+>u
unsafeLeftInverse = uli dualSpaceWitness dualSpaceWitness
where uli :: DualSpaceWitness u -> DualSpaceWitness v -> (u+>v) -> v+>u
uli DualSpaceWitness DualSpaceWitness m
= unsafeInverse (m' . (fmap uncanonicallyToDual $ m))
. m' . arr uncanonicallyToDual
where m' = adjoint $ m :: DualVector v +> DualVector u
unsafeRightInverse :: β u v . ( SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v )
=> (u+>v) -> v+>u
unsafeRightInverse = uri dualSpaceWitness dualSpaceWitness
where uri :: DualSpaceWitness u -> DualSpaceWitness v -> (u+>v) -> v+>u
uri DualSpaceWitness DualSpaceWitness m
= (fmap uncanonicallyToDual $ m')
. unsafeInverse (m . (fmap uncanonicallyToDual $ m'))
where m' = adjoint $ m :: DualVector v +> DualVector u
unsafeInverse :: ( SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v )
=> (u+>v) -> v+>u
unsafeInverse m = recomposeContraLinMap (fst . recomposeSB mbas)
$ [maybe zeroV id v' | v'<-v's]
where v's = dualBasis $ mdecomp []
(mbas, mdecomp) = decomposeLinMap m
riesz :: β v . (FiniteDimensional v, InnerSpace v) => DualVector v -+> v
riesz = case ( scalarSpaceWitness :: ScalarSpaceWitness v
, dualSpaceWitness :: DualSpaceWitness v ) of
(ScalarSpaceWitness,DualSpaceWitness) -> LinearFunction $ \dv ->
let (bas, compos) = decomposeLinMap $ sampleLinearFunction $ applyDualVector $ dv
in fst . recomposeSB bas $ compos []
sRiesz :: β v . FiniteDimensional v => DualSpace v -+> v
sRiesz = case ( scalarSpaceWitness :: ScalarSpaceWitness v
, dualSpaceWitness :: DualSpaceWitness v ) of
(ScalarSpaceWitness,DualSpaceWitness) -> LinearFunction $ \dv ->
let (bas, compos) = decomposeLinMap $ dv
in fst . recomposeSB bas $ compos []
coRiesz :: β v . (LSpace v, InnerSpace v) => v -+> DualVector v
coRiesz = case ( scalarSpaceWitness :: ScalarSpaceWitness v
, dualSpaceWitness :: DualSpaceWitness v ) of
(ScalarSpaceWitness,DualSpaceWitness)
-> fromFlatTensor . arr asTensor . sampleLinearFunction . inner
showsPrecAsRiesz :: β v . ( FiniteDimensional v, InnerSpace v, Show v
, HasBasis (Scalar v), Basis (Scalar v) ~ () )
=> Int -> DualSpace v -> ShowS
showsPrecAsRiesz = case ( scalarSpaceWitness :: ScalarSpaceWitness v
, dualSpaceWitness :: DualSpaceWitness v ) of
(ScalarSpaceWitness,DualSpaceWitness)
-> \p dv -> showParen (p>0) $ ("().<"++) . showsPrec 7 (sRiesz$dv)
instance Show (LinearMap β (ZeroDim β) β) where showsPrec = showsPrecAsRiesz
instance Show (LinearMap β (V0 β) β) where showsPrec = showsPrecAsRiesz
instance Show (LinearMap β β β) where showsPrec = showsPrecAsRiesz
instance Show (LinearMap β (V1 β) β) where showsPrec = showsPrecAsRiesz
instance Show (LinearMap β (V2 β) β) where showsPrec = showsPrecAsRiesz
instance Show (LinearMap β (V3 β) β) where showsPrec = showsPrecAsRiesz
instance Show (LinearMap β (V4 β) β) where showsPrec = showsPrecAsRiesz
class TensorDecomposable u => RieszDecomposable u where
rieszDecomposition :: (FiniteDimensional v, v ~ DualVector v, Scalar v ~ Scalar u)
=> (v +> u) -> [(Basis u, v)]
instance RieszDecomposable β where
rieszDecomposition (LinearMap r) = [((), fromFlatTensor $ Tensor r)]
instance ( RieszDecomposable x, RieszDecomposable y
, Scalar x ~ Scalar y, Scalar (DualVector x) ~ Scalar (DualVector y) )
=> RieszDecomposable (x,y) where
rieszDecomposition m = map (first Left) (rieszDecomposition $ fst . m)
++ map (first Right) (rieszDecomposition $ snd . m)
instance RieszDecomposable (ZeroDim β) where
rieszDecomposition _ = []
instance RieszDecomposable (V0 β) where
rieszDecomposition _ = []
instance RieszDecomposable (V1 β) where
rieszDecomposition m = [(ex, sRiesz $ fmap (LinearFunction (^._x)) $ m)]
instance RieszDecomposable (V2 β) where
rieszDecomposition m = [ (ex, sRiesz $ fmap (LinearFunction (^._x)) $ m)
, (ey, sRiesz $ fmap (LinearFunction (^._y)) $ m) ]
instance RieszDecomposable (V3 β) where
rieszDecomposition m = [ (ex, sRiesz $ fmap (LinearFunction (^._x)) $ m)
, (ey, sRiesz $ fmap (LinearFunction (^._y)) $ m)
, (ez, sRiesz $ fmap (LinearFunction (^._z)) $ m) ]
instance RieszDecomposable (V4 β) where
rieszDecomposition m = [ (ex, sRiesz $ fmap (LinearFunction (^._x)) $ m)
, (ey, sRiesz $ fmap (LinearFunction (^._y)) $ m)
, (ez, sRiesz $ fmap (LinearFunction (^._z)) $ m)
, (ew, sRiesz $ fmap (LinearFunction (^._w)) $ m) ]
infixl 7 .<
(.<) :: ( FiniteDimensional v, Num' (Scalar v)
, InnerSpace v, LSpace w, HasBasis w, Scalar v ~ Scalar w )
=> Basis w -> v -> v+>w
bw .< v = sampleLinearFunction $ LinearFunction $ \v' -> recompose [(bw, v<.>v')]
rieszDecomposeShowsPrec :: β u v s . ( RieszDecomposable u
, FiniteDimensional v, v ~ DualVector v, Show v
, Scalar u ~ s, Scalar v ~ s )
=> Int -> LinearMap s v u -> ShowS
rieszDecomposeShowsPrec p m = case rieszDecomposition m of
[] -> ("zeroV"++)
((bβ,dvβ):dvs) -> showParen (p>6)
$ \s -> showsPrecBasis ([]::[u]) 7 bβ
. (".<"++) . showsPrec 7 dvβ
$ foldr (\(b,dv)
-> (" ^+^ "++) . showsPrecBasis ([]::[u]) 7 b
. (".<"++) . showsPrec 7 dv) s dvs
instance Show (LinearMap s v (ZeroDim s)) where
show _ = "zeroV"
instance Show (LinearMap s v (V0 s)) where
show _ = "zeroV"
instance (FiniteDimensional v, v ~ DualVector v, Scalar v ~ β, Show v)
=> Show (LinearMap β v (V1 β)) where
showsPrec = rieszDecomposeShowsPrec
instance (FiniteDimensional v, v ~ DualVector v, Scalar v ~ β, Show v)
=> Show (LinearMap β v (V2 β)) where
showsPrec = rieszDecomposeShowsPrec
instance (FiniteDimensional v, v ~ DualVector v, Scalar v ~ β, Show v)
=> Show (LinearMap β v (V3 β)) where
showsPrec = rieszDecomposeShowsPrec
instance (FiniteDimensional v, v ~ DualVector v, Scalar v ~ β, Show v)
=> Show (LinearMap β v (V4 β)) where
showsPrec = rieszDecomposeShowsPrec
instance ( FiniteDimensional v, v ~ DualVector v, Show v
, RieszDecomposable x, RieszDecomposable y
, Scalar x ~ s, Scalar y ~ s, Scalar v ~ s
, Scalar (DualVector x) ~ s, Scalar (DualVector y) ~ s )
=> Show (LinearMap s v (x,y)) where
showsPrec = case
(dualSpaceWitness::DualSpaceWitness x, dualSpaceWitness::DualSpaceWitness y) of
(DualSpaceWitness, DualSpaceWitness) -> rieszDecomposeShowsPrec
infixr 7 .β
(.β) :: ( TensorSpace v, HasBasis v, TensorSpace w
, Num' (Scalar v), Scalar v ~ Scalar w )
=> Basis v -> w -> vβw
b .β w = basisValue b β w
class (FiniteDimensional v, HasBasis v) => TensorDecomposable v where
tensorDecomposition :: vβw -> [(Basis v, w)]
showsPrecBasis :: Hask.Functor p => p v -> Int -> Basis v -> ShowS
instance TensorDecomposable β where
tensorDecomposition (Tensor r) = [((), r)]
showsPrecBasis _ _ = shows
instance ( TensorDecomposable x, TensorDecomposable y
, Scalar x ~ Scalar y, Scalar (DualVector x) ~ Scalar (DualVector y) )
=> TensorDecomposable (x,y) where
tensorDecomposition (Tensor (tx,ty))
= map (first Left) (tensorDecomposition tx)
++ map (first Right) (tensorDecomposition ty)
showsPrecBasis proxy p (Left bx)
= showParen (p>9) $ ("Left "++) . showsPrecBasis (fst<$>proxy) 10 bx
showsPrecBasis proxy p (Right by)
= showParen (p>9) $ ("Right "++) . showsPrecBasis (snd<$>proxy) 10 by
instance TensorDecomposable (ZeroDim β) where
tensorDecomposition _ = []
showsPrecBasis _ _ = absurd
instance TensorDecomposable (V0 β) where
tensorDecomposition _ = []
showsPrecBasis _ _ (Mat.E q) = (V0^.q ++)
instance TensorDecomposable (V1 β) where
tensorDecomposition (Tensor (V1 w)) = [(ex, w)]
showsPrecBasis _ _ (Mat.E q) = (V1"ex"^.q ++)
instance TensorDecomposable (V2 β) where
tensorDecomposition (Tensor (V2 x y)) = [ (ex, x), (ey, y) ]
showsPrecBasis _ _ (Mat.E q) = (V2"ex""ey"^.q ++)
instance TensorDecomposable (V3 β) where
tensorDecomposition (Tensor (V3 x y z)) = [ (ex, x), (ey, y), (ez, z) ]
showsPrecBasis _ _ (Mat.E q) = (V3"ex""ey""ez"^.q ++)
instance TensorDecomposable (V4 β) where
tensorDecomposition (Tensor (V4 x y z w)) = [ (ex, x), (ey, y), (ez, z), (ew, w) ]
showsPrecBasis _ _ (Mat.E q) = (V4"ex""ey""ez""ew"^.q ++)
tensorDecomposeShowsPrec :: β u v s
. ( TensorDecomposable u, FiniteDimensional v, Show v, Scalar u ~ s, Scalar v ~ s )
=> Int -> Tensor s u v -> ShowS
tensorDecomposeShowsPrec p t = case tensorDecomposition t of
[] -> ("zeroV"++)
((bβ,dvβ):dvs) -> showParen (p>6)
$ \s -> showsPrecBasis ([]::[u]) 7 bβ
. (".β"++) . showsPrec 7 dvβ
$ foldr (\(b,dv)
-> (" ^+^ "++) . showsPrecBasis ([]::[u]) 7 b
. (".β"++) . showsPrec 7 dv) s dvs
instance Show (Tensor s (V0 s) v) where
show _ = "zeroV"
instance (FiniteDimensional v, v ~ DualVector v, Scalar v ~ β, Show v)
=> Show (Tensor β (V1 β) v) where
showsPrec = tensorDecomposeShowsPrec
instance (FiniteDimensional v, v ~ DualVector v, Scalar v ~ β, Show v)
=> Show (Tensor β (V2 β) v) where
showsPrec = tensorDecomposeShowsPrec
instance (FiniteDimensional v, v ~ DualVector v, Scalar v ~ β, Show v)
=> Show (Tensor β (V3 β) v) where
showsPrec = tensorDecomposeShowsPrec
instance (FiniteDimensional v, v ~ DualVector v, Scalar v ~ β, Show v)
=> Show (Tensor β (V4 β) v) where
showsPrec = tensorDecomposeShowsPrec
instance ( FiniteDimensional v, v ~ DualVector v, Show v
, TensorDecomposable x, TensorDecomposable y
, Scalar x ~ s, Scalar y ~ s, Scalar v ~ s )
=> Show (Tensor s (x,y) v) where
showsPrec = case
(dualSpaceWitness::DualSpaceWitness x, dualSpaceWitness::DualSpaceWitness y) of
(DualSpaceWitness, DualSpaceWitness) -> tensorDecomposeShowsPrec
(^) :: Num a => a -> Int -> a
(^) = (Hask.^)
type HilbertSpace v = (LSpace v, InnerSpace v, DualVector v ~ v)
type RealFrac' s = (Fractional' s, IEEE s, InnerSpace s)
type RealFloat' s = (RealFrac' s, Floating s)
type SimpleSpace v = ( FiniteDimensional v, FiniteDimensional (DualVector v)
, SemiInner v, SemiInner (DualVector v)
, RealFrac' (Scalar v) )
instance β s u v .
( FiniteDimensional u, LSpace v, FiniteFreeSpace v
, Scalar u~s, Scalar v~s ) => FiniteFreeSpace (LinearMap s u v) where
freeDimension _ = subbasisDimension (entireBasis :: SubBasis u)
* freeDimension ([]::[v])
toFullUnboxVect = decomposeLinMapWithin entireBasis >>> \case
Right l -> UArr.concat $ toFullUnboxVect <$> l []
unsafeFromFullUnboxVect arrv = fst . recomposeLinMap entireBasis
$ [unsafeFromFullUnboxVect $ UArr.slice (dv*j) dv arrv | j <- [0 .. du1]]
where du = subbasisDimension (entireBasis :: SubBasis u)
dv = freeDimension ([]::[v])
instance β s u v .
( LSpace u, FiniteDimensional (DualVector u), LSpace v, FiniteFreeSpace v
, Scalar u~s, Scalar v~s, Scalar (DualVector u)~s, Scalar (DualVector v)~s )
=> FiniteFreeSpace (Tensor s u v) where
freeDimension _ = subbasisDimension (entireBasis :: SubBasis (DualVector u))
* freeDimension ([]::[v])
toFullUnboxVect = arr asLinearMap >>> decomposeLinMapWithin entireBasis >>> \case
Right l -> UArr.concat $ toFullUnboxVect <$> l []
unsafeFromFullUnboxVect arrv = fromLinearMap $ fst . recomposeLinMap entireBasis
$ [unsafeFromFullUnboxVect $ UArr.slice (dv*j) dv arrv | j <- [0 .. du1]]
where du = subbasisDimension (entireBasis :: SubBasis (DualVector u))
dv = freeDimension ([]::[v])
instance β s u v .
( FiniteDimensional u, LSpace v, FiniteFreeSpace v
, Scalar u~s, Scalar v~s ) => FiniteFreeSpace (LinearFunction s u v) where
freeDimension _ = subbasisDimension (entireBasis :: SubBasis u)
* freeDimension ([]::[v])
toFullUnboxVect f = toFullUnboxVect (arr f :: LinearMap s u v)
unsafeFromFullUnboxVect arrv = arr (unsafeFromFullUnboxVect arrv :: LinearMap s u v)
adjoint :: β v w . (LinearSpace v, LinearSpace w, Scalar v ~ Scalar w)
=> (v +> DualVector w) -+> (w +> DualVector v)
adjoint = case ( dualSpaceWitness :: DualSpaceWitness v
, dualSpaceWitness :: DualSpaceWitness w ) of
(DualSpaceWitness, DualSpaceWitness)
-> arr fromTensor . transposeTensor . arr asTensor
multiSplit :: Int -> Int -> [a] -> ([[a]], [a])
multiSplit chunkSize 0 l = ([],l)
multiSplit chunkSize nChunks l = case splitAt chunkSize l of
(chunk, rest) -> first (chunk:) $ multiSplit chunkSize (nChunks1) rest