{-# 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 :: forall (n :: * -> *). Shade x -> RVarT n x
rvarT (Shade x
c Metric' x
e) = 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' :: forall x (m :: * -> *).
(PseudoAffine x, SimpleSpace (Needle x), Scalar (Needle x) ~ ℝ) =>
x -> Variance (Needle x) -> RVarT m x
shadeT' x
ctr Variance (Needle x)
expa = ((x
ctrforall x. Semimanifold x => x -> Needle x -> x
.+~^) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) v. (Foldable f, AdditiveGroup v) => f v -> v
sumV) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Needle x
v -> (Needle x
vforall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^*) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). Distribution Normal a => RVarT m a
stdNormalT) [Needle x]
eigSpan
   where eigSpan :: [Needle x]
eigSpan = 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 :: forall x.
(Distribution Shade x, D_S x) =>
x -> Variance (Needle x) -> RVar x
shade x
ctr Variance (Needle x)
expa = forall (d :: * -> *) t. Distribution d t => d t -> RVar t
rvar forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ 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 :: forall x (m :: * -> *).
(Distribution Shade x, D_S x) =>
x -> Variance (Needle x) -> RVarT m x
shadeT = 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 :: 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 Shade x
shx x -> Shade y
f = case ( forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualNeedleWitness x
                                         , forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualNeedleWitness 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 <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (d :: * -> *) t (n :: * -> *).
Distribution d t =>
d t -> RVarT n t
rvarT Shade x
shx
      [(x, y)]
pts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [x]
domainSpls forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \x
x -> do
         y
y <- forall (d :: * -> *) t (n :: * -> *).
Distribution d t =>
d t -> RVarT n t
rvarT forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ x -> Shade y
f x
x
         forall (m :: * -> *) a. Monad m => a -> m a
return (x
x,y
y)
      let t₀ :: Shaded x y
t₀ = forall x y.
(WithField ℝ Manifold x, SimpleSpace (Needle x)) =>
[(x, y)] -> Shaded x y
fromLeafPoints_ [(x, y)]
pts
          ntwigs :: Int
ntwigs = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n forall a. Fractional a => a -> a -> a
/ 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, LinearMap (Scalar (Needle x)) (Needle x) (Needle y)))
ensureThickness shl :: Shade' (x, y)
shl@(Shade' (x
xlc,y
ylc) Metric (x, y)
expa) = do
             let jOrig :: LinearMap (Scalar (Needle x)) (Needle x) (Needle y)
jOrig = forall u v.
(SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v) =>
Variance (u, v) -> u +> v
dependence forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall v. SimpleSpace v => Norm v -> Variance v
dualNorm Metric (x, y)
expa
                 (Norm (Needle x)
expax,Norm (Needle y)
expay) = forall u v.
(SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v) =>
Norm (u, v) -> (Norm u, Norm v)
summandSpaceNorms Metric (x, y)
expa
                 expax' :: Norm (Needle' x)
expax' = 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 forall a. Ord a => a -> a -> Bool
> ℝ
6  = 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 <- forall (d :: * -> *) t (n :: * -> *).
Distribution d t =>
d t -> RVarT n t
rvarT (forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade x
xlc forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall v. LSpace v => Scalar v -> Norm v -> Norm v
scaleNorm ℝ
1.2 Norm (Needle' x)
expax')
                       let Shade y
ylc Norm (Needle' y)
expaly = x -> Shade y
f x
x
                       y
y <- forall (d :: * -> *) t (n :: * -> *).
Distribution d t =>
d t -> RVarT n t
rvarT forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade y
ylc (forall v. LSpace v => Scalar v -> Norm v -> Norm v
scaleNorm ℝ
1.2 Norm (Needle' y)
expaly)
                       [(x, y)] -> ℝ -> RVarT m [(x, y)]
mkControlSample ((x
x,y
y)forall a. a -> [a] -> [a]
:[(x, y)]
css)
                         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
+ 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) Norm (Needle' x, Needle' y)
Metric' (x, y)
expaCtrl :: 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 = forall v. SimpleSpace v => Norm v -> Variance v
dualNorm forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall u v.
(SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v) =>
Norm (u, v) -> (Norm u, Norm v)
summandSpaceNorms Norm (Needle' x, Needle' y)
expaCtrl
                 jCtrl :: LinearMap (Scalar (Needle x)) (Needle x) (Needle y)
jCtrl = forall u v.
(SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v) =>
Variance (u, v) -> u +> v
dependence Norm (Needle' x, Needle' y)
expaCtrl
                 jFin :: LinearMap (Scalar (Needle x)) (Needle x) (Needle y)
jFin = LinearMap (Scalar (Needle x)) (Needle x) (Needle y)
jOrigforall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^*ℝ
η forall v. AdditiveGroup v => v -> v -> v
^+^ LinearMap (Scalar (Needle x)) (Needle x) (Needle y)
jCtrlforall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^*ℝ
η'
                 Just Needle x
δx = x
xlcforall 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
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (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
yCtrlforall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.y
ylc
             forall (m :: * -> *) a. Monad m => a -> m a
return ( x
xlc forall x. Semimanifold x => x -> Needle x -> x
.+~^ Needle x
δxforall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^*ℝ
η'
                    , ( forall x. x -> Metric x -> Shade' x
Shade' (y
ylc forall x. Semimanifold x => x -> Needle x -> x
.+~^ Needle y
δyforall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^*ℝ
η')
                               (forall v. LSpace v => Scalar v -> Norm v -> Norm v
scaleNorm (forall a. Floating a => a -> a
sqrt ℝ
η) Norm (Needle y)
expay forall a. Semigroup a => a -> a -> a
<> forall v. LSpace v => Scalar v -> Norm v -> Norm v
scaleNorm (forall a. Floating a => a -> a
sqrt ℝ
η') Norm (Needle y)
expayCtrl)
                      , LinearMap (Scalar (Needle x)) (Needle x) (Needle y)
jFin ) )
      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, LinearMap (Scalar (Needle x)) (Needle x) (Needle y)))
ensureThickness Shaded x y
t₀

uncrtFuncIntervalSpls :: (x~ℝ, y~ℝ)
      => Int -> (x,x) -> (x -> (y, Diff y)) -> RVar (x`Shaded`y)
uncrtFuncIntervalSpls :: forall x y.
(x ~ ℝ, y ~ ℝ) =>
Int -> (x, x) -> (x -> (y, Diff y)) -> RVar (Shaded x y)
uncrtFuncIntervalSpls Int
n (x
xl,x
xr) x -> (y, Diff y)
f
      = 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
            (forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade ((x
xlforall a. Num a => a -> a -> a
+x
xr)forall a. Fractional a => a -> a -> a
/x
2) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall v. LSpace v => [v] -> Variance v
spanVariance [(x
xrforall a. Num a => a -> a -> a
-x
xl)forall a. Fractional a => a -> a -> a
/x
2])
            (x -> (y, Diff y)
f forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \(ℝ
y,ℝ
δy) -> forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade ℝ
y forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall v. LSpace v => [v] -> Variance v
spanVariance [ℝ
δy])