-- |
-- Module      : Data.Manifold.Function.Quadratic
-- Copyright   : (c) Justus Sagemüller 2016
-- License     : GPL v3
-- 
-- Maintainer  : (@) jsag $ hvl.no
-- Stability   : experimental
-- Portability : portable
-- 

{-# LANGUAGE TypeFamilies             #-}
{-# LANGUAGE FlexibleContexts         #-}
{-# LANGUAGE UndecidableInstances     #-}
{-# LANGUAGE LiberalTypeSynonyms      #-}
{-# LANGUAGE GADTs                    #-}
{-# LANGUAGE TypeOperators            #-}
{-# LANGUAGE UnicodeSyntax            #-}
{-# LANGUAGE ScopedTypeVariables      #-}


module Data.Manifold.Function.Quadratic (
              Quadratic(..), evalQuadratic
            ) where



import Data.Semigroup
import qualified Data.List.NonEmpty as NE

import Data.MemoTrie
import Data.VectorSpace
import Data.AffineSpace
import Data.Tagged
import Data.Manifold.PseudoAffine
import Data.Manifold.Atlas
import Data.Manifold.Riemannian
import Data.Function.Affine

import Prelude                       hiding (id, ($), fmap, fst)
import Control.Category.Constrained.Prelude (id, ($), fmap, fst)
import Control.Arrow.Constrained ((>>>), (&&&), (***), second)

import Math.LinearMap.Category



data Quadratic s d c where
    Quadratic :: (ChartIndex d :->: ( c, ( LinearMap s (Needle d) (Needle c)
                                         , LinearMap s (SymmetricTensor s (Needle d))
                                                     (Needle c) ) )
                 )  -> Quadratic s d c

affineQuadratic :: (WithField s AffineManifold d, WithField s AffineManifold c)
        => Affine s d c -> Quadratic s d c
affineQuadratic :: forall s d c.
(WithField s AffineManifold d, WithField s AffineManifold c) =>
Affine s d c -> Quadratic s d c
affineQuadratic (Affine ChartIndex d :->: (c, LinearMap s (Needle d) (Needle c))
f) = forall d c s.
(ChartIndex d
 :->: (c,
       (LinearMap s (Needle d) (Needle c),
        LinearMap s (SymmetricTensor s (Needle d)) (Needle c))))
-> Quadratic s d c
Quadratic forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. HasTrie a => (a -> b) -> a :->: b
trie
                  forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a b. HasTrie a => (a :->: b) -> a -> b
untrie ChartIndex d :->: (c, LinearMap s (Needle d) (Needle c))
f forall (k :: * -> * -> *) a b c.
(Category k, Object k a, Object k b, Object k c) =>
k a b -> k b c -> k a c
>>> forall (a :: * -> * -> *) d b c.
(Morphism a, ObjectPair a d b, ObjectPair a d c) =>
a b c -> a (d, b) (d, c)
second (forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id forall (a :: * -> * -> *) b c c'.
(PreArrow a, Object a b, ObjectPair a c c') =>
a b c -> a b c' -> a b (c, c')
&&& forall a b. a -> b -> a
const forall v. AdditiveGroup v => v
zeroV)

instance ( Atlas x, HasTrie (ChartIndex x), Manifold y
         , LinearManifold (Needle x), Scalar (Needle x) ~ s
         , LinearManifold (Needle y), Scalar (Needle y) ~ s
         , Needle (Needle y) ~ Needle y
         ) => Semimanifold (Quadratic s x y) where
  type Needle (Quadratic s x y) = Quadratic s x (Needle y)
  .+~^ :: Quadratic s x y -> Needle (Quadratic s x y) -> Quadratic s x y
(.+~^) = case ( forall x. Semimanifold x => SemimanifoldWitness x
semimanifoldWitness :: SemimanifoldWitness y ) of
    (SemimanifoldWitness y
SemimanifoldWitness) -> \(Quadratic ChartIndex x
:->: (y,
      (LinearMap s (Needle x) (Needle y),
       LinearMap s (SymmetricTensor s (Needle x)) (Needle y)))
f) (Quadratic ChartIndex x
:->: (Needle y,
      (LinearMap s (Needle x) (Needle (Needle y)),
       LinearMap s (SymmetricTensor s (Needle x)) (Needle (Needle y))))
g)
      -> forall d c s.
(ChartIndex d
 :->: (c,
       (LinearMap s (Needle d) (Needle c),
        LinearMap s (SymmetricTensor s (Needle d)) (Needle c))))
-> Quadratic s d c
Quadratic forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. HasTrie a => (a -> b) -> a :->: b
trie forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \ChartIndex x
ix -> case (forall a b. HasTrie a => (a :->: b) -> a -> b
untrie ChartIndex x
:->: (y,
      (LinearMap s (Needle x) (Needle y),
       LinearMap s (SymmetricTensor s (Needle x)) (Needle y)))
f ChartIndex x
ix, forall a b. HasTrie a => (a :->: b) -> a -> b
untrie ChartIndex x
:->: (Needle y,
      (LinearMap s (Needle x) (Needle (Needle y)),
       LinearMap s (SymmetricTensor s (Needle x)) (Needle (Needle y))))
g ChartIndex x
ix) of
          ((y
fx₀,(LinearMap s (Needle x) (Needle y),
 LinearMap s (SymmetricTensor s (Needle x)) (Needle y))
f'), (Needle y
gx₀,(LinearMap s (Needle x) (Needle y),
 LinearMap s (SymmetricTensor s (Needle x)) (Needle y))
g')) -> (y
fx₀forall x. Semimanifold x => x -> Needle x -> x
.+~^Needle y
gx₀, (LinearMap s (Needle x) (Needle y),
 LinearMap s (SymmetricTensor s (Needle x)) (Needle y))
f'forall v. AdditiveGroup v => v -> v -> v
^+^(LinearMap s (Needle x) (Needle y),
 LinearMap s (SymmetricTensor s (Needle x)) (Needle y))
g')
  semimanifoldWitness :: SemimanifoldWitness (Quadratic s x y)
semimanifoldWitness = case forall x. Semimanifold x => SemimanifoldWitness x
semimanifoldWitness :: SemimanifoldWitness y of
    SemimanifoldWitness y
SemimanifoldWitness -> forall x.
(Semimanifold (Needle x), Needle (Needle x) ~ Needle x) =>
SemimanifoldWitness x
SemimanifoldWitness
instance ( Atlas x, HasTrie (ChartIndex x), Manifold y
         , LinearManifold (Needle x), Scalar (Needle x) ~ s
         , LinearManifold (Needle y), Scalar (Needle y) ~ s
         , Needle (Needle y) ~ Needle y
         ) => PseudoAffine (Quadratic s x y) where
  Quadratic s x y
p.-~. :: Quadratic s x y
-> Quadratic s x y -> Maybe (Needle (Quadratic s x y))
.-~.Quadratic s x y
q = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Quadratic s x y
pforall x. (PseudoAffine x, HasCallStack) => x -> x -> Needle x
.-~!Quadratic s x y
q)
  .-~! :: HasCallStack =>
Quadratic s x y -> Quadratic s x y -> Needle (Quadratic s x y)
(.-~!) = case ( forall x. Semimanifold x => SemimanifoldWitness x
semimanifoldWitness :: SemimanifoldWitness y ) of
    (SemimanifoldWitness y
SemimanifoldWitness) -> \(Quadratic ChartIndex x
:->: (y,
      (LinearMap s (Needle x) (Needle y),
       LinearMap s (SymmetricTensor s (Needle x)) (Needle y)))
f) (Quadratic ChartIndex x
:->: (y,
      (LinearMap s (Needle x) (Needle y),
       LinearMap s (SymmetricTensor s (Needle x)) (Needle y)))
g)
      -> forall d c s.
(ChartIndex d
 :->: (c,
       (LinearMap s (Needle d) (Needle c),
        LinearMap s (SymmetricTensor s (Needle d)) (Needle c))))
-> Quadratic s d c
Quadratic forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. HasTrie a => (a -> b) -> a :->: b
trie forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \ChartIndex x
ix -> case (forall a b. HasTrie a => (a :->: b) -> a -> b
untrie ChartIndex x
:->: (y,
      (LinearMap s (Needle x) (Needle y),
       LinearMap s (SymmetricTensor s (Needle x)) (Needle y)))
f ChartIndex x
ix, forall a b. HasTrie a => (a :->: b) -> a -> b
untrie ChartIndex x
:->: (y,
      (LinearMap s (Needle x) (Needle y),
       LinearMap s (SymmetricTensor s (Needle x)) (Needle y)))
g ChartIndex x
ix) of
          ((y
fx₀,(LinearMap s (Needle x) (Needle y),
 LinearMap s (SymmetricTensor s (Needle x)) (Needle y))
f'), (y
gx₀,(LinearMap s (Needle x) (Needle y),
 LinearMap s (SymmetricTensor s (Needle x)) (Needle y))
g')) -> (y
fx₀forall x. (PseudoAffine x, HasCallStack) => x -> x -> Needle x
.-~!y
gx₀, (LinearMap s (Needle x) (Needle y),
 LinearMap s (SymmetricTensor s (Needle x)) (Needle y))
f'forall v. AdditiveGroup v => v -> v -> v
^-^(LinearMap s (Needle x) (Needle y),
 LinearMap s (SymmetricTensor s (Needle x)) (Needle y))
g')
  pseudoAffineWitness :: PseudoAffineWitness (Quadratic s x y)
pseudoAffineWitness = case forall x. Semimanifold x => SemimanifoldWitness x
semimanifoldWitness :: SemimanifoldWitness y of
    SemimanifoldWitness y
SemimanifoldWitness -> forall x.
PseudoAffine (Needle x) =>
SemimanifoldWitness x -> PseudoAffineWitness x
PseudoAffineWitness (forall x.
(Semimanifold (Needle x), Needle (Needle x) ~ Needle x) =>
SemimanifoldWitness x
SemimanifoldWitness)
instance ( Atlas x, HasTrie (ChartIndex x), Manifold y
         , LinearManifold (Needle x), Scalar (Needle x) ~ s
         , LinearManifold (Needle y), Scalar (Needle y) ~ s
         , Needle (Needle y) ~ Needle y
         ) => AffineSpace (Quadratic s x y) where
  type Diff (Quadratic s x y) = Quadratic s x (Needle y)
  .+^ :: Quadratic s x y -> Diff (Quadratic s x y) -> Quadratic s x y
(.+^) = forall x. Semimanifold x => x -> Needle x -> x
(.+~^); .-. :: Quadratic s x y -> Quadratic s x y -> Diff (Quadratic s x y)
(.-.) = forall x. (PseudoAffine x, HasCallStack) => x -> x -> Needle x
(.-~!)
instance ( Atlas x, HasTrie (ChartIndex x)
         , LinearManifold (Needle x), Scalar (Needle x) ~ s
         , LinearManifold y, Scalar y ~ s
         , Needle y ~ y
         ) => AdditiveGroup (Quadratic s x y) where
  zeroV :: Quadratic s x y
zeroV = case forall v. TensorSpace v => LinearManifoldWitness v
linearManifoldWitness :: LinearManifoldWitness y of
       LinearManifoldWitness y
LinearManifoldWitness -> forall d c s.
(ChartIndex d
 :->: (c,
       (LinearMap s (Needle d) (Needle c),
        LinearMap s (SymmetricTensor s (Needle d)) (Needle c))))
-> Quadratic s d c
Quadratic forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. HasTrie a => (a -> b) -> a :->: b
trie forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a b. a -> b -> a
const (forall v. AdditiveGroup v => v
zeroV, forall v. AdditiveGroup v => v
zeroV)
  ^+^ :: Quadratic s x y -> Quadratic s x y -> Quadratic s x y
(^+^) = case ( forall v. TensorSpace v => LinearManifoldWitness v
linearManifoldWitness :: LinearManifoldWitness y
               , forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualSpaceWitness y ) of
      (LinearManifoldWitness y
LinearManifoldWitness, DualSpaceWitness y
DualSpaceWitness) -> forall x. Semimanifold x => x -> Needle x -> x
(.+~^)
  negateV :: Quadratic s x y -> Quadratic s x y
negateV = case forall v. TensorSpace v => LinearManifoldWitness v
linearManifoldWitness :: LinearManifoldWitness y of
       LinearManifoldWitness y
LinearManifoldWitness -> \(Quadratic ChartIndex x
:->: (y,
      (LinearMap s (Needle x) (Needle y),
       LinearMap s (SymmetricTensor s (Needle x)) (Needle y)))
f) -> forall d c s.
(ChartIndex d
 :->: (c,
       (LinearMap s (Needle d) (Needle c),
        LinearMap s (SymmetricTensor s (Needle d)) (Needle c))))
-> Quadratic s d c
Quadratic forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. HasTrie a => (a -> b) -> a :->: b
trie forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$
             forall a b. HasTrie a => (a :->: b) -> a -> b
untrie ChartIndex x
:->: (y,
      (LinearMap s (Needle x) (Needle y),
       LinearMap s (SymmetricTensor s (Needle x)) (Needle y)))
f forall (k :: * -> * -> *) a b c.
(Category k, Object k a, Object k b, Object k c) =>
k a b -> k b c -> k a c
>>> forall v. AdditiveGroup v => v -> v
negateVforall (a :: * -> * -> *) b b' c c'.
(Morphism a, ObjectPair a b b', ObjectPair a c c') =>
a b c -> a b' c' -> a (b, b') (c, c')
***forall v. AdditiveGroup v => v -> v
negateV
instance ( Atlas x, HasTrie (ChartIndex x)
         , LinearManifold (Needle x), Scalar (Needle x) ~ s
         , LinearManifold y, Scalar y ~ s
         , Needle y ~ y
         ) => VectorSpace (Quadratic s x y) where
  type Scalar (Quadratic s x y) = s
  *^ :: Scalar (Quadratic s x y) -> Quadratic s x y -> Quadratic s x y
(*^) = case forall v. TensorSpace v => LinearManifoldWitness v
linearManifoldWitness :: LinearManifoldWitness y of
       LinearManifoldWitness y
LinearManifoldWitness -> \Scalar (Quadratic s x y)
μ (Quadratic ChartIndex x
:->: (y,
      (LinearMap s (Needle x) (Needle y),
       LinearMap s (SymmetricTensor s (Needle x)) (Needle y)))
f) -> forall d c s.
(ChartIndex d
 :->: (c,
       (LinearMap s (Needle d) (Needle c),
        LinearMap s (SymmetricTensor s (Needle d)) (Needle c))))
-> Quadratic s d c
Quadratic forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. HasTrie a => (a -> b) -> a :->: b
trie forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$
             forall a b. HasTrie a => (a :->: b) -> a -> b
untrie ChartIndex x
:->: (y,
      (LinearMap s (Needle x) (Needle y),
       LinearMap s (SymmetricTensor s (Needle x)) (Needle y)))
f forall (k :: * -> * -> *) a b c.
(Category k, Object k a, Object k b, Object k c) =>
k a b -> k b c -> k a c
>>> (Scalar (Quadratic s x y)
μforall v. VectorSpace v => Scalar v -> v -> v
*^)forall (a :: * -> * -> *) b b' c c'.
(Morphism a, ObjectPair a b b', ObjectPair a c c') =>
a b c -> a b' c' -> a (b, b') (c, c')
***(Scalar (Quadratic s x y)
μforall v. VectorSpace v => Scalar v -> v -> v
*^)

evalQuadratic :: ∀ x y s . ( Manifold x, Atlas x, HasTrie (ChartIndex x)
                           , Manifold y
                           , s ~ Scalar (Needle x), s ~ Scalar (Needle y) )
               => Quadratic s x y -> x
                    -> (y, ( LinearMap s (Needle x) (Needle y)
                           , LinearMap s (SymmetricTensor s (Needle x)) (Needle y) ))
evalQuadratic :: forall x y s.
(Manifold x, Atlas x, HasTrie (ChartIndex x), Manifold y,
 s ~ Scalar (Needle x), s ~ Scalar (Needle y)) =>
Quadratic s x y
-> x
-> (y,
    (LinearMap s (Needle x) (Needle y),
     LinearMap s (SymmetricTensor s (Needle x)) (Needle y)))
evalQuadratic = Quadratic s x y
-> x
-> (y,
    (LinearMap s (Needle x) (Needle y),
     LinearMap s (SymmetricTensor s (Needle x)) (Needle y)))
ea
 where ea :: Quadratic s x y -> x -> (y, ( LinearMap s (Needle x) (Needle y)
                                            , LinearMap s (SymmetricTensor s (Needle x)) (Needle y) ))
       ea :: Quadratic s x y
-> x
-> (y,
    (LinearMap s (Needle x) (Needle y),
     LinearMap s (SymmetricTensor s (Needle x)) (Needle y)))
ea (Quadratic ChartIndex x
:->: (y,
      (LinearMap s (Needle x) (Needle y),
       LinearMap s (SymmetricTensor s (Needle x)) (Needle y)))
f) x
x = ( y
fx₀forall x. Semimanifold x => x -> Needle x -> x
.+~^(LinearMap s (Needle x) (Needle y)
ðx'f₀ forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Needle x
v)forall x. Semimanifold x => x -> Needle x -> x
.+~^(LinearMap s (SymmetricTensor s (Needle x)) (Needle y)
ð²x'f forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall s v.
(Num' s, s ~ Scalar v, TensorSpace v) =>
v -> SymmetricTensor s v
squareV Needle x
v)
                            , ( LinearMap s (Needle x) (Needle y)
ðx'f₀ forall v. AdditiveGroup v => v -> v -> v
^+^ s
2forall v. VectorSpace v => Scalar v -> v -> v
*^((forall v w. LinearSpace v => (v ⊗〃+> w) -+> (v +> (v +> w))
currySymBilin forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ LinearMap s (SymmetricTensor s (Needle x)) (Needle y)
ð²x'f) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Needle x
v)
                              , LinearMap s (SymmetricTensor s (Needle x)) (Needle y)
ð²x'f
                              ) )
        where Just Needle x
v = x
x forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~. forall m. Atlas m => ChartIndex m -> m
chartReferencePoint ChartIndex x
chIx
              chIx :: ChartIndex x
chIx = forall m. Atlas m => m -> ChartIndex m
lookupAtlas x
x
              (y
fx₀, (LinearMap s (Needle x) (Needle y)
ðx'f₀, LinearMap s (SymmetricTensor s (Needle x)) (Needle y)
ð²x'f)) = forall a b. HasTrie a => (a :->: b) -> a -> b
untrie ChartIndex x
:->: (y,
      (LinearMap s (Needle x) (Needle y),
       LinearMap s (SymmetricTensor s (Needle x)) (Needle y)))
f ChartIndex x
chIx