-- |
-- Module      : Math.LinearMap.Category.Instances
-- Copyright   : (c) Justus Sagemüller 2016
-- License     : GPL v3
-- 
-- Maintainer  : (@) sagemueller $ geo.uni-koeln.de
-- Stability   : experimental
-- Portability : portable
-- 
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE UnicodeSyntax              #-}
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE TupleSections              #-}

module Math.LinearMap.Category.Instances where

import Math.LinearMap.Category.Class

import Data.VectorSpace
import Data.Basis

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.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 qualified Data.Vector as Arr
import qualified Data.Vector.Unboxed as UArr

import Math.LinearMap.Asserted
import Math.VectorSpace.ZeroDimensional

import qualified GHC.Exts as GHC

infixr 7 <.>^
(<.>^) :: LinearSpace v => DualVector v -> v -> Scalar v
f<.>^v = (applyDualVector-+$>f)-+$>v


type ℝ = Double

instance Num' ℝ where
  closedScalarWitness = ClosedScalarWitness

instance TensorSpace ℝ where
  type TensorProduct ℝ w = w
  scalarSpaceWitness = ScalarSpaceWitness
  linearManifoldWitness = LinearManifoldWitness BoundarylessWitness
  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 = 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
  wellDefinedTensor (Tensor w) = Tensor <$> wellDefinedVector w
instance LinearSpace ℝ where
  type DualVector ℝ = ℝ
  dualSpaceWitness = DualSpaceWitness
  linearId = LinearMap 1
  tensorId = uncurryLinearMap $ LinearMap $ fmap (follow Tensor) -+$> id
  idTensor = Tensor 1
  fromLinearForm = flout LinearMap
  coerceDoubleDual = Coercion
  contractTensorMap = flout Tensor . flout LinearMap
  contractMapTensor = 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

#define FreeLinearSpace(V, LV, tp, tenspl, tenid, dspan, contraction, contraaction)  \
instance Num s => Semimanifold (V s) where {  \
  type Needle (V s) = V s;                      \
  toInterior = pure; fromInterior = id;           \
  (.+~^) = (^+^);                                     \
  translateP = Tagged (^+^) };                      \
instance Num s => PseudoAffine (V s) where {         \
  v.-~.w = pure (v^-^w); (.-~!) = (^-^) };              \
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 = LinearManifoldWitness BoundarylessWitness;   \
  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 -> follow Tensor}; \
  fromFlatTensor = case closedScalarWitness :: ClosedScalarWitness s of{ \
                         ClosedScalarWitness -> 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; \
  coerceFmapTensorProduct _ Coercion = 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 = Coercion; \
  fromLinearForm = case closedScalarWitness :: ClosedScalarWitness s of{ \
                         ClosedScalarWitness -> 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 (arr fromTensor >>> \
                         getLinearFunction . getLinearFunction applyLinear) f t; \
  composeLinear = bilinearFunction $   \
         \f (LinearMap g) -> LinearMap $ fmap ((applyLinear-+$>f)-+$>) g }
FreeLinearSpace( V0
               , LinearMap
               , \(Tensor V0) -> zeroV
               , \_ -> LinearMap V0
               , V0
               , LinearMap V0
               , \V0 -> zeroV
               , \V0 _ -> 0 )
FreeLinearSpace( V1
               , 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 )
FreeLinearSpace( V2
               , 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 )
FreeLinearSpace( V3
               , 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 )
FreeLinearSpace( V4
               , 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 )



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
  (.+~^) = (.+^); translateP = Tagged (.+^)
  toInterior = pure; fromInterior = id

instance (Num' n, UArr.Unbox n) => PseudoAffine (FinSuppSeq n) where
  v.-~.w = Just $ v.-.w; (.-~!) = (.-.)

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 = LinearManifoldWitness BoundarylessWitness
  zeroTensor = Tensor []
  toFlatTensor = LinearFunction $ Tensor . UArr.toList . getFiniteSeq
  fromFlatTensor = LinearFunction $ FinSuppSeq . UArr.fromList . getTensorProduct
  addTensors (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
  coerceFmapTensorProduct _ Coercion = 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
  (.+~^) = (.+^); translateP = Tagged (.+^)
  toInterior = pure; fromInterior = id

instance (Num' n, UArr.Unbox n) => PseudoAffine (Sequence n) where
  v.-~.w = Just $ v.-.w; (.-~!) = (.-.)

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 = LinearManifoldWitness BoundarylessWitness
  zeroTensor = Tensor []
  toFlatTensor = LinearFunction $ Tensor . GHC.toList
  fromFlatTensor = LinearFunction $ GHC.fromList . getTensorProduct
  addTensors (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
  coerceFmapTensorProduct _ Coercion = Coercion

instance (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
instance (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
  


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
  (.+~^) = (^+^)
  fromInterior = id
  toInterior = pure
  translateP = Tagged (^+^)
instance (TensorSpace v, Scalar v ~ s) => PseudoAffine (SymmetricTensor s v) where
  (.-~!) = (^-^)
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 = LinearManifoldWitness BoundarylessWitness
  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 (
                            arr (fmap Coercion) . 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 = fmap (fmap crc)
  wellDefinedTensor (Tensor t) = Tensor <$> wellDefinedVector t

instance (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 $ rassocTensor . asTensor
                          . fmap (follow SymTensor . asTensor) $ id
  tensorId = LinearMap $ asTensor . fmap asTensor . curryLinearMap
                           . fmap asTensor
                           . curryLinearMap
                           . fmap (follow $ \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 = case dualSpaceWitness :: DualSpaceWitness v of
    DualSpaceWitness -> bilinearFunction $ \(LinearMap f) (Tensor t)
                   -> getLinearFunction
                        (getLinearFunction applyTensorFunctional
                             $ fromTensor . fmap fromTensor $ f) t
  applyTensorLinMap = case dualSpaceWitness :: DualSpaceWitness v of
    DualSpaceWitness -> bilinearFunction $ \(LinearMap (Tensor f)) (Tensor t)
                   -> getLinearFunction (getLinearFunction applyTensorLinMap
                             $ uncurryLinearMap
                                . fmap (uncurryLinearMap . fromTensor . fmap fromTensor)
                                       $ LinearMap f) t  




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 = LinearFunction . arr $ fmap fromTensor . fromTensor . flout LinearMap