{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE UnicodeSyntax         #-}

module Data.Random.Manifold (shade, shadeT, D_S, uncertainFunctionSamplesT, uncrtFuncIntervalSpls) where

import Prelude hiding (($))
import Control.Category.Constrained.Prelude (($))

import Data.VectorSpace
import Data.AffineSpace
import Math.LinearMap.Category
import Data.Manifold.Types
import Data.Manifold.PseudoAffine
import Data.Manifold.TreeCover

import Data.Semigroup
import Data.Maybe (catMaybes)

import Data.Random

import Control.Applicative
import Control.Monad
import Control.Arrow

-- |
-- @
-- instance D_S x => 'Distribution' 'Shade' x
-- @
type D_S x = (WithField ℝ PseudoAffine x, SimpleSpace (Needle x))

instance D_S x => Distribution Shade x where
  rvarT :: Shade x -> RVarT n x
rvarT (Shade x
c Metric' x
e) = x -> Metric' x -> RVarT n x
forall x (m :: * -> *).
(PseudoAffine x, SimpleSpace (Needle x), Scalar (Needle x) ~ ℝ) =>
x -> Variance (Needle x) -> RVarT m x
shadeT' x
c Metric' x
e

shadeT' :: (PseudoAffine x, SimpleSpace (Needle x), Scalar (Needle x) ~ ℝ)
                      => x -> Variance (Needle x) -> RVarT m x
shadeT' :: x -> Variance (Needle x) -> RVarT m x
shadeT' x
ctr Variance (Needle x)
expa = ((x
ctrx -> Needle x -> x
forall x. Semimanifold x => x -> Needle x -> x
.+~^) (Needle x -> x) -> ([Needle x] -> Needle x) -> [Needle x] -> x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Needle x] -> Needle x
forall (f :: * -> *) v. (Foldable f, AdditiveGroup v) => f v -> v
sumV) ([Needle x] -> x) -> RVarT m [Needle x] -> RVarT m x
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Needle x -> RVarT m (Needle x))
-> [Needle x] -> RVarT m [Needle x]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Needle x
v -> (Needle x
vNeedle x -> ℝ -> Needle x
forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^*) (ℝ -> Needle x) -> RVarT m ℝ -> RVarT m (Needle x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RVarT m ℝ
forall a (m :: * -> *). Distribution Normal a => RVarT m a
stdNormalT) [Needle x]
eigSpan
   where eigSpan :: [Needle x]
eigSpan = Variance (Needle x) -> [Needle x]
forall v. SimpleSpace v => Variance v -> [v]
varianceSpanningSystem Variance (Needle x)
expa

-- | A shade can be considered a specification for a generalised normal distribution.
-- 
--   If you use 'rvar' to sample a large number of points from a shade @sh@ in a sufficiently
--   flat space, then 'pointsShades' of that sample will again be approximately @[sh]@.
shade :: (Distribution Shade x, D_S x) => x -> Variance (Needle x) -> RVar x
shade :: x -> Variance (Needle x) -> RVar x
shade x
ctr Variance (Needle x)
expa = Shade x -> RVar x
forall (d :: * -> *) t. Distribution d t => d t -> RVar t
rvar (Shade x -> RVar x) -> Shade x -> RVar x
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ x -> Variance (Needle x) -> Shade x
forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
fullShade x
ctr Variance (Needle x)
expa

shadeT :: (Distribution Shade x, D_S x) => x -> Variance (Needle x) -> RVarT m x
shadeT :: x -> Variance (Needle x) -> RVarT m x
shadeT = x -> Variance (Needle x) -> RVarT m x
forall x (m :: * -> *).
(PseudoAffine x, SimpleSpace (Needle x), Scalar (Needle x) ~ ℝ) =>
x -> Variance (Needle x) -> RVarT m x
shadeT'




uncertainFunctionSamplesT :: ∀ x y m .
        ( WithField ℝ Manifold x, SimpleSpace (Needle x)
        , WithField ℝ Manifold y, SimpleSpace (Needle y) )
       => Int -> Shade x -> (x -> Shade y) -> RVarT m (x`Shaded`y)
