-- |
-- Module      : Math.LinearMap.Category.Derivatives
-- Copyright   : (c) Justus Sagemüller 2016
-- License     : GPL v3
-- 
-- Maintainer  : (@) jsag $ hvl.no
-- Stability   : experimental
-- Portability : portable
-- 
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# LANGUAGE FunctionalDependencies     #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE Rank2Types                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE PatternSynonyms            #-}
{-# LANGUAGE ViewPatterns               #-}
{-# LANGUAGE UnicodeSyntax              #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE DefaultSignatures          #-}

module Math.LinearMap.Category.Derivatives
    {-# WARNING "These lenses will probably change their domain in the future." #-} where

import Data.VectorSpace
import Data.VectorSpace.Free

import Prelude ()
import qualified Prelude as Hask

import Control.Category.Constrained.Prelude
import Control.Arrow.Constrained

import Data.Type.Coercion
import Data.Tagged

import Math.Manifold.Core.PseudoAffine
import Math.LinearMap.Asserted
import Math.LinearMap.Category.Instances
import Math.LinearMap.Category.Class

import Control.Lens

infixr 7 *∂, /∂, .∂
(/∂) :: ∀ s x y v q
          . ( Num' s, LinearSpace x, LinearSpace y, LinearSpace v, LinearSpace q
            , s ~ Scalar x, s ~ Scalar y, s ~ Scalar v, s ~ Scalar q )
       => Lens' y v -> Lens' x q -> Lens' (LinearMap s x y) (LinearMap s q v)
Lens' y v
𝑣/∂ :: Lens' y v -> Lens' x q -> Lens' (LinearMap s x y) (LinearMap s q v)
/∂Lens' x q
𝑞 = (LinearMap s x y -> LinearMap s q v)
-> (LinearMap s x y -> LinearMap s q v -> LinearMap s x y)
-> Lens' (LinearMap s x y) (LinearMap s q v)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\LinearMap s x y
m -> LinearFunction s y v
-> LinearFunction s (LinearMap s q y) (LinearMap s q v)
forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap ((y -> v) -> LinearFunction s y v
forall s v w. (v -> w) -> LinearFunction s v w
LinearFunction (y -> Getting v y v -> v
forall s a. s -> Getting a s a -> a
^.Getting v y v
Lens' y v
𝑣))
                     LinearFunction s (LinearMap s q y) (LinearMap s q v)
-> LinearMap s q y -> LinearMap s q v
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ LinearMap s x y
m LinearMap s x y -> LinearMap s q x -> LinearMap s q y
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. LinearFunction s q x -> LinearMap s q x
forall (a :: * -> * -> *) (k :: * -> * -> *) b c.
(EnhancedCat a k, Object k b, Object k c, Object a b,
 Object a c) =>
k b c -> a b c
arr ((q -> x) -> LinearFunction s q x
forall s v w. (v -> w) -> LinearFunction s v w
LinearFunction ((q -> x) -> LinearFunction s q x)
-> (q -> x) -> LinearFunction s q x
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \q
q -> x
forall v. AdditiveGroup v => v
zeroV x -> (x -> x) -> x
forall a b. a -> (a -> b) -> b
& (q -> Identity q) -> x -> Identity x
Lens' x q
𝑞((q -> Identity q) -> x -> Identity x) -> q -> x -> x
forall s t a b. ASetter s t a b -> b -> s -> t
.~q
q))
            (\LinearMap s x y
m LinearMap s q v
u -> LinearFunction s x y -> LinearMap s x y
forall (a :: * -> * -> *) (k :: * -> * -> *) b c.
(EnhancedCat a k, Object k b, Object k c, Object a b,
 Object a c) =>
k b c -> a b c
arr(LinearFunction s x y -> LinearMap s x y)
-> ((x -> y) -> LinearFunction s x y)
-> (x -> y)
-> LinearMap s x y
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
.(x -> y) -> LinearFunction s x y
forall s v w. (v -> w) -> LinearFunction s v w
LinearFunction
               ((x -> y) -> LinearMap s x y) -> (x -> y) -> LinearMap s x y
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \x
x -> (LinearMap s x y
m LinearMap s x y -> x -> y
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ x
x x -> (x -> x) -> x
forall a b. a -> (a -> b) -> b
& (q -> Identity q) -> x -> Identity x
Lens' x q
𝑞((q -> Identity q) -> x -> Identity x) -> q -> x -> x
forall s t a b. ASetter s t a b -> b -> s -> t
.~q
forall v. AdditiveGroup v => v
zeroV)
                   y -> y -> y
forall v. AdditiveGroup v => v -> v -> v
^+^ ((v -> Identity v) -> y -> Identity y
Lens' y v
𝑣((v -> Identity v) -> y -> Identity y) -> v -> y -> y
forall s t a b. ASetter s t a b -> b -> s -> t
.~(LinearMap s q v
u LinearMap s q v -> q -> v
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ x
xx -> Getting q x q -> q
forall s a. s -> Getting a s a -> a
^.Getting q x q
Lens' x q
𝑞) (y -> y) -> y -> y
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ LinearMap s x y
m LinearMap s x y -> x -> y
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ x
forall v. AdditiveGroup v => v
zeroV x -> (x -> x) -> x
forall a b. a -> (a -> b) -> b
& (q -> Identity q) -> x -> Identity x
Lens' x q
𝑞((q -> Identity q) -> x -> Identity x) -> q -> x -> x
forall s t a b. ASetter s t a b -> b -> s -> t
.~(x
xx -> Getting q x q -> q
forall s a. s -> Getting a s a -> a
^.Getting q x q
Lens' x q
𝑞)) )

(*∂) :: ∀ s a q v . ( Num' s, OneDimensional q, LinearSpace q, LinearSpace v
                   , s ~ Scalar a, s ~ Scalar q, s ~ Scalar v )
       => q -> Lens' a (LinearMap s q v) -> Lens' a v
q
q*∂ :: q -> Lens' a (LinearMap s q v) -> Lens' a v
*∂Lens' a (LinearMap s q v)
𝑚 = (a -> v) -> (a -> v -> a) -> Lens' a v
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\a
a -> a
aa
-> Getting (LinearMap s q v) a (LinearMap s q v) -> LinearMap s q v
forall s a. s -> Getting a s a -> a
^.Getting (LinearMap s q v) a (LinearMap s q v)
Lens' a (LinearMap s q v)
𝑚 LinearMap s q v -> q -> v
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ q
q)
           (\a
a v
v -> (a
a a -> (a -> a) -> a
forall a b. a -> (a -> b) -> b
& (LinearMap s q v -> Identity (LinearMap s q v)) -> a -> Identity a
Lens' a (LinearMap s q v)
𝑚 ((LinearMap s q v -> Identity (LinearMap s q v))
 -> a -> Identity a)
-> LinearMap s q v -> a -> a
forall s t a b. ASetter s t a b -> b -> s -> t
.~ LinearFunction s q v -> LinearMap s q v
forall (a :: * -> * -> *) (k :: * -> * -> *) b c.
(EnhancedCat a k, Object k b, Object k c, Object a b,
 Object a c) =>
k b c -> a b c
arr ((q -> v) -> LinearFunction s q v
forall s v w. (v -> w) -> LinearFunction s v w
LinearFunction ((q -> v) -> LinearFunction s q v)
-> (q -> v) -> LinearFunction s q v
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \q
q' -> v
v v -> s -> v
forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^* (q
q'q -> q -> Scalar q
forall v. OneDimensional v => v -> v -> Scalar v
^/!q
q))) )

(.∂) :: ∀ s x z . ( Fractional' s, LinearSpace x, s ~ Scalar x, LinearSpace z, s ~ Scalar z )
            => (∀ w . (LinearSpace w, Scalar w ~ s) => Lens' (TensorProduct x w) w)
                  -> Lens' x z -> Lens' (SymmetricTensor s x) z
forall w.
(LinearSpace w, Scalar w ~ s) =>
Lens' (TensorProduct x w) w
𝑤.∂ :: (forall w.
 (LinearSpace w, Scalar w ~ s) =>
 Lens' (TensorProduct x w) w)
-> Lens' x z -> Lens' (SymmetricTensor s x) z
.∂Lens' x z
𝑦 = case ClosedScalarWitness s
forall s. Num' s => ClosedScalarWitness s
closedScalarWitness :: ClosedScalarWitness s of
     ClosedScalarWitness s
ClosedScalarWitness -> (SymmetricTensor s x -> z)
-> (SymmetricTensor s x -> z -> SymmetricTensor s x)
-> Lens' (SymmetricTensor s x) z
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
            (\(SymTensor Tensor s x x
t)
               -> (Tensor s x z -> TensorProduct x z
forall s v w. Tensor s v w -> TensorProduct v w
getTensorProduct (Tensor s x z -> TensorProduct x z)
-> Tensor s x z -> TensorProduct x z
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ LinearFunction s x z
-> LinearFunction s (Tensor s x x) (Tensor s x z)
forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap ((x -> z) -> LinearFunction s x z
forall s v w. (v -> w) -> LinearFunction s v w
LinearFunction (x -> Getting z x z -> z
forall s a. s -> Getting a s a -> a
^.Getting z x z
Lens' x z
𝑦)) LinearFunction s (Tensor s x x) (Tensor s x z)
-> Tensor s x x -> Tensor s x z
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Tensor s x x
t)TensorProduct x z -> Getting z (TensorProduct x z) z -> z
forall s a. s -> Getting a s a -> a
^.Getting z (TensorProduct x z) z
forall w.
(LinearSpace w, Scalar w ~ s) =>
Lens' (TensorProduct x w) w
𝑤 z -> s -> z
forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^* s
0.5)
            (\(SymTensor (Tensor TensorProduct x x
t)) z
z -> Tensor s x x -> SymmetricTensor s x
forall s v. Tensor s v v -> SymmetricTensor s v
SymTensor (Tensor s x x -> SymmetricTensor s x)
-> (TensorProduct x x -> Tensor s x x)
-> TensorProduct x x
-> SymmetricTensor s x
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. TensorProduct x x -> Tensor s x x
forall s v w. TensorProduct v w -> Tensor s v w
Tensor (TensorProduct x x -> SymmetricTensor s x)
-> TensorProduct x x -> SymmetricTensor s x
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ ((x -> Identity x)
-> TensorProduct x x -> Identity (TensorProduct x x)
forall w.
(LinearSpace w, Scalar w ~ s) =>
Lens' (TensorProduct x w) w
𝑤((x -> Identity x)
 -> TensorProduct x x -> Identity (TensorProduct x x))
-> ((z -> Identity z) -> x -> Identity x)
-> (z -> Identity z)
-> TensorProduct x x
-> Identity (TensorProduct x x)
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
.(z -> Identity z) -> x -> Identity x
Lens' x z
𝑦((z -> Identity z)
 -> TensorProduct x x -> Identity (TensorProduct x x))
-> z -> TensorProduct x x -> TensorProduct x x
forall s t a b. ASetter s t a b -> b -> s -> t
.~z
zz -> s -> z
forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^*s
2) TensorProduct x x
t)