{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LiberalTypeSynonyms #-}
module Data.Manifold.DifferentialEquation (
DifferentialEqn, ODE
, constLinearDEqn
, constLinearODE
, iterateFilterDEqn_static
, maxDeviationsGoal
, uncertaintyGoal
, uncertaintyGoal'
, euclideanVolGoal
, InconsistencyStrategy(..)
) where
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NE
import Data.VectorSpace
import Data.VectorSpace.Free
import Math.LinearMap.Category
import Data.AffineSpace
import Data.Basis
import Data.Manifold.Types
import Data.Manifold.PseudoAffine
import Data.Manifold.Shade
import Data.Manifold.Function.LocalModel
import Data.Function.Differentiable
import Data.Function.Differentiable.Data
import Data.Manifold.TreeCover
import Data.Manifold.Web
import Data.Manifold.Atlas
import Data.Embedding
import qualified Data.List as List
import qualified Prelude as Hask hiding(foldl, sum, sequence)
import qualified Control.Applicative as Hask
import qualified Control.Monad as Hask hiding(forM_, sequence)
import qualified Data.Foldable as Hask
import qualified Data.Traversable as Hask
import Control.Category.Constrained.Prelude hiding
((^), all, elem, sum, forM, Foldable(..), foldr1, Traversable, traverse)
import Control.Arrow.Constrained
import Control.Monad.Constrained hiding (forM)
import Data.Foldable.Constrained
import Data.Traversable.Constrained (Traversable, traverse)
import Control.Lens
type ODE x y = DifferentialEqn QuadraticModel x y
constLinearDEqn :: ∀ x y . ( SimpleSpace x
, SimpleSpace y, AffineManifold y
, Scalar x ~ ℝ, Scalar y ~ ℝ )
=> (y +> (x +> y)) -> ((x +> y) +> y) -> DifferentialEqn QuadraticModel x y
constLinearDEqn :: forall x y.
(SimpleSpace x, SimpleSpace y, AffineManifold y, Scalar x ~ ℝ,
Scalar y ~ ℝ) =>
(y +> (x +> y))
-> ((x +> y) +> y) -> DifferentialEqn QuadraticModel x y
constLinearDEqn = case ( forall v. TensorSpace v => LinearManifoldWitness v
linearManifoldWitness :: LinearManifoldWitness x
, forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualSpaceWitness x
, forall v. TensorSpace v => LinearManifoldWitness v
linearManifoldWitness :: LinearManifoldWitness y
, forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualSpaceWitness y ) of
( LinearManifoldWitness x
LinearManifoldWitness, DualSpaceWitness x
DualSpaceWitness
,LinearManifoldWitness y
LinearManifoldWitness, DualSpaceWitness y
DualSpaceWitness ) -> \y +> (x +> y)
bwt'inv (x +> y) +> y
bwt' ->
\(Shade (x
_x,y
y) Metric' (x, y)
δxy) -> LocalDifferentialEqn
{ _rescanDifferentialEqn :: QuadraticModel x y
-> (Maybe (Shade' y), Maybe (Shade' (LocalLinear x y)))
_rescanDifferentialEqn
= \(QuadraticModel Shade y
shy' Shade (LocalLinear x y)
shj'Apriori Shade (Needle x ⊗〃+> Needle y)
_) ->
let shy :: Shade' y
shy = forall x.
(PseudoAffine x, SimpleSpace (Needle x)) =>
Shade x -> Shade' x
dualShade Shade y
shy'
shjApriori :: Shade' (LinearMap ℝ x y)
shjApriori = forall x.
(PseudoAffine x, SimpleSpace (Needle x)) =>
Shade x -> Shade' x
dualShade Shade (LocalLinear x y)
shj'Apriori
in ( forall y.
(WithField ℝ Manifold y, SimpleSpace (Needle y)) =>
NonEmpty (Shade' y) -> Maybe (Shade' y)
mixShade's forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Shade' y
shy
forall a. a -> [a] -> NonEmpty a
:| [ forall (shade :: * -> *) x y s.
(IsShade shade, Semimanifold x, Semimanifold y,
Object (Affine s) x, Object (Affine s) y, SimpleSpace (Needle x),
SemiInner (Needle y)) =>
Embedding (Affine s) x y -> shade y -> shade x
projectShade
(forall (c :: * -> * -> *) a b. c a b -> c b a -> Embedding c a b
Embedding (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 y +> (x +> y)
bwt'inv)
(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 (x +> y) +> y
bwt'))
Shade' (LinearMap ℝ x y)
shjApriori ]
, forall (m :: * -> *) a. Monad m (->) => a -> m a
return forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (shade :: * -> *) x y s.
(IsShade shade, Semimanifold x, Semimanifold y,
Object (Affine s) x, Object (Affine s) y, SimpleSpace (Needle x),
SemiInner (Needle y)) =>
Embedding (Affine s) x y -> shade y -> shade x
projectShade
(forall (c :: * -> * -> *) a b. c a b -> c b a -> Embedding c a b
Embedding (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 (x +> y) +> y
bwt')
(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 y +> (x +> y)
bwt'inv))
Shade' y
shy
)
}
constLinearODE :: ∀ x y . ( SimpleSpace x, Scalar x ~ ℝ
, AffineManifold y, SimpleSpace y, Scalar y ~ ℝ )
=> ((x +> y) +> y) -> ODE x y
constLinearODE :: forall x y.
(SimpleSpace x, Scalar x ~ ℝ, AffineManifold y, SimpleSpace y,
Scalar y ~ ℝ) =>
((x +> y) +> y) -> ODE x y
constLinearODE = case ( forall v. TensorSpace v => LinearManifoldWitness v
linearManifoldWitness :: LinearManifoldWitness x
, forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualSpaceWitness x
, forall v. TensorSpace v => LinearManifoldWitness v
linearManifoldWitness :: LinearManifoldWitness y
, forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualSpaceWitness y ) of
( LinearManifoldWitness x
LinearManifoldWitness, DualSpaceWitness x
DualSpaceWitness
,LinearManifoldWitness y
LinearManifoldWitness, DualSpaceWitness y
DualSpaceWitness ) -> \(x +> y) +> y
bwt' ->
let bwt'inv :: y +> LinearMap ℝ x y
bwt'inv = forall u v.
(SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v) =>
(u +> v) -> v +> u
pseudoInverse (x +> y) +> y
bwt'
in \(Shade (x
_x,y
y) Metric' (x, y)
δxy) -> forall (ㄇ :: * -> * -> *) x y.
(ㄇ x y -> (Maybe (Shade' y), Maybe (Shade' (LocalLinear x y))))
-> LocalDifferentialEqn ㄇ x y
LocalDifferentialEqn
(\(QuadraticModel Shade y
shy' Shade (LocalLinear x y)
_ Shade (Needle x ⊗〃+> Needle y)
_) ->
let shy :: Shade' y
shy = forall x.
(PseudoAffine x, SimpleSpace (Needle x)) =>
Shade x -> Shade' x
dualShade Shade y
shy'
in ( forall (m :: * -> *) a. Monad m (->) => a -> m a
return forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Shade' y
shy forall a b. a -> (a -> b) -> b
& forall x. Lens' (Shade' x) (Metric x)
shadeNarrowness forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall v. LSpace v => Scalar v -> Norm v -> Norm v
scaleNorm ℝ
0.01
, forall (m :: * -> *) a. Monad m (->) => a -> m a
return forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (shade :: * -> *) x y s.
(IsShade shade, Semimanifold x, Semimanifold y,
Object (Affine s) x, Object (Affine s) y, SimpleSpace (Needle x),
SemiInner (Needle y)) =>
Embedding (Affine s) x y -> shade y -> shade x
projectShade (forall (c :: * -> * -> *) a b. c a b -> c b a -> Embedding c a b
Embedding (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 (x +> y) +> y
bwt')
(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 y +> LinearMap ℝ x y
bwt'inv)) Shade' y
shy )
)
goalSensitive :: ℝ -> ℝ
goalSensitive :: ℝ -> ℝ
goalSensitive ℝ
η = ℝ
0.3 forall a. Num a => a -> a -> a
+ forall a. Floating a => a -> a
sqrt (ℝ
η forall a. Num a => a -> a -> a
* (ℝ
1 forall a. Num a => a -> a -> a
+ ℝ
ηforall a. Fractional a => a -> a -> a
/(ℝ
1forall a. Num a => a -> a -> a
+ℝ
η)) forall a. Fractional a => a -> a -> a
/ (ℝ
3 forall a. Num a => a -> a -> a
+ ℝ
η))
euclideanVolGoal :: (WithField ℝ EuclidSpace y, SimpleSpace (Needle y))
=> ℝ -> x -> Shade' y -> ℝ
euclideanVolGoal :: forall y x.
(WithField ℝ EuclidSpace y, SimpleSpace (Needle y)) =>
ℝ -> x -> Shade' y -> ℝ
euclideanVolGoal ℝ
vTgt x
_ (Shade' y
_ Metric y
shy) = ℝ -> ℝ
goalSensitive ℝ
η
where η :: ℝ
η = forall y. (SimpleSpace y, HilbertSpace y) => Norm y -> Scalar y
euclideanRelativeMetricVolume Metric y
shy forall a. Fractional a => a -> a -> a
/ ℝ
vTgt
euclideanRelativeMetricVolume :: (SimpleSpace y, HilbertSpace y) => Norm y -> Scalar y
euclideanRelativeMetricVolume :: forall y. (SimpleSpace y, HilbertSpace y) => Norm y -> Scalar y
euclideanRelativeMetricVolume (Norm y -+> DualVector y
m) = forall a. Fractional a => a -> a
recip 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
. forall v.
(FiniteDimensional v, IEEE (Scalar v)) =>
(v +> v) -> Scalar v
roughDet 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
. 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 forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ y -+> DualVector y
ue 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
. y -+> DualVector y
m
where Norm y -+> DualVector y
ue = forall v. HilbertSpace v => Norm v
euclideanNorm
maxDeviationsGoal :: (WithField ℝ EuclidSpace y, SimpleSpace (Needle y))
=> [Needle y] -> x -> Shade' y -> ℝ
maxDeviationsGoal :: forall y x.
(WithField ℝ EuclidSpace y, SimpleSpace (Needle y)) =>
[Needle y] -> x -> Shade' y -> ℝ
maxDeviationsGoal = forall y x.
(WithField ℝ EuclidSpace y, SimpleSpace (Needle y)) =>
Metric' y -> x -> Shade' y -> ℝ
uncertaintyGoal 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
. forall v. LSpace v => [DualVector v] -> Seminorm v
spanNorm
uncertaintyGoal :: (WithField ℝ EuclidSpace y, SimpleSpace (Needle y))
=> Metric' y -> x -> Shade' y -> ℝ
uncertaintyGoal :: forall y x.
(WithField ℝ EuclidSpace y, SimpleSpace (Needle y)) =>
Metric' y -> x -> Shade' y -> ℝ
uncertaintyGoal = forall y x.
(WithField ℝ EuclidSpace y, SimpleSpace (Needle y)) =>
(x -> Metric' y) -> x -> Shade' y -> ℝ
uncertaintyGoal' 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
. forall (a :: * -> * -> *) b x.
(WellPointed a, Object a b, ObjectPoint a x) =>
x -> a b x
const
uncertaintyGoal' :: (WithField ℝ EuclidSpace y, SimpleSpace (Needle y))
=> (x -> Metric' y) -> x -> Shade' y -> ℝ
uncertaintyGoal' :: forall y x.
(WithField ℝ EuclidSpace y, SimpleSpace (Needle y)) =>
(x -> Metric' y) -> x -> Shade' y -> ℝ
uncertaintyGoal' x -> Metric' y
f x
x (Shade' y
_ Metric y
shy)
= forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
List.sum [ℝ -> ℝ
goalSensitive forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ ℝ
1 forall a. Fractional a => a -> a -> a
/ forall v. LSpace v => Seminorm v -> v -> Scalar v
normSq Metric' y
m Diff y
q | Diff y
q <- [DualVector (Diff y)]
shySpan]
where shySpan :: [DualVector (Diff y)]
shySpan = forall v. SimpleSpace v => Seminorm v -> [DualVector v]
normSpanningSystem Metric y
shy
m :: Metric' y
m = x -> Metric' y
f x
x