uncertainFunctionSamplesT :: Int -> Shade x -> (x -> Shade y) -> RVarT m (Shaded x y)
uncertainFunctionSamplesT Int
n Shade x
shx x -> Shade y
f = case ( DualSpaceWitness (Needle x)
forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualNeedleWitness x
                                         , DualSpaceWitness (Needle y)
forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualNeedleWitness y
                                         , PseudoAffineWitness y
forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness :: PseudoAffineWitness y ) of
    ( DualSpaceWitness (Needle x)
DualSpaceWitness, DualSpaceWitness (Needle y)
DualSpaceWitness
     ,PseudoAffineWitness SemimanifoldWitness y
SemimanifoldWitness ) -> do
      [x]
domainSpls <- Int -> RVarT m x -> RVarT m [x]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (RVarT m x -> RVarT m [x]) -> RVarT m x -> RVarT m [x]
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Shade x -> RVarT m x
forall (d :: * -> *) t (n :: * -> *).
Distribution d t =>
d t -> RVarT n t
rvarT Shade x
shx
      [(x, y)]
pts <- [x] -> (x -> RVarT m (x, y)) -> RVarT m [(x, y)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [x]
domainSpls ((x -> RVarT m (x, y)) -> RVarT m [(x, y)])
-> (x -> RVarT m (x, y)) -> RVarT m [(x, y)]
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \x
x -> do
         y
y <- Shade y -> RVarT m y
forall (d :: * -> *) t (n :: * -> *).
Distribution d t =>
d t -> RVarT n t
rvarT (Shade y -> RVarT m y) -> Shade y -> RVarT m y
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ x -> Shade y
f x
x
         (x, y) -> RVarT m (x, y)
forall (m :: * -> *) a. Monad m => a -> m a
return (x
x,y
y)
      let t₀ :: Shaded x y
t₀ = [(x, y)] -> Shaded x y
forall x y.
(WithField ℝ Manifold x, SimpleSpace (Needle x)) =>
[(x, y)] -> Shaded x y
fromLeafPoints_ [(x, y)]
pts
          ntwigs :: Int
ntwigs = [(Twig x y, TwigEnviron x y)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(Twig x y, TwigEnviron x y)] -> Int)
-> [(Twig x y, TwigEnviron x y)] -> Int
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Shaded x y -> [(Twig x y, TwigEnviron x y)]
forall x y.
(WithField ℝ Manifold x, SimpleSpace (Needle x)) =>
Shaded x y -> [(Twig x y, TwigEnviron x y)]
twigsWithEnvirons Shaded x y
t₀
          nPerTwig :: ℝ
nPerTwig = Int -> ℝ
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n ℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ Int -> ℝ
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ntwigs
          ensureThickness :: Shade' (x,y)
                  -> RVarT m (x, (Shade' y, Needle x +> Needle y))
          ensureThickness :: Shade' (x, y) -> RVarT m (x, (Shade' y, Needle x +> Needle y))
ensureThickness shl :: Shade' (x, y)
shl@(Shade' (x
xlc,y
ylc) Metric (x, y)
expa) = do
             let jOrig :: Needle x +> Needle y
jOrig = Norm (DualVector (Needle x), DualVector (Needle y))
-> Needle x +> Needle y
forall u v.
(SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v) =>
Variance (u, v) -> u +> v
dependence (Norm (DualVector (Needle x), DualVector (Needle y))
 -> Needle x +> Needle y)
-> Norm (DualVector (Needle x), DualVector (Needle y))
-> Needle x +> Needle y
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Norm (Needle x, Needle y) -> Variance (Needle x, Needle y)
forall v. SimpleSpace v => Norm v -> Variance v
dualNorm Norm (Needle x, Needle y)
Metric (x, y)
expa
                 (Norm (Needle x)
expax,Norm (Needle y)
expay) = Norm (Needle x, Needle y) -> (Norm (Needle x), Norm (Needle y))
forall u v.
(SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v) =>
Norm (u, v) -> (Norm u, Norm v)
summandSpaceNorms Norm (Needle x, Needle y)
Metric (x, y)
expa
                 expax' :: Variance (Needle x)
expax' = Norm (Needle x) -> Variance (Needle x)
forall v. SimpleSpace v => Norm v -> Variance v
dualNorm Norm (Needle x)
expax
                 mkControlSample :: [(x, y)] -> ℝ -> RVarT m [(x, y)]
mkControlSample [(x, y)]
css ℝ
confidence
                  | ℝ
confidence ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
> ℝ
6  = [(x, y)] -> RVarT m [(x, y)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(x, y)]
css
                  | Bool
otherwise  = do
                              -- exaggerate deviations a bit here, to avoid clustering
                              -- in center of normal distribution.
                       x
x <- Shade x -> RVarT m x
forall (d :: * -> *) t (n :: * -> *).
Distribution d t =>
d t -> RVarT n t
rvarT (x -> Variance (Needle x) -> Shade x
forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade x
xlc (Variance (Needle x) -> Shade x) -> Variance (Needle x) -> Shade x
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Scalar (DualVector (Needle x))
-> Variance (Needle x) -> Variance (Needle x)
forall v. LSpace v => Scalar v -> Norm v -> Norm v
scaleNorm Scalar (DualVector (Needle x))
1.2 Variance (Needle x)
expax')
                       let Shade y
ylc Metric' y
expaly = x -> Shade y
f x
x
                       y
y <- Shade y -> RVarT m y
forall (d :: * -> *) t (n :: * -> *).
Distribution d t =>
d t -> RVarT n t
rvarT (Shade y -> RVarT m y) -> Shade y -> RVarT m y
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ y -> Metric' y -> Shade y
forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade y
ylc (Scalar (DualVector (Needle y)) -> Metric' y -> Metric' y
forall v. LSpace v => Scalar v -> Norm v -> Norm v
scaleNorm Scalar (DualVector (Needle y))
1.2 Metric' y
expaly)
                       [(x, y)] -> ℝ -> RVarT m [(x, y)]
mkControlSample ((x
x,y
y)(x, y) -> [(x, y)] -> [(x, y)]
forall a. a -> [a] -> [a]
:[(x, y)]
css)
                         (ℝ -> RVarT m [(x, y)]) -> ℝ -> RVarT m [(x, y)]
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ ℝ
confidence ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
+ Shade' (x, y) -> (x, y) -> ℝ
forall (shade :: * -> *) x s.
(IsShade shade, PseudoAffine x, SimpleSpace (Needle x),
 s ~ Scalar (Needle x), RealFloat' s) =>
shade x -> x -> s
occlusion Shade' (x, y)
shl (x
x,y
y)
             [(x, y)]
css <- [(x, y)] -> ℝ -> RVarT m [(x, y)]
mkControlSample [] ℝ
0
             let xCtrl :: x
                 [Shade (x
xCtrl,y
yCtrl) Metric' (x, y)
expaCtrl :: Shade (x,y)]
                       = [(x, y)] -> [Shade (x, y)]
forall x.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
[x] -> [Shade x]
pointsShades [(x, y)]
css
                 yCtrl :: y
                 expayCtrl :: Norm (Needle y)
expayCtrl = Metric' y -> Norm (DualVector (DualVector (Needle y)))
forall v. SimpleSpace v => Norm v -> Variance v
dualNorm (Metric' y -> Norm (DualVector (DualVector (Needle y))))
-> ((Variance (Needle x), Metric' y) -> Metric' y)
-> (Variance (Needle x), Metric' y)
-> Norm (DualVector (DualVector (Needle y)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Variance (Needle x), Metric' y) -> Metric' y
forall a b. (a, b) -> b
snd ((Variance (Needle x), Metric' y) -> Norm (Needle y))
-> (Variance (Needle x), Metric' y) -> Norm (Needle y)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Norm (DualVector (Needle x), DualVector (Needle y))
-> (Variance (Needle x), Metric' y)
forall u v.
(SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v) =>
Norm (u, v) -> (Norm u, Norm v)
summandSpaceNorms Norm (DualVector (Needle x), DualVector (Needle y))
expaCtrl
                 jCtrl :: Needle x +> Needle y
jCtrl = Variance (Needle x, Needle y) -> Needle x +> Needle y
forall u v.
(SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v) =>
Variance (u, v) -> u +> v
dependence Norm (DualVector (Needle x), DualVector (Needle y))
Variance (Needle x, Needle y)
expaCtrl
                 jFin :: Needle x +> Needle y
jFin = Needle x +> Needle y
jOrig(Needle x +> Needle y) -> ℝ -> Needle x +> Needle y
forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^*ℝ
η (Needle x +> Needle y)
-> (Needle x +> Needle y) -> Needle x +> Needle y
forall v. AdditiveGroup v => v -> v -> v
^+^ Needle x +> Needle y
jCtrl(Needle x +> Needle y) -> ℝ -> Needle x +> Needle y
forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^*ℝ
η'
                 Just Needle x
δx = x
xlcx -> x -> Maybe (Needle x)
forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
xCtrl
                 η, η' :: ℝ
                 η :: ℝ
η = ℝ
nPerTwig ℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ (ℝ
nPerTwig ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
+ Int -> ℝ
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([(x, y)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(x, y)]
css))
                 η' :: ℝ
η' = ℝ
1 ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
- ℝ
η
                 Just Needle y
δy = y
yCtrly -> y -> Maybe (Needle y)
forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.y
ylc
             (x, (Shade' y, Needle x +> Needle y))
-> RVarT m (x, (Shade' y, Needle x +> Needle y))
forall (m :: * -> *) a. Monad m => a -> m a
return ( x
xlc x -> Needle x -> x
forall x. Semimanifold x => x -> Needle x -> x
.+~^ Needle x
δxNeedle x -> ℝ -> Needle x
forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^*ℝ
η'
                    , ( y -> Norm (Needle y) -> Shade' y
forall x. x -> Metric x -> Shade' x
Shade' (y
ylc y -> Needle y -> y
forall x. Semimanifold x => x -> Needle x -> x
.+~^ Needle y
δyNeedle y -> ℝ -> Needle y
forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^*ℝ
η')
                               (Scalar (Needle y) -> Norm (Needle y) -> Norm (Needle y)
forall v. LSpace v => Scalar v -> Norm v -> Norm v
scaleNorm (ℝ -> ℝ
forall a. Floating a => a -> a
sqrt ℝ
η) Norm (Needle y)
expay Norm (Needle y) -> Norm (Needle y) -> Norm (Needle y)
forall a. Semigroup a => a -> a -> a
<> Scalar (Needle y) -> Norm (Needle y) -> Norm (Needle y)
forall v. LSpace v => Scalar v -> Norm v -> Norm v
scaleNorm (ℝ -> ℝ
forall a. Floating a => a -> a
sqrt ℝ
η') Norm (Needle y)
expayCtrl)
                      , Needle x +> Needle y
jFin ) )
      (Shade' (x, y) -> RVarT m (x, (Shade' y, Needle x +> Needle y)))
-> Shaded x y -> RVarT m (Shaded x y)
forall x y (f :: * -> *).
(WithField ℝ Manifold x, WithField ℝ Manifold y,
 SimpleSpace (Needle x), SimpleSpace (Needle y), Applicative f) =>
(Shade' (x, y) -> f (x, (Shade' y, LocalLinear x y)))
-> Shaded x y -> f (Shaded x y)
flexTwigsShading Shade' (x, y) -> RVarT m (x, (Shade' y, Needle x +> Needle y))
ensureThickness Shaded x y
t₀

uncrtFuncIntervalSpls :: (x~ℝ, y~ℝ)
      => Int -> (x,x) -> (x -> (y, Diff y)) -> RVar (x`Shaded`y)
uncrtFuncIntervalSpls :: Int -> (x, x) -> (x -> (y, Diff y)) -> RVar (Shaded x y)
uncrtFuncIntervalSpls Int
n (x
xl,x
xr) x -> (y, Diff y)
f
      = Int -> Shade x -> (x -> Shade y) -> RVar (Shaded x y)
forall x y (m :: * -> *).
(WithField ℝ Manifold x, SimpleSpace (Needle x),
 WithField ℝ Manifold y, SimpleSpace (Needle y)) =>
Int -> Shade x -> (x -> Shade y) -> RVarT m (Shaded x y)
uncertainFunctionSamplesT Int
n
            (x -> Metric' x -> Shade x
forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade ((x
xlx -> x -> x
forall a. Num a => a -> a -> a
+x
xr)x -> x -> x
forall a. Fractional a => a -> a -> a
/x
2) (Norm ℝ -> Shade x) -> Norm ℝ -> Shade x
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ [x] -> Variance x
forall v. LSpace v => [v] -> Variance v
spanVariance [(x
xrx -> x -> x
forall a. Num a => a -> a -> a
-x
xl)x -> x -> x
forall a. Fractional a => a -> a -> a
/x
2])
            (x -> (y, Diff y)
ℝ -> (ℝ, ℝ)
f (ℝ -> (ℝ, ℝ)) -> ((ℝ, ℝ) -> Shade ℝ) -> ℝ -> Shade ℝ
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \(ℝ
y,ℝ
δy) -> ℝ -> Metric' ℝ -> Shade ℝ
forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade ℝ
y (Norm ℝ -> Shade ℝ) -> Norm ℝ -> Shade ℝ
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ [ℝ] -> Variance ℝ
forall v. LSpace v => [v] -> Variance v
spanVariance [ℝ
δy])