-- |
-- Module      : Data.Manifold.Shade
-- Copyright   : (c) Justus Sagemüller 2016
-- License     : GPL v3
-- 
-- Maintainer  : (@) jsagemue $ uni-koeln.de
-- Stability   : experimental
-- Portability : portable
-- 
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ParallelListComp           #-}
{-# LANGUAGE UnicodeSyntax              #-}
{-# LANGUAGE PatternSynonyms            #-}
{-# LANGUAGE ViewPatterns               #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE LiberalTypeSynonyms        #-}
{-# LANGUAGE DefaultSignatures          #-}
{-# LANGUAGE TemplateHaskell            #-}


module Data.Manifold.Shade (
       -- * Shades 
         Shade(..), pattern(:±), Shade'(..), (|±|), IsShade
       -- ** Lenses
       , shadeCtr, shadeExpanse, shadeNarrowness
       -- ** Construction
       , fullShade, fullShade', pointsShades, pointsShade's
       , pointsCovers, pointsCover's, coverAllAround
       -- ** Evaluation
       , occlusion, prettyShowsPrecShade', prettyShowShade', LtdErrorShow
       -- ** Misc
       , factoriseShade, orthoShades, (✠), intersectShade's, linIsoTransformShade
       , embedShade, projectShade
       , Refinable, subShade', refineShade', convolveShade', coerceShade
       , mixShade's, dualShade, dualShade', wellDefinedShade', linearProjectShade
       , shadesMerge, pointsShades', pseudoECM, convolveMetric
       , WithAny(..), shadeWithAny, shadeWithoutAnything
       -- * Misc
       , rangeWithinVertices
    ) where


import Data.List hiding (filter, all, elem, sum, foldr1)
import Data.Maybe
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NE
import Data.Semigroup
import Control.DeepSeq
import Data.MemoTrie

import Data.VectorSpace
import Data.AffineSpace
import Math.LinearMap.Category
import Data.Tagged
import Linear (_x,_y,_z,_w)

import Data.Manifold.Types
import Data.Manifold.Types.Primitive ((^))
import Data.Manifold.PseudoAffine
import Data.Manifold.Riemannian
import Data.Manifold.WithBoundary
import Data.Manifold.Atlas
import Data.Function.Affine
import Data.Manifold.Function.Quadratic

import Data.Embedding

import Control.Lens (Lens', (^.), view, _1, _2, mapping, (&))
import Control.Lens.TH

import qualified Prelude as Hask hiding(foldl, sum, sequence)
import qualified Control.Applicative as Hask
import qualified Data.Foldable       as Hask
import Data.Foldable (all, elem, toList, sum, foldr1)

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 GHC.Generics (Generic)

import Text.Show.Number
import qualified Text.Show.Pragmatic as SP


-- | A 'Shade' is a very crude description of a region within a manifold. It
--   can be interpreted as either an ellipsoid shape, or as the Gaussian peak
--   of a normal distribution (use <http://hackage.haskell.org/package/manifold-random>
--   for actually sampling from that distribution).
-- 
--   For a /precise/ description of an arbitrarily-shaped connected subset of a manifold,
--   there is 'Region', whose implementation is vastly more complex.
data Shade x where
   Shade :: (Semimanifold x, SimpleSpace (Needle x))
           =>  { forall x. Shade x -> x
_shadeCtr :: !x
               , forall x. Shade x -> Metric' x
_shadeExpanse :: !(Metric' x) } -> Shade x
deriving instance (Show x, Show (Metric' x), WithField ℝ PseudoAffine x)
                => Show (Shade x)

-- | A &#x201c;co-shade&#x201d; can describe ellipsoid regions as well, but unlike
--   'Shade' it can be unlimited / infinitely wide in some directions.
--   It does OTOH need to have nonzero thickness, which 'Shade' needs not.
data Shade' x = Shade' { forall x. Shade' x -> x
_shade'Ctr :: !x
                       , forall x. Shade' x -> Metric x
_shade'Narrowness :: !(Metric x) }


class IsShade shade where
--  type (*) shade :: *->*
  -- | Access the center of a 'Shade' or a 'Shade''.
  shadeCtr :: Lens' (shade x) x
--  -- | Convert between 'Shade' and 'Shade' (which must be neither singular nor infinite).
--  unsafeDualShade :: WithField ℝ Manifold x => shade x -> shade* x
  -- | Check the statistical likelihood-density of a point being within a shade.
  --   This is taken as a normal distribution.
  occlusion :: ( PseudoAffine x, SimpleSpace (Needle x)
               , s ~ (Scalar (Needle x)), RealFloat' s )
                => shade x -> x -> s
  factoriseShade :: ( PseudoAffine x, SimpleSpace (Needle x)
                    , PseudoAffine y, SimpleSpace (Needle y)
                    , Scalar (Needle x) ~ Scalar (Needle y) )
                => shade (x,y) -> (shade x, shade y)
  coerceShade :: ( Manifold x, Manifold y, LocallyCoercible x y
                 , SimpleSpace (Needle y) ) => shade x -> shade y
  -- | ASCII version of '✠'.
  orthoShades :: ( PseudoAffine x, SimpleSpace (Needle x)
           , PseudoAffine y, SimpleSpace (Needle y)
           , Scalar (Needle x) ~ Scalar (Needle y) )
                => shade x -> shade y -> shade (x,y)
  linIsoTransformShade :: ( SimpleSpace x, SimpleSpace y, Scalar x ~ Scalar y
                          , Num' (Scalar x) )
                          => (x+>y) -> shade x -> shade y
  -- | Squash a shade down into a lower dimensional space.
  projectShade :: ( 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
  -- | Include a shade in a higher-dimensional space. Notice that this behaves
  --   fundamentally different for 'Shade' and 'Shade''. For 'Shade', it gives
  --   a “flat image” of the region, whereas for 'Shade'' it gives an “extrusion
  --   pillar” pointing in the projection's orthogonal complement.
  embedShade :: ( Semimanifold x, Semimanifold y
                , Object (Affine s) x, Object (Affine s) y
                , SemiInner (Needle x), SimpleSpace (Needle y) )
                        => Embedding (Affine s) x y
                              -> shade x -> shade y
  

linearProjectShade :: ∀ x y s
          . (Num' s, LinearSpace x, SimpleSpace y, Scalar x ~ s, Scalar y ~ s)
                  => (x+>y) -> Shade x -> Shade y
linearProjectShade :: forall x y s.
(Num' s, LinearSpace x, SimpleSpace y, Scalar x ~ s,
 Scalar y ~ s) =>
(x +> y) -> Shade x -> Shade y
linearProjectShade = case ( forall v. TensorSpace v => LinearManifoldWitness v
linearManifoldWitness :: LinearManifoldWitness x
                          , forall v. TensorSpace v => LinearManifoldWitness v
linearManifoldWitness :: LinearManifoldWitness y
                          , forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualSpaceWitness x
                          , forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualSpaceWitness y ) of
   ( LinearManifoldWitness x
LinearManifoldWitness
    ,LinearManifoldWitness y
LinearManifoldWitness
    ,DualSpaceWitness x
DualSpaceWitness, DualSpaceWitness y
DualSpaceWitness )
       -> \x +> y
f (Shade x
x Metric' x
ex) -> forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade (x +> y
f forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ x
x) (forall v w.
(LSpace v, LSpace w, Scalar v ~ Scalar w) =>
(v +> w) -> Variance v -> Variance w
transformVariance x +> y
f Metric' x
ex)


infixl 5 ✠
-- | Combine two shades on independent subspaces to a shade with the same
--   properties on the subspaces (see 'factoriseShade') and no covariance.
(✠) :: ( IsShade shade, PseudoAffine x, SimpleSpace (Needle x)
       , PseudoAffine y, SimpleSpace (Needle y)
       , Scalar (Needle x) ~ Scalar (Needle y) )
                => shade x -> shade y -> shade (x,y)
✠ :: forall (shade :: * -> *) x y.
(IsShade shade, PseudoAffine x, SimpleSpace (Needle x),
 PseudoAffine y, SimpleSpace (Needle y),
 Scalar (Needle x) ~ Scalar (Needle y)) =>
shade x -> shade y -> shade (x, y)
(✠) = forall (shade :: * -> *) x y.
(IsShade shade, PseudoAffine x, SimpleSpace (Needle x),
 PseudoAffine y, SimpleSpace (Needle y),
 Scalar (Needle x) ~ Scalar (Needle y)) =>
shade x -> shade y -> shade (x, y)
orthoShades

instance IsShade Shade where
  shadeCtr :: forall x. Lens' (Shade x) x
shadeCtr x -> f x
f (Shade x
c Metric' x
e) = 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 (forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
`Shade`Metric' x
e) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ x -> f x
f x
c
  occlusion :: forall x s.
(PseudoAffine x, SimpleSpace (Needle x), s ~ Scalar (Needle x),
 RealFloat' s) =>
Shade x -> x -> s
occlusion = forall x s.
(PseudoAffine x, SimpleSpace (Needle x), Scalar (Needle x) ~ s,
 RealFloat' s) =>
PseudoAffineWitness x -> DualNeedleWitness x -> Shade x -> x -> s
occ forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness
   where occ :: ∀ x s . ( PseudoAffine x, SimpleSpace (Needle x)
                        , Scalar (Needle x) ~ s, RealFloat' s )
                    => PseudoAffineWitness x -> DualNeedleWitness x -> Shade x -> x -> s
         occ :: forall x s.
(PseudoAffine x, SimpleSpace (Needle x), Scalar (Needle x) ~ s,
 RealFloat' s) =>
PseudoAffineWitness x -> DualNeedleWitness x -> Shade x -> x -> s
occ (PseudoAffineWitness SemimanifoldWitness x
SemimanifoldWitness) DualSpaceWitness (Needle x)
DualSpaceWitness (Shade x
p₀ Metric' x
δ)
                 = \x
p -> case x
pforall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
p₀ of
           (Just Needle x
vd) | Scalar (Needle x)
mSq <- forall v. LSpace v => Seminorm v -> v -> Scalar v
normSq Variance (DualVector (Needle x))
δinv Needle x
vd
                     , Scalar (Needle x)
mSq forall a. Eq a => a -> a -> Bool
== Scalar (Needle x)
mSq  -- avoid NaN
                     -> forall a. Floating a => a -> a
exp (forall a. Num a => a -> a
negate Scalar (Needle x)
mSq)
           Maybe (Needle x)
_         -> forall v. AdditiveGroup v => v
zeroV
          where δinv :: Variance (DualVector (Needle x))
δinv = forall v. SimpleSpace v => Norm v -> Variance v
dualNorm Metric' x
δ
  factoriseShade :: forall x y.
(PseudoAffine x, SimpleSpace (Needle x), PseudoAffine y,
 SimpleSpace (Needle y), Scalar (Needle x) ~ Scalar (Needle y)) =>
Shade (x, y) -> (Shade x, Shade y)
factoriseShade = forall x y.
(PseudoAffine x, SimpleSpace (Needle x), PseudoAffine y,
 SimpleSpace (Needle y), Scalar (Needle x) ~ Scalar (Needle y)) =>
DualNeedleWitness x
-> DualNeedleWitness y -> Shade (x, y) -> (Shade x, Shade y)
fs forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness
   where fs :: ∀ x y . ( PseudoAffine x, SimpleSpace (Needle x)
                       , PseudoAffine y, SimpleSpace (Needle y)
                       , Scalar (Needle x) ~ Scalar (Needle y) )
               => DualNeedleWitness x -> DualNeedleWitness y
                       -> Shade (x,y) -> (Shade x, Shade y)
         fs :: forall x y.
(PseudoAffine x, SimpleSpace (Needle x), PseudoAffine y,
 SimpleSpace (Needle y), Scalar (Needle x) ~ Scalar (Needle y)) =>
DualNeedleWitness x
-> DualNeedleWitness y -> Shade (x, y) -> (Shade x, Shade y)
fs DualSpaceWitness (Needle x)
DualSpaceWitness DualSpaceWitness (Needle y)
DualSpaceWitness (Shade (x
x₀,y
y₀) Metric' (x, y)
δxy)
                   = (forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade x
x₀ Norm (DualVector (Needle x))
δx, forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade y
y₀ Norm (DualVector (Needle y))
δy)
          where (Norm (DualVector (Needle x))
δx,Norm (DualVector (Needle y))
δy) = forall u v.
(SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v) =>
Norm (u, v) -> (Norm u, Norm v)
summandSpaceNorms Metric' (x, y)
δxy
  orthoShades :: forall x y.
(PseudoAffine x, SimpleSpace (Needle x), PseudoAffine y,
 SimpleSpace (Needle y), Scalar (Needle x) ~ Scalar (Needle y)) =>
Shade x -> Shade y -> Shade (x, y)
orthoShades = forall x y.
(PseudoAffine x, SimpleSpace (Needle x), PseudoAffine y,
 SimpleSpace (Needle y), Scalar (Needle x) ~ Scalar (Needle y)) =>
DualNeedleWitness x
-> DualNeedleWitness y -> Shade x -> Shade y -> Shade (x, y)
fs forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness
   where fs :: ∀ x y . ( PseudoAffine x, SimpleSpace (Needle x)
                       , PseudoAffine y, SimpleSpace (Needle y)
                       , Scalar (Needle x) ~ Scalar (Needle y) )
               => DualNeedleWitness x -> DualNeedleWitness y
                       -> Shade x -> Shade y ->  Shade (x,y)
         fs :: forall x y.
(PseudoAffine x, SimpleSpace (Needle x), PseudoAffine y,
 SimpleSpace (Needle y), Scalar (Needle x) ~ Scalar (Needle y)) =>
DualNeedleWitness x
-> DualNeedleWitness y -> Shade x -> Shade y -> Shade (x, y)
fs DualSpaceWitness (Needle x)
DualSpaceWitness DualSpaceWitness (Needle y)
DualSpaceWitness (Shade x
x Metric' x
δx) (Shade y
y Metric' y
δy)
             = forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade (x
x,y
y) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall u v.
(LSpace u, LSpace v, Scalar u ~ Scalar v) =>
Norm u -> Norm v -> Norm (u, v)
sumSubspaceNorms Metric' x
δx Metric' y
δy
  coerceShade :: forall x y.
(Manifold x, Manifold y, LocallyCoercible x y,
 SimpleSpace (Needle y)) =>
Shade x -> Shade y
coerceShade = forall x y.
(LocallyCoercible x y, SimpleSpace (Needle y)) =>
DualNeedleWitness x -> DualNeedleWitness y -> Shade x -> Shade y
cS forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness
   where cS :: ∀ x y . (LocallyCoercible x y, SimpleSpace (Needle y))
                => DualNeedleWitness x -> DualNeedleWitness y -> Shade x -> Shade y
         cS :: forall x y.
(LocallyCoercible x y, SimpleSpace (Needle y)) =>
DualNeedleWitness x -> DualNeedleWitness y -> Shade x -> Shade y
cS DualSpaceWitness (Needle x)
DualSpaceWitness DualSpaceWitness (Needle y)
DualSpaceWitness
                    = \(Shade x
x Metric' x
δxym)
                         -> forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade (forall x ξ. LocallyCoercible x ξ => x -> ξ
locallyTrivialDiffeomorphism x
x) (Metric' x -> Norm (DualVector (Needle y))
tN Metric' x
δxym)
          where tN :: Metric' x -> Norm (DualVector (Needle y))
tN = case forall x ξ. LocallyCoercible x ξ => CanonicalDiffeomorphism ξ x
oppositeLocalCoercion :: CanonicalDiffeomorphism y x of
                      CanonicalDiffeomorphism y x
CanonicalDiffeomorphism ->
                       forall v w.
(LSpace v, LSpace w, Scalar v ~ Scalar w) =>
(v +> w) -> Norm w -> Norm v
transformNorm 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
$ forall x ξ (p :: * -> *).
(LocallyCoercible x ξ, Functor p) =>
p (x, ξ) -> Needle' x -+> Needle' ξ
coerceNeedle' ([]::[(y,x)])
  linIsoTransformShade :: forall x y.
(SimpleSpace x, SimpleSpace y, Scalar x ~ Scalar y,
 Num' (Scalar x)) =>
(x +> y) -> Shade x -> Shade y
linIsoTransformShade = forall x y.
(LinearSpace x, SimpleSpace y, Scalar x ~ Scalar y,
 Num' (Scalar x)) =>
LinearManifoldWitness x
-> LinearManifoldWitness y
-> DualSpaceWitness x
-> DualSpaceWitness y
-> (x +> y)
-> Shade x
-> Shade y
lits forall v. TensorSpace v => LinearManifoldWitness v
linearManifoldWitness forall v. TensorSpace v => LinearManifoldWitness v
linearManifoldWitness
                              forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness
   where lits :: ∀ x y . ( LinearSpace x, SimpleSpace y
                         , Scalar x ~ Scalar y, Num' (Scalar x) )
               => LinearManifoldWitness x -> LinearManifoldWitness y
                   -> DualSpaceWitness x -> DualSpaceWitness y
                       -> (x+>y) -> Shade x -> Shade y
         lits :: forall x y.
(LinearSpace x, SimpleSpace y, Scalar x ~ Scalar y,
 Num' (Scalar x)) =>
LinearManifoldWitness x
-> LinearManifoldWitness y
-> DualSpaceWitness x
-> DualSpaceWitness y
-> (x +> y)
-> Shade x
-> Shade y
lits (LinearManifoldWitness x
LinearManifoldWitness)
              (LinearManifoldWitness y
LinearManifoldWitness)
              DualSpaceWitness x
DualSpaceWitness DualSpaceWitness y
DualSpaceWitness
              x +> y
f (Shade x
x Metric' x
δx)
                  = forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade (x +> y
f forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ x
x) (forall v w.
(LSpace v, LSpace w, Scalar v ~ Scalar w) =>
(v +> w) -> Norm w -> Norm v
transformNorm (forall v w.
(LinearSpace v, LinearSpace w, Scalar v ~ Scalar w) =>
(v +> DualVector w) -+> (w +> DualVector v)
adjoint forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ x +> y
f) Metric' x
δx)
  embedShade :: forall x y s.
(Semimanifold x, Semimanifold y, Object (Affine s) x,
 Object (Affine s) y, SemiInner (Needle x),
 SimpleSpace (Needle y)) =>
Embedding (Affine s) x y -> Shade x -> Shade y
embedShade = forall s x y.
(Semimanifold y, Object (Affine s) x, Object (Affine s) y,
 SemiInner (Needle x), SimpleSpace (Needle y)) =>
(SemimanifoldWitness x, SemimanifoldWitness y)
-> Embedding (Affine s) x y -> Shade x -> Shade y
ps' (forall x. Semimanifold x => SemimanifoldWitness x
semimanifoldWitness, forall x. Semimanifold x => SemimanifoldWitness x
semimanifoldWitness)
   where ps' :: ∀ s x y . ( Semimanifold y
                          , Object (Affine s) x, Object (Affine s) y
                          , SemiInner (Needle x), SimpleSpace (Needle y) )
                        => (SemimanifoldWitness x, SemimanifoldWitness y)
               -> Embedding (Affine s) x y
                              -> Shade x -> Shade y
         ps' :: forall s x y.
(Semimanifold y, Object (Affine s) x, Object (Affine s) y,
 SemiInner (Needle x), SimpleSpace (Needle y)) =>
(SemimanifoldWitness x, SemimanifoldWitness y)
-> Embedding (Affine s) x y -> Shade x -> Shade y
ps' (SemimanifoldWitness x
SemimanifoldWitness, SemimanifoldWitness y
SemimanifoldWitness)
              (Embedding Affine s x y
q Affine s y x
_) (Shade x
x Metric' x
e) = forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade y
y (forall v w.
(LSpace v, LSpace w, Scalar v ~ Scalar w) =>
(v +> w) -> Variance v -> Variance w
transformVariance LinearMap s (Needle x) (Needle y)
j Metric' x
e)
          where y :: y
y = Affine s x y
q forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ x
x
                (y
_,LinearMap s (Needle x) (Needle y)
j) = forall x y s.
(Manifold x, Atlas x, HasTrie (ChartIndex x), Manifold y,
 s ~ Scalar (Needle x), s ~ Scalar (Needle y)) =>
Affine s x y -> x -> (y, LinearMap s (Needle x) (Needle y))
evalAffine Affine s x y
q x
x
  projectShade :: forall x y s.
(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 s x y.
(Semimanifold x, Object (Affine s) x, Object (Affine s) y,
 SimpleSpace (Needle x), SemiInner (Needle y)) =>
(SemimanifoldWitness x, SemimanifoldWitness y)
-> Embedding (Affine s) x y -> Shade y -> Shade x
ps' (forall x. Semimanifold x => SemimanifoldWitness x
semimanifoldWitness, forall x. Semimanifold x => SemimanifoldWitness x
semimanifoldWitness)
   where ps' :: ∀ s x y . ( Semimanifold x
                          , Object (Affine s) x, Object (Affine s) y
                          , SimpleSpace (Needle x), SemiInner (Needle y) )
                        => (SemimanifoldWitness x, SemimanifoldWitness y)
               -> Embedding (Affine s) x y
                              -> Shade y -> Shade x
         ps' :: forall s x y.
(Semimanifold x, Object (Affine s) x, Object (Affine s) y,
 SimpleSpace (Needle x), SemiInner (Needle y)) =>
(SemimanifoldWitness x, SemimanifoldWitness y)
-> Embedding (Affine s) x y -> Shade y -> Shade x
ps' (SemimanifoldWitness x
SemimanifoldWitness, SemimanifoldWitness y
SemimanifoldWitness)
              (Embedding Affine s x y
_ Affine s y x
q) (Shade y
x Metric' y
e) = forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade x
y (forall v w.
(LSpace v, LSpace w, Scalar v ~ Scalar w) =>
(v +> w) -> Variance v -> Variance w
transformVariance LinearMap s (Needle y) (Needle x)
j Metric' y
e)
          where y :: x
y = Affine s y x
q forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ y
x
                (x
_,LinearMap s (Needle y) (Needle x)
j) = forall x y s.
(Manifold x, Atlas x, HasTrie (ChartIndex x), Manifold y,
 s ~ Scalar (Needle x), s ~ Scalar (Needle y)) =>
Affine s x y -> x -> (y, LinearMap s (Needle x) (Needle y))
evalAffine Affine s y x
q y
x


dualShade :: ∀ x . (PseudoAffine x, SimpleSpace (Needle x))
                => Shade x -> Shade' x
dualShade :: forall x.
(PseudoAffine x, SimpleSpace (Needle x)) =>
Shade x -> Shade' x
dualShade = case forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualSpaceWitness (Needle x) of
    DualSpaceWitness (Needle x)
DualSpaceWitness -> \(Shade x
c Metric' x
e) -> forall x. x -> Metric x -> Shade' x
Shade' x
c 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
e

dualShade' :: ∀ x . (PseudoAffine x, SimpleSpace (Needle x))
                => Shade' x -> Shade x
dualShade' :: forall x.
(PseudoAffine x, SimpleSpace (Needle x)) =>
Shade' x -> Shade x
dualShade' = case forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualSpaceWitness (Needle x) of
    DualSpaceWitness (Needle x)
DualSpaceWitness -> \(Shade' x
c Metric x
e) -> forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade x
c forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall v. SimpleSpace v => Variance v -> Norm v
dualNorm' Metric x
e

instance ImpliesMetric Shade where
  type MetricRequirement Shade x = (Manifold x, SimpleSpace (Needle x))
  inferMetric' :: forall x.
(MetricRequirement Shade x, LSpace (Needle x)) =>
Shade x -> Metric' x
inferMetric' (Shade x
_ Metric' x
e) = Metric' x
e
  inferMetric :: forall x.
(MetricRequirement Shade x, LSpace (Needle x)) =>
Shade x -> Metric x
inferMetric = forall x.
(Manifold x, SimpleSpace (Needle x)) =>
DualNeedleWitness x -> Shade x -> Metric x
im forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness
   where im :: (Manifold x, SimpleSpace (Needle x))
                   => DualNeedleWitness x -> Shade x -> Metric x
         im :: forall x.
(Manifold x, SimpleSpace (Needle x)) =>
DualNeedleWitness x -> Shade x -> Metric x
im DualSpaceWitness (Needle x)
DualSpaceWitness (Shade x
_ Metric' x
e) = forall v. SimpleSpace v => Norm v -> Variance v
dualNorm Metric' x
e

instance ImpliesMetric Shade' where
  type MetricRequirement Shade' x = (Manifold x, SimpleSpace (Needle x))
  inferMetric :: forall x.
(MetricRequirement Shade' x, LSpace (Needle x)) =>
Shade' x -> Metric x
inferMetric (Shade' x
_ Metric x
e) = Metric x
e
  inferMetric' :: forall x.
(MetricRequirement Shade' x, LSpace (Needle x)) =>
Shade' x -> Metric' x
inferMetric' (Shade' x
_ Metric x
e) = forall v. SimpleSpace v => Norm v -> Variance v
dualNorm Metric x
e

shadeExpanse :: Lens' (Shade x) (Metric' x)
shadeExpanse :: forall x. Lens' (Shade x) (Metric' x)
shadeExpanse Metric' x -> f (Metric' x)
f (Shade x
c Metric' x
e) = 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 (forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade x
c) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Metric' x -> f (Metric' x)
f Metric' x
e

instance IsShade Shade' where
  shadeCtr :: forall x. Lens' (Shade' x) x
shadeCtr x -> f x
f (Shade' x
c Metric x
e) = 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 (forall x. x -> Metric x -> Shade' x
`Shade'`Metric x
e) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ x -> f x
f x
c
  occlusion :: forall x s.
(PseudoAffine x, SimpleSpace (Needle x), s ~ Scalar (Needle x),
 RealFloat' s) =>
Shade' x -> x -> s
occlusion = forall x s.
(PseudoAffine x, SimpleSpace (Needle x), Scalar (Needle x) ~ s,
 RealFloat' s) =>
PseudoAffineWitness x -> Shade' x -> x -> s
occ forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness
   where occ :: ∀ x s . ( PseudoAffine x, SimpleSpace (Needle x)
                        , Scalar (Needle x) ~ s, RealFloat' s )
                    => PseudoAffineWitness x -> Shade' x -> x -> s
         occ :: forall x s.
(PseudoAffine x, SimpleSpace (Needle x), Scalar (Needle x) ~ s,
 RealFloat' s) =>
PseudoAffineWitness x -> Shade' x -> x -> s
occ (PseudoAffineWitness (SemimanifoldWitness x
SemimanifoldWitness)) (Shade' x
p₀ Metric x
δinv) x
p
               = case x
pforall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
p₀ of
           (Just Needle x
vd) | Scalar (Needle x)
mSq <- forall v. LSpace v => Seminorm v -> v -> Scalar v
normSq Metric x
δinv Needle x
vd
                     , Scalar (Needle x)
mSq forall a. Eq a => a -> a -> Bool
== Scalar (Needle x)
mSq  -- avoid NaN
                     -> forall a. Floating a => a -> a
exp (forall a. Num a => a -> a
negate Scalar (Needle x)
mSq)
           Maybe (Needle x)
_         -> forall v. AdditiveGroup v => v
zeroV
  factoriseShade :: forall x y.
(PseudoAffine x, SimpleSpace (Needle x), PseudoAffine y,
 SimpleSpace (Needle y), Scalar (Needle x) ~ Scalar (Needle y)) =>
Shade' (x, y) -> (Shade' x, Shade' y)
factoriseShade (Shade' (x
x₀,y
y₀) Metric (x, y)
δxy) = (forall x. x -> Metric x -> Shade' x
Shade' x
x₀ Norm (Needle x)
δx, forall x. x -> Metric x -> Shade' x
Shade' y
y₀ Norm (Needle y)
δy)
   where (Norm (Needle x)
δx,Norm (Needle y)
δy) = forall u v.
(SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v) =>
Norm (u, v) -> (Norm u, Norm v)
summandSpaceNorms Metric (x, y)
δxy
  orthoShades :: forall x y.
(PseudoAffine x, SimpleSpace (Needle x), PseudoAffine y,
 SimpleSpace (Needle y), Scalar (Needle x) ~ Scalar (Needle y)) =>
Shade' x -> Shade' y -> Shade' (x, y)
orthoShades (Shade' x
x Metric x
δx) (Shade' y
y Metric y
δy) = forall x. x -> Metric x -> Shade' x
Shade' (x
x,y
y) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall u v.
(LSpace u, LSpace v, Scalar u ~ Scalar v) =>
Norm u -> Norm v -> Norm (u, v)
sumSubspaceNorms Metric x
δx Metric y
δy
  coerceShade :: forall x y.
(Manifold x, Manifold y, LocallyCoercible x y,
 SimpleSpace (Needle y)) =>
Shade' x -> Shade' y
coerceShade = forall x y. LocallyCoercible x y => Shade' x -> Shade' y
cS
   where cS :: ∀ x y . (LocallyCoercible x y) => Shade' x -> Shade' y
         cS :: forall x y. LocallyCoercible x y => Shade' x -> Shade' y
cS = \(Shade' x
x Metric x
δxym) -> forall x. x -> Metric x -> Shade' x
Shade' (forall x ξ. LocallyCoercible x ξ => x -> ξ
locallyTrivialDiffeomorphism x
x) (Metric x -> Norm (Needle y)
tN Metric x
δxym)
          where tN :: Metric x -> Norm (Needle y)
tN = case forall x ξ. LocallyCoercible x ξ => CanonicalDiffeomorphism ξ x
oppositeLocalCoercion :: CanonicalDiffeomorphism y x of
                      CanonicalDiffeomorphism y x
CanonicalDiffeomorphism ->
                       forall v w.
(LSpace v, LSpace w, Scalar v ~ Scalar w) =>
(v +> w) -> Norm w -> Norm v
transformNorm 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
$ forall x ξ (p :: * -> *).
(LocallyCoercible x ξ, Functor p) =>
p (x, ξ) -> Needle x -+> Needle ξ
coerceNeedle ([]::[(y,x)])
  linIsoTransformShade :: forall x y.
(SimpleSpace x, SimpleSpace y, Scalar x ~ Scalar y,
 Num' (Scalar x)) =>
(x +> y) -> Shade' x -> Shade' y
linIsoTransformShade = forall x y.
(SimpleSpace x, SimpleSpace y, Scalar x ~ Scalar y,
 RealFloat' (Scalar x)) =>
LinearManifoldWitness x
-> LinearManifoldWitness y
-> DualSpaceWitness x
-> DualSpaceWitness y
-> (x +> y)
-> Shade' x
-> Shade' y
lits forall v. TensorSpace v => LinearManifoldWitness v
linearManifoldWitness forall v. TensorSpace v => LinearManifoldWitness v
linearManifoldWitness
                              forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness
   where lits :: ∀ x y . ( SimpleSpace x, SimpleSpace y
                         , Scalar x ~ Scalar y, RealFloat' (Scalar x) )
               => LinearManifoldWitness x -> LinearManifoldWitness y
                   -> DualSpaceWitness x -> DualSpaceWitness y
                       -> (x+>y) -> Shade' x -> Shade' y
         lits :: forall x y.
(SimpleSpace x, SimpleSpace y, Scalar x ~ Scalar y,
 RealFloat' (Scalar x)) =>
LinearManifoldWitness x
-> LinearManifoldWitness y
-> DualSpaceWitness x
-> DualSpaceWitness y
-> (x +> y)
-> Shade' x
-> Shade' y
lits (LinearManifoldWitness x
LinearManifoldWitness)
              (LinearManifoldWitness y
LinearManifoldWitness)
              DualSpaceWitness x
DualSpaceWitness DualSpaceWitness y
DualSpaceWitness
               x +> y
f (Shade' x
x Metric x
δx)
          = forall x. x -> Metric x -> Shade' x
Shade' (x +> y
f forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ x
x) (forall v w.
(LSpace v, LSpace w, Scalar v ~ Scalar w) =>
(v +> w) -> Norm w -> Norm v
transformNorm (forall u v.
(SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v) =>
(u +> v) -> v +> u
pseudoInverse x +> y
f) Metric x
δx)
  embedShade :: forall x y s.
(Semimanifold x, Semimanifold y, Object (Affine s) x,
 Object (Affine s) y, SemiInner (Needle x),
 SimpleSpace (Needle y)) =>
Embedding (Affine s) x y -> Shade' x -> Shade' y
embedShade = forall s x y.
(Object (Affine s) x, Object (Affine s) y, SemiInner (Needle x),
 SemiInner (Needle y)) =>
(SemimanifoldWitness x, SemimanifoldWitness y)
-> Embedding (Affine s) x y -> Shade' x -> Shade' y
ps (forall x. Semimanifold x => SemimanifoldWitness x
semimanifoldWitness, forall x. Semimanifold x => SemimanifoldWitness x
semimanifoldWitness)
   where ps :: ∀ s x y . ( Object (Affine s) x, Object (Affine s) y
                         , SemiInner (Needle x), SemiInner (Needle y) )
                        => (SemimanifoldWitness x, SemimanifoldWitness y)
               -> Embedding (Affine s) x y
                              -> Shade' x -> Shade' y
         ps :: forall s x y.
(Object (Affine s) x, Object (Affine s) y, SemiInner (Needle x),
 SemiInner (Needle y)) =>
(SemimanifoldWitness x, SemimanifoldWitness y)
-> Embedding (Affine s) x y -> Shade' x -> Shade' y
ps (SemimanifoldWitness x
SemimanifoldWitness, SemimanifoldWitness y
SemimanifoldWitness)
             (Embedding Affine s x y
q Affine s y x
p) (Shade' x
x Metric x
e) = forall x. x -> Metric x -> Shade' x
Shade' y
y (forall v w.
(LSpace v, LSpace w, Scalar v ~ Scalar w) =>
(v +> w) -> Norm w -> Norm v
transformNorm LinearMap s (Needle y) (Needle x)
j Metric x
e)
          where y :: y
y = Affine s x y
q forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ x
x
                (x
_,LinearMap s (Needle y) (Needle x)
j) = forall x y s.
(Manifold x, Atlas x, HasTrie (ChartIndex x), Manifold y,
 s ~ Scalar (Needle x), s ~ Scalar (Needle y)) =>
Affine s x y -> x -> (y, LinearMap s (Needle x) (Needle y))
evalAffine Affine s y x
p y
y
  projectShade :: forall x y s.
(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 s x y.
(Object (Affine s) x, Object (Affine s) y, SemiInner (Needle x),
 SemiInner (Needle y)) =>
(SemimanifoldWitness x, SemimanifoldWitness y)
-> Embedding (Affine s) x y -> Shade' y -> Shade' x
ps (forall x. Semimanifold x => SemimanifoldWitness x
semimanifoldWitness, forall x. Semimanifold x => SemimanifoldWitness x
semimanifoldWitness)
   where ps :: ∀ s x y . ( Object (Affine s) x, Object (Affine s) y
                         , SemiInner (Needle x), SemiInner (Needle y) )
                        => (SemimanifoldWitness x, SemimanifoldWitness y)
               -> Embedding (Affine s) x y
                              -> Shade' y -> Shade' x
         ps :: forall s x y.
(Object (Affine s) x, Object (Affine s) y, SemiInner (Needle x),
 SemiInner (Needle y)) =>
(SemimanifoldWitness x, SemimanifoldWitness y)
-> Embedding (Affine s) x y -> Shade' y -> Shade' x
ps (SemimanifoldWitness x
SemimanifoldWitness, SemimanifoldWitness y
SemimanifoldWitness)
             (Embedding Affine s x y
p Affine s y x
q) (Shade' y
x Metric y
e) = forall x. x -> Metric x -> Shade' x
Shade' x
y (forall v w.
(LSpace v, LSpace w, Scalar v ~ Scalar w) =>
(v +> w) -> Norm w -> Norm v
transformNorm LinearMap s (Needle x) (Needle y)
j Metric y
e)
          where y :: x
y = Affine s y x
q forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ y
x
                (y
_,LinearMap s (Needle x) (Needle y)
j) = forall x y s.
(Manifold x, Atlas x, HasTrie (ChartIndex x), Manifold y,
 s ~ Scalar (Needle x), s ~ Scalar (Needle y)) =>
Affine s x y -> x -> (y, LinearMap s (Needle x) (Needle y))
evalAffine Affine s x y
p x
y


shadeNarrowness :: Lens' (Shade' x) (Metric x)
shadeNarrowness :: forall x. Lens' (Shade' x) (Metric x)
shadeNarrowness Norm (Needle x) -> f (Norm (Needle x))
f (Shade' x
c Norm (Needle x)
e) = 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 (forall x. x -> Metric x -> Shade' x
Shade' x
c) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Norm (Needle x) -> f (Norm (Needle x))
f Norm (Needle x)
e

newtype ShadeNeedle x = ShadeNeedle { forall x. ShadeNeedle x -> Needle x
shadeCtrDiff :: Needle x
                                       -- TODO add shade-spread information
                                   }
deriving instance (AdditiveGroup (Needle x)) => AdditiveGroup (ShadeNeedle x)
deriving instance (VectorSpace (Needle x)) => VectorSpace (ShadeNeedle x)

instance (VectorSpace (Needle x)) => Semimanifold (ShadeNeedle x) where
  type Needle (ShadeNeedle x) = ShadeNeedle x
  .+~^ :: ShadeNeedle x -> Needle (ShadeNeedle x) -> ShadeNeedle x
(.+~^) = forall v. AdditiveGroup v => v -> v -> v
(^+^)

instance ∀ x . (PseudoAffine x, VectorSpace (Needle x)) => Semimanifold (Shade x) where
  type Needle (Shade x) = ShadeNeedle x
  .+~^ :: Shade x -> Needle (Shade x) -> Shade x
(.+~^) = case forall x. Semimanifold x => SemimanifoldWitness x
semimanifoldWitness :: SemimanifoldWitness x of
             SemimanifoldWitness x
SemimanifoldWitness
                   -> \(Shade x
c Metric' x
e) (ShadeNeedle Needle x
v) -> forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade (x
cforall x. Semimanifold x => x -> Needle x -> x
.+~^Needle x
v) Metric' x
e
  .-~^ :: Shade x -> Needle (Shade x) -> Shade x
(.-~^) = case forall x. Semimanifold x => SemimanifoldWitness x
semimanifoldWitness :: SemimanifoldWitness x of
             SemimanifoldWitness x
SemimanifoldWitness
                   -> \(Shade x
c Metric' x
e) (ShadeNeedle Needle x
v) -> forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade (x
cforall x. Semimanifold x => x -> Needle x -> x
.-~^Needle x
v) Metric' x
e
  semimanifoldWitness :: SemimanifoldWitness (Shade x)
semimanifoldWitness = case forall x. Semimanifold x => SemimanifoldWitness x
semimanifoldWitness :: SemimanifoldWitness x of
                         (SemimanifoldWitness x
SemimanifoldWitness)
                          -> forall x.
(Semimanifold (Needle x), Needle (Needle x) ~ Needle x) =>
SemimanifoldWitness x
SemimanifoldWitness

data ShadeHalfNeedle x = ShadeHalfNeedle -- TODO add shade-spread information

instance AdditiveMonoid (ShadeHalfNeedle x) where
  zeroHV :: ShadeHalfNeedle x
zeroHV = forall a. HasCallStack => a
undefined
  addHVs :: ShadeHalfNeedle x -> ShadeHalfNeedle x -> ShadeHalfNeedle x
addHVs = forall a. HasCallStack => a
undefined

instance ( VectorSpace (Needle x)
         ) => HalfSpace (ShadeHalfNeedle x) where
  type FullSubspace (ShadeHalfNeedle x) = Needle x
  type Ray (ShadeHalfNeedle x) = Ray x
  type MirrorJoin (ShadeHalfNeedle x) = Needle x
  scaleNonNeg :: Ray (ShadeHalfNeedle x) -> ShadeHalfNeedle x -> ShadeHalfNeedle x
scaleNonNeg = forall a. HasCallStack => a
undefined
  fromFullSubspace :: FullSubspace (ShadeHalfNeedle x) -> ShadeHalfNeedle x
fromFullSubspace = forall a. HasCallStack => a
undefined
  projectToFullSubspace :: ShadeHalfNeedle x -> FullSubspace (ShadeHalfNeedle x)
projectToFullSubspace = forall a. HasCallStack => a
undefined
  fullSubspaceIsVectorSpace :: forall r.
((VectorSpace (FullSubspace (ShadeHalfNeedle x)),
  ScalarSpace (Scalar (FullSubspace (ShadeHalfNeedle x))),
  Scalar (FullSubspace (ShadeHalfNeedle x))
  ~ MirrorJoin (Ray (ShadeHalfNeedle x))) =>
 r)
-> r
fullSubspaceIsVectorSpace (VectorSpace (FullSubspace (ShadeHalfNeedle x)),
 ScalarSpace (Scalar (FullSubspace (ShadeHalfNeedle x))),
 Scalar (FullSubspace (ShadeHalfNeedle x))
 ~ MirrorJoin (Ray (ShadeHalfNeedle x))) =>
r
_ = forall a. HasCallStack => a
undefined
  rayIsHalfSpace :: forall r. (HalfSpace (Ray (ShadeHalfNeedle x)) => r) -> r
rayIsHalfSpace HalfSpace (Ray (ShadeHalfNeedle x)) => r
_ = forall a. HasCallStack => a
undefined
  mirrorJoinIsVectorSpace :: forall r.
((VectorSpace (MirrorJoin (ShadeHalfNeedle x)),
  Scalar (MirrorJoin (ShadeHalfNeedle x))
  ~ MirrorJoin (Ray (ShadeHalfNeedle x))) =>
 r)
-> r
mirrorJoinIsVectorSpace (VectorSpace (MirrorJoin (ShadeHalfNeedle x)),
 Scalar (MirrorJoin (ShadeHalfNeedle x))
 ~ MirrorJoin (Ray (ShadeHalfNeedle x))) =>
r
_ = forall a. HasCallStack => a
undefined
  fromPositiveHalf :: ShadeHalfNeedle x -> MirrorJoin (ShadeHalfNeedle x)
fromPositiveHalf = forall a. HasCallStack => a
undefined
  fromNegativeHalf :: ShadeHalfNeedle x -> MirrorJoin (ShadeHalfNeedle x)
fromNegativeHalf = forall a. HasCallStack => a
undefined

instance ( AffineSpace x, Manifold x, Diff x ~ Needle x
         , Atlas x, HasTrie (ChartIndex x)   -- ??
         , LinearSpace (Needle x), LinearSpace (Needle' x)
         , Num' (Scalar (Needle x))
         ) => SemimanifoldWithBoundary (Shade x) where
  type Interior (Shade x) = Shade' x
  type Boundary (Shade x) = x
  type HalfNeedle (Shade x) = ShadeHalfNeedle x
  extendToBoundary :: Interior (Shade x)
-> Needle (Interior (Shade x)) -> Maybe (Boundary (Shade x))
extendToBoundary = forall a. HasCallStack => a
undefined
  smfdWBoundWitness :: SmfdWBoundWitness (Shade x)
smfdWBoundWitness = forall a. HasCallStack => a
undefined
  needleIsOpenMfd :: forall r. (OpenManifold (Needle (Interior (Shade x))) => r) -> r
needleIsOpenMfd OpenManifold (Needle (Interior (Shade x))) => r
_ = forall a. HasCallStack => a
undefined
  scalarIsOpenMfd :: forall r.
(OpenManifold (Scalar (Needle (Interior (Shade x)))) => r) -> r
scalarIsOpenMfd OpenManifold (Scalar (Needle (Interior (Shade x)))) => r
_ = forall a. HasCallStack => a
undefined

instance ( AffineSpace x, Manifold x, Diff x ~ Needle x
         , Atlas x, HasTrie (ChartIndex x)   -- ??
         , Geodesic x
         , LinearSpace (Needle x), LinearSpace (Needle' x)
         , Scalar (Needle x) ~ ℝ
         ) => Geodesic (Shade x) where
  geodesicBetween :: Shade x -> Shade x -> Maybe (D¹ -> Shade x)
geodesicBetween = DualNeedleWitness x -> Shade x -> Shade x -> Maybe (D¹ -> Shade x)
gb forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness
   where gb :: DualNeedleWitness x -> Shade x -> Shade x -> Maybe (D¹ -> Shade x)
         gb :: DualNeedleWitness x -> Shade x -> Shade x -> Maybe (D¹ -> Shade x)
gb DualNeedleWitness x
DualSpaceWitness (Shade x
c (Norm Needle' x -+> DualVector (Needle' x)
e)) (Shade x
ζ (Norm Needle' x -+> DualVector (Needle' x)
η)) = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a.
(Applicative f r t, Object r a, Object t (f a)) =>
t a (f a)
pure D¹ -> Shade x
interp
          where interp :: D¹ -> Shade x
interp t :: D¹
t@(D¹ ℝ
q) = forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade (D¹ -> x
pinterp D¹
t)
                                 (forall v. (v -+> DualVector v) -> Norm v
Norm 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 κ (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. VectorSpace v => v -> v -> Scalar v -> v
lerp LinearMap ℝ (Needle' x) (Needle x)
ed LinearMap ℝ (Needle' x) (Needle x)
ηd forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (ℝ
qforall a. Num a => a -> a -> a
+ℝ
1)forall a. Fractional a => a -> a -> a
/ℝ
2)
                ed :: LinearMap ℝ (Needle' x) (Needle x)
ed@(LinearMap TensorProduct (DualVector (Needle' x)) (Needle 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 Needle' x -+> DualVector (Needle' x)
e
                ηd :: LinearMap ℝ (Needle' x) (Needle x)
ηd@(LinearMap TensorProduct (DualVector (Needle' x)) (Needle 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 Needle' x -+> DualVector (Needle' x)
η
                Just D¹ -> x
pinterp = forall x. Geodesic x => x -> x -> Maybe (D¹ -> x)
geodesicBetween x
c x
ζ

newtype Shade'Needle x = Shade'Needle { forall x. Shade'Needle x -> Needle x
shade'CtrDiff :: Needle x
                                       -- TODO add shade-spread information
                                   }
deriving instance (AdditiveGroup (Needle x)) => AdditiveGroup (Shade'Needle x)
deriving instance (VectorSpace (Needle x)) => VectorSpace (Shade'Needle x)

instance (VectorSpace (Needle x)) => Semimanifold (Shade'Needle x) where
  type Needle (Shade'Needle x) = Shade'Needle x
  .+~^ :: Shade'Needle x -> Needle (Shade'Needle x) -> Shade'Needle x
(.+~^) = forall v. AdditiveGroup v => v -> v -> v
(^+^)


instance (AffineManifold x) => Semimanifold (Shade' x) where
  type Needle (Shade' x) = Shade'Needle x
  Shade' x
c Metric x
e .+~^ :: Shade' x -> Needle (Shade' x) -> Shade' x
.+~^ Shade'Needle Needle x
v = forall x. x -> Metric x -> Shade' x
Shade' (x
cforall x. Semimanifold x => x -> Needle x -> x
.+~^Needle x
v) Metric x
e
  Shade' x
c Metric x
e .-~^ :: Shade' x -> Needle (Shade' x) -> Shade' x
.-~^ Shade'Needle Needle x
v = forall x. x -> Metric x -> Shade' x
Shade' (x
cforall x. Semimanifold x => x -> Needle x -> x
.-~^Needle x
v) Metric x
e
  semimanifoldWitness :: SemimanifoldWitness (Shade' x)
semimanifoldWitness = case forall x. Semimanifold x => SemimanifoldWitness x
semimanifoldWitness :: SemimanifoldWitness x of
     SemimanifoldWitness x
SemimanifoldWitness -> forall x.
(Semimanifold (Needle x), Needle (Needle x) ~ Needle x) =>
SemimanifoldWitness x
SemimanifoldWitness

data Shade'HalfNeedle x = Shade'HalfNeedle -- TODO add shade-spread information

instance AdditiveMonoid (Shade'HalfNeedle x) where
  zeroHV :: Shade'HalfNeedle x
zeroHV = forall a. HasCallStack => a
undefined
  addHVs :: Shade'HalfNeedle x -> Shade'HalfNeedle x -> Shade'HalfNeedle x
addHVs = forall a. HasCallStack => a
undefined

instance ( VectorSpace (Needle x)
         ) => HalfSpace (Shade'HalfNeedle x) where
  type FullSubspace (Shade'HalfNeedle x) = Needle x
  type Ray (Shade'HalfNeedle x) = Ray x
  type MirrorJoin (Shade'HalfNeedle x) = Needle x
  scaleNonNeg :: Ray (Shade'HalfNeedle x)
-> Shade'HalfNeedle x -> Shade'HalfNeedle x
scaleNonNeg = forall a. HasCallStack => a
undefined
  fromFullSubspace :: FullSubspace (Shade'HalfNeedle x) -> Shade'HalfNeedle x
fromFullSubspace = forall a. HasCallStack => a
undefined
  projectToFullSubspace :: Shade'HalfNeedle x -> FullSubspace (Shade'HalfNeedle x)
projectToFullSubspace = forall a. HasCallStack => a
undefined
  fullSubspaceIsVectorSpace :: forall r.
((VectorSpace (FullSubspace (Shade'HalfNeedle x)),
  ScalarSpace (Scalar (FullSubspace (Shade'HalfNeedle x))),
  Scalar (FullSubspace (Shade'HalfNeedle x))
  ~ MirrorJoin (Ray (Shade'HalfNeedle x))) =>
 r)
-> r
fullSubspaceIsVectorSpace (VectorSpace (FullSubspace (Shade'HalfNeedle x)),
 ScalarSpace (Scalar (FullSubspace (Shade'HalfNeedle x))),
 Scalar (FullSubspace (Shade'HalfNeedle x))
 ~ MirrorJoin (Ray (Shade'HalfNeedle x))) =>
r
_ = forall a. HasCallStack => a
undefined
  rayIsHalfSpace :: forall r. (HalfSpace (Ray (Shade'HalfNeedle x)) => r) -> r
rayIsHalfSpace HalfSpace (Ray (Shade'HalfNeedle x)) => r
_ = forall a. HasCallStack => a
undefined
  mirrorJoinIsVectorSpace :: forall r.
((VectorSpace (MirrorJoin (Shade'HalfNeedle x)),
  Scalar (MirrorJoin (Shade'HalfNeedle x))
  ~ MirrorJoin (Ray (Shade'HalfNeedle x))) =>
 r)
-> r
mirrorJoinIsVectorSpace (VectorSpace (MirrorJoin (Shade'HalfNeedle x)),
 Scalar (MirrorJoin (Shade'HalfNeedle x))
 ~ MirrorJoin (Ray (Shade'HalfNeedle x))) =>
r
_ = forall a. HasCallStack => a
undefined
  fromPositiveHalf :: Shade'HalfNeedle x -> MirrorJoin (Shade'HalfNeedle x)
fromPositiveHalf = forall a. HasCallStack => a
undefined
  fromNegativeHalf :: Shade'HalfNeedle x -> MirrorJoin (Shade'HalfNeedle x)
fromNegativeHalf = forall a. HasCallStack => a
undefined

instance ( AffineSpace x, Manifold x, Diff x ~ Needle x
         , Atlas' x
         , LinearSpace (Needle x), LinearSpace (Needle' x)
         ) => SemimanifoldWithBoundary (Shade' x) where
  type Interior (Shade' x) = Shade x
  type Boundary (Shade' x) = x
  type HalfNeedle (Shade' x) = Shade'HalfNeedle x
  extendToBoundary :: Interior (Shade' x)
-> Needle (Interior (Shade' x)) -> Maybe (Boundary (Shade' x))
extendToBoundary = forall a. HasCallStack => a
undefined
  smfdWBoundWitness :: SmfdWBoundWitness (Shade' x)
smfdWBoundWitness = forall a. HasCallStack => a
undefined
  needleIsOpenMfd :: forall r. (OpenManifold (Needle (Interior (Shade' x))) => r) -> r
needleIsOpenMfd OpenManifold (Needle (Interior (Shade' x))) => r
_ = forall a. HasCallStack => a
undefined
  scalarIsOpenMfd :: forall r.
(OpenManifold (Scalar (Needle (Interior (Shade' x)))) => r) -> r
scalarIsOpenMfd OpenManifold (Scalar (Needle (Interior (Shade' x)))) => r
_ = forall a. HasCallStack => a
undefined

instance ∀ x . (WithField ℝ AffineManifold x, Geodesic x, SimpleSpace (Needle x))
            => Geodesic (Shade' x) where
  geodesicBetween :: Shade' x -> Shade' x -> Maybe (D¹ -> Shade' x)
geodesicBetween (Shade' x
c Metric x
e) (Shade' x
ζ Metric x
η) = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a.
(Applicative f r t, Object r a, Object t (f a)) =>
t a (f a)
pure D¹ -> Shade' x
interp
   where sharedSpan :: [(DualVector (Diff x), Scalar (Diff x))]
sharedSpan = forall v.
SimpleSpace v =>
Norm v -> Norm v -> [(DualVector v, Scalar v)]
sharedNormSpanningSystem Metric x
e Metric x
η
         interp :: D¹ -> Shade' x
interp D¹
t = forall x. x -> Metric x -> Shade' x
Shade' (D¹ -> x
pinterp D¹
t)
                           (forall v. LSpace v => [DualVector v] -> Seminorm v
spanNorm [ DualVector (Diff x)
v forall v s.
(VectorSpace v, s ~ Scalar v, Fractional s) =>
v -> s -> v
^/ (forall x.
(AffineSpace x, VectorSpace (Diff x), Scalar (Diff x) ~ ℝ) =>
x -> x -> D¹ -> x
alerpB ℝ
1 (forall a. Fractional a => a -> a
recip ℝ
qη) D¹
t)
                                     | (DualVector (Diff x)
v,ℝ
qη) <- [(DualVector (Diff x), Scalar (Diff x))]
sharedSpan ])
         Just D¹ -> x
pinterp = forall x. Geodesic x => x -> x -> Maybe (D¹ -> x)
geodesicBetween x
c x
ζ

fullShade :: (Semimanifold x, SimpleSpace (Needle x))
                      => x -> Metric' x -> Shade x
fullShade :: forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
fullShade x
ctr Metric' x
expa = forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade x
ctr Metric' x
expa

fullShade' :: WithField ℝ SimpleSpace x => x -> Metric x -> Shade' x
fullShade' :: forall x. WithField ℝ SimpleSpace x => x -> Metric x -> Shade' x
fullShade' x
ctr Metric x
expa = forall x. x -> Metric x -> Shade' x
Shade' x
ctr Metric x
expa


infixl 6 :±, |±|

-- | Span a 'Shade' from a center point and multiple deviation-vectors.
#if GLASGOW_HASKELL < 800
pattern (:±) :: ()
#else
pattern (:±) :: (Semimanifold x, SimpleSpace (Needle x))
#endif
             => (Semimanifold x, SimpleSpace (Needle x))
                         => x -> [Needle x] -> Shade x
pattern x $b:± :: forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> [Needle x] -> Shade x
$m:± :: forall {r} {x}.
Shade x
-> ((Semimanifold x, SimpleSpace (Needle x)) =>
    x -> [Needle x] -> r)
-> ((# #) -> r)
-> r
:± shs <- (Shade x (varianceSpanningSystem -> shs))
 where x
x :± [Needle x]
shs = forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
fullShade x
x 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 [Needle x]
shs

-- | Similar to ':±', but instead of expanding the shade, each vector /restricts/ it.
--   Iff these form a orthogonal basis (in whatever sense applicable), then both
--   methods will be equivalent.
-- 
--   Note that '|±|' is only possible, as such, in an inner-product space; in
--   general you need reciprocal vectors ('Needle'') to define a 'Shade''.
(|±|) :: ∀ x . WithField ℝ EuclidSpace x => x -> [Needle x] -> Shade' x
x
x|±| :: forall x. WithField ℝ EuclidSpace x => x -> [Needle x] -> Shade' x
|±|[Needle x]
shs = forall x. x -> Metric x -> Shade' x
Shade' x
x forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall v. LSpace v => [DualVector v] -> Seminorm v
spanNorm [Diff x
vforall v s.
(VectorSpace v, s ~ Scalar v, Fractional s) =>
v -> s -> v
^/(Diff x
vforall v. InnerSpace v => v -> v -> Scalar v
<.>Diff x
v) | Diff x
v<-[Needle x]
shs]



                 


-- | Attempt to find a 'Shade' that describes the distribution of given points.
--   At least in an affine space (and thus locally in any manifold), this can be used to
--   estimate the parameters of a normal distribution from which some points were
--   sampled. Note that some points will be &#x201c;outside&#x201d; of the shade,
--   as happens for a normal distribution with some statistical likelyhood.
--   (Use 'pointsCovers' if you need to prevent that.)
-- 
--   For /nonconnected/ manifolds it will be necessary to yield separate shades
--   for each connected component. And for an empty input list, there is no shade!
--   Hence the result type is a list.
pointsShades :: (WithField ℝ PseudoAffine x, SimpleSpace (Needle x))
                                 => [x] -> [Shade x]
pointsShades :: forall x.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
[x] -> [Shade x]
pointsShades = forall a b. (a -> b) -> [a] -> [b]
map forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd 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 x y.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
Metric' x -> [(x, y)] -> [([(x, y)], Shade x)]
pointsShades' forall a. Monoid a => a
mempty 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. (a -> b) -> [a] -> [b]
map ((,()))

coverAllAround :: ∀ x s . ( Fractional' s, WithField s PseudoAffine x
                          , SimpleSpace (Needle x) )
                  => x -> [Needle x] -> Shade x
coverAllAround :: forall x s.
(Fractional' s, WithField s PseudoAffine x,
 SimpleSpace (Needle x)) =>
x -> [Needle x] -> Shade x
coverAllAround x
x₀ [Needle x]
offs = forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade x
x₀
         forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ DualNeedleWitness x
-> [Needle x]
-> Norm (DualVector (Needle x))
-> Norm (DualVector (Needle x))
guaranteeIn forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness [Needle x]
offs
               (forall v. LSpace v => Scalar v -> Norm v -> Norm v
scaleNorm (s
1forall a. Fractional a => a -> a -> a
/forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Needle x]
offs)) 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 [Needle x]
offs)
 where guaranteeIn :: DualNeedleWitness x -> [Needle x] -> Metric' x -> Metric' x
       guaranteeIn :: DualNeedleWitness x
-> [Needle x]
-> Norm (DualVector (Needle x))
-> Norm (DualVector (Needle x))
guaranteeIn w :: DualNeedleWitness x
w@DualNeedleWitness x
DualSpaceWitness [Needle x]
offs Norm (DualVector (Needle x))
ex
          = case [Needle x]
offs forall (f :: * -> * -> *) (m :: * -> *) a b.
(Function f, Monad m f, Object f a, Object f b, Object f (m a),
 Object f (m b), Object f (m (m b))) =>
m a -> f a (m b) -> m b
>>= \Needle x
v -> forall (m :: * -> *) (k :: * -> * -> *).
(MonadPlus m k, Arrow k (->), Function k, UnitObject k ~ (),
 Object k Bool) =>
k Bool (m ())
guard ((Variance (DualVector (Needle x))
ex'forall v.
(LSpace v, Floating (Scalar v)) =>
Seminorm v -> v -> Scalar v
|$|Needle x
v) forall a. Ord a => a -> a -> Bool
> Scalar (Needle x)
1) forall (k :: * -> * -> *) (m :: * -> *) b a.
(WellPointed k, Monad m k, ObjectPair k b (UnitObject k),
 ObjectPair k (m b) (UnitObject k),
 ObjectPair k (UnitObject k) (m b), ObjectPair k b a,
 ObjectPair k a b, Object k (m (a, b)), ObjectPair k (m a) (m b),
 ObjectPoint k (m a)) =>
m a -> k (m b) (m b)
>> [(Needle x
v, forall v. LSpace v => [v] -> Variance v
spanVariance [Needle x
v])] of
             []   -> Norm (DualVector (Needle x))
ex
             [(Needle x, Norm (DualVector (Needle x)))]
outs -> DualNeedleWitness x
-> [Needle x]
-> Norm (DualVector (Needle x))
-> Norm (DualVector (Needle x))
guaranteeIn DualNeedleWitness x
w (forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fstforall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>[(Needle x, Norm (DualVector (Needle x)))]
outs)
                                 ( forall v. LSpace v => Norm v -> Norm v
densifyNorm forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$
                                    Norm (DualVector (Needle x))
ex 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 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. 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 a b. (Integral a, Num b) => a -> b
fromIntegral
                                                            forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Int
2 forall a. Num a => a -> a -> a
* forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Needle x, Norm (DualVector (Needle x)))]
outs)
                                                (forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
sndforall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>[(Needle x, Norm (DualVector (Needle x)))]
outs)
                                 )
        where ex' :: Variance (DualVector (Needle x))
ex' = forall v. SimpleSpace v => Norm v -> Variance v
dualNorm Norm (DualVector (Needle x))
ex

-- | Like 'pointsShades', but ensure that all points are actually in
--   the shade, i.e. if @['Shade' x₀ ex]@ is the result then
--   @'metric' (recipMetric ex) (p-x₀) ≤ 1@ for all @p@ in the list.
pointsCovers :: ∀ x . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x))
                          => [x] -> [Shade x]
pointsCovers :: forall x.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
[x] -> [Shade x]
pointsCovers = case forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness :: PseudoAffineWitness x of
                 (PseudoAffineWitness (SemimanifoldWitness x
SemimanifoldWitness)) ->
                  \[x]
ps -> forall a b. (a -> b) -> [a] -> [b]
map (\([(x, ())]
ps', Shade x
x₀ Norm (Needle' x)
_)
                                -> forall x s.
(Fractional' s, WithField s PseudoAffine x,
 SimpleSpace (Needle x)) =>
x -> [Needle x] -> Shade x
coverAllAround x
x₀ [Needle x
v | (x
p,())<-[(x, ())]
ps'
                                                        , let Just Needle x
v
                                                                 = x
pforall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
x₀])
                             (forall x y.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
Metric' x -> [(x, y)] -> [([(x, y)], Shade x)]
pointsShades' forall a. Monoid a => a
mempty ((,())forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>[x]
ps)
                                  :: [([(x,())], Shade x)])

pointsShade's :: ∀ x . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x))
                     => [x] -> [Shade' x]
pointsShade's :: forall x.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
[x] -> [Shade' x]
pointsShade's = case forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualNeedleWitness x of
 DualSpaceWitness (Needle x)
DualSpaceWitness -> forall a b. (a -> b) -> [a] -> [b]
map (\(Shade x
c Metric' x
e :: Shade x) -> forall x. x -> Metric x -> Shade' x
Shade' x
c 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
e) 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 x.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
[x] -> [Shade x]
pointsShades

pointsCover's :: ∀ x . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x))
                     => [x] -> [Shade' x]
pointsCover's :: forall x.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
[x] -> [Shade' x]
pointsCover's = case forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualNeedleWitness x of
 DualSpaceWitness (Needle x)
DualSpaceWitness -> forall a b. (a -> b) -> [a] -> [b]
map (\(Shade x
c Metric' x
e :: Shade x) -> forall x. x -> Metric x -> Shade' x
Shade' x
c 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
e) 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 x.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
[x] -> [Shade x]
pointsCovers

pseudoECM :: ∀ x y p . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x), Hask.Functor p)
                => p x -> NonEmpty (x,y) -> (x, ([(x,y)],[(x,y)]))
pseudoECM :: forall x y (p :: * -> *).
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x), Functor p) =>
p x -> NonEmpty (x, y) -> (x, ([(x, y)], [(x, y)]))
pseudoECM = case forall x. Semimanifold x => SemimanifoldWitness x
semimanifoldWitness :: SemimanifoldWitness x of
 SemimanifoldWitness x
SemimanifoldWitness ->
   \p x
_ ((x
p₀,y
y₀) NE.:| [(x, y)]
psr) -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ( \(x
acc, ([(x, y)]
rb,[(x, y)]
nr)) (ℝ
i,(x
p,y
y))
                                -> case (x
pforall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
acc, x
acc) of 
                                      (Just Needle x
δ, x
acci)
                                        -> (x
acci forall x. Semimanifold x => x -> Needle x -> x
.+~^ Needle x
δforall v s.
(VectorSpace v, s ~ Scalar v, Fractional s) =>
v -> s -> v
^/ℝ
i, ((x
p,y
y)forall a. a -> [a] -> [a]
:[(x, y)]
rb, [(x, y)]
nr))
                                      (Maybe (Needle x), x)
_ -> (x
acc, ([(x, y)]
rb, (x
p,y
y)forall a. a -> [a] -> [a]
:[(x, y)]
nr)) )
                             (x
p₀, forall a. Monoid a => a
mempty)
                             ( forall a b. [a] -> [b] -> [(a, b)]
zip [ℝ
1..] forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (x
p₀,y
y₀)forall a. a -> [a] -> [a]
:[(x, y)]
psr )

pointsShades' :: ∀ x y . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x))
                                => Metric' x -> [(x,y)] -> [([(x,y)], Shade x)]
pointsShades' :: forall x y.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
Metric' x -> [(x, y)] -> [([(x, y)], Shade x)]
pointsShades' Norm (DualVector (Needle x))
_ [] = []
pointsShades' Norm (DualVector (Needle x))
minExt [(x, y)]
ps = case (Maybe (Norm (DualVector (Needle x)))
expa, x
ctr) of 
                           (Just Norm (DualVector (Needle x))
e, x
c)
                             -> ([(x, y)]
ps, forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
fullShade x
c Norm (DualVector (Needle x))
e) forall a. a -> [a] -> [a]
: forall x y.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
Metric' x -> [(x, y)] -> [([(x, y)], Shade x)]
pointsShades' Norm (DualVector (Needle x))
minExt [(x, y)]
unreachable
                           (Maybe (Norm (DualVector (Needle x))), x)
_ -> forall x y.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
Metric' x -> [(x, y)] -> [([(x, y)], Shade x)]
pointsShades' Norm (DualVector (Needle x))
minExt [(x, y)]
inc'd
                                  forall a. [a] -> [a] -> [a]
++ forall x y.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
Metric' x -> [(x, y)] -> [([(x, y)], Shade x)]
pointsShades' Norm (DualVector (Needle x))
minExt [(x, y)]
unreachable
 where (x
ctr,([(x, y)]
inc'd,[(x, y)]
unreachable)) = forall x y (p :: * -> *).
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x), Functor p) =>
p x -> NonEmpty (x, y) -> (x, ([(x, y)], [(x, y)]))
pseudoECM ([]::[x]) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. [a] -> NonEmpty a
NE.fromList [(x, y)]
ps
       expa :: Maybe (Norm (DualVector (Needle x)))
expa = ( (forall a. Semigroup a => a -> a -> a
<>Norm (DualVector (Needle x))
minExt) 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 => [v] -> Variance v
spanVariance 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. (a -> b) -> [a] -> [b]
map (forall v s.
(VectorSpace v, s ~ Scalar v, Fractional s) =>
v -> s -> v
^/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(x, y)]
ps)) )
              forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> forall (s :: * -> *) (t :: * -> *) (k :: * -> * -> *)
       (l :: * -> * -> *) (m :: * -> *) a b.
(Traversable s t k l, k ~ l, s ~ t, Applicative m k k, Object k a,
 Object k (t a), ObjectPair k b (t b), ObjectPair k (m b) (m (t b)),
 TraversalObject k t b) =>
k a (m b) -> k (t a) (m (t b))
mapM ((forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
ctr) 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 :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst) [(x, y)]
ps
       

-- | Attempt to reduce the number of shades to fewer (ideally, a single one).
--   In the simplest cases these should guaranteed cover the same area;
--   for non-flat manifolds it only works in a heuristic sense.
shadesMerge :: ∀ x . (WithField ℝ Manifold x, SimpleSpace (Needle x))
                 => ℝ -- ^ How near (inverse normalised distance, relative to shade expanse)
                      --   two shades must be to be merged. If this is zero, any shades
                      --   in the same connected region of a manifold are merged.
                 -> [Shade x] -- ^ A list of /n/ shades.
                 -> [Shade x] -- ^ /m/ &#x2264; /n/ shades which cover at least the same area.
shadesMerge :: forall x.
(WithField ℝ Manifold x, SimpleSpace (Needle x)) =>
ℝ -> [Shade x] -> [Shade x]
shadesMerge ℝ
fuzz (sh :: Shade x
sh@(Shade x
c₁ Metric' x
e₁) : [Shade x]
shs)
    = case forall a b. (a -> Maybe b) -> [a] -> (Maybe b, [a])
extractJust (PseudoAffineWitness x
-> DualNeedleWitness x -> Shade x -> Maybe (Shade x)
tryMerge forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness)
                 [Shade x]
shs of
          (Just Shade x
mg₁, [Shade x]
shs') -> forall x.
(WithField ℝ Manifold x, SimpleSpace (Needle x)) =>
ℝ -> [Shade x] -> [Shade x]
shadesMerge ℝ
fuzz
                                forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ [Shade x]
shs'forall a. [a] -> [a] -> [a]
++[Shade x
mg₁] -- Append to end to prevent undue weighting
                                              -- of first shade and its mergers.
          (Maybe (Shade x)
_, [Shade x]
shs') -> Shade x
sh forall a. a -> [a] -> [a]
: forall x.
(WithField ℝ Manifold x, SimpleSpace (Needle x)) =>
ℝ -> [Shade x] -> [Shade x]
shadesMerge ℝ
fuzz [Shade x]
shs' 
 where tryMerge :: PseudoAffineWitness x -> DualNeedleWitness x
                         -> Shade x -> Maybe (Shade x)
       tryMerge :: PseudoAffineWitness x
-> DualNeedleWitness x -> Shade x -> Maybe (Shade x)
tryMerge (PseudoAffineWitness (SemimanifoldWitness x
SemimanifoldWitness)) DualNeedleWitness x
DualSpaceWitness
                    (Shade x
c₂ Metric' x
e₂)
           | Just Needle x
v <- x
c₁forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
c₂
           , [Norm (DualVector (Needle' x))
e₁',Norm (DualVector (Needle' x))
e₂'] <- forall v. SimpleSpace v => Norm v -> Variance v
dualNormforall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>[Metric' x
e₁, Metric' x
e₂] 
           , Scalar (DualVector (Needle' x))
b₁ <- Norm (DualVector (Needle' x))
e₂'forall v.
(LSpace v, Floating (Scalar v)) =>
Seminorm v -> v -> Scalar v
|$|Needle x
v
           , Scalar (DualVector (Needle' x))
b₂ <- Norm (DualVector (Needle' x))
e₁'forall v.
(LSpace v, Floating (Scalar v)) =>
Seminorm v -> v -> Scalar v
|$|Needle x
v
           , ℝ
fuzzforall a. Num a => a -> a -> a
*Scalar (DualVector (Needle' x))
b₁forall a. Num a => a -> a -> a
*Scalar (DualVector (Needle' x))
b₂ forall a. Ord a => a -> a -> Bool
<= Scalar (DualVector (Needle' x))
b₁ forall a. Num a => a -> a -> a
+ Scalar (DualVector (Needle' x))
b₂
                  = forall a. a -> Maybe a
Just forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ let cc :: x
cc = x
c₂ forall x. Semimanifold x => x -> Needle x -> x
.+~^ Needle x
v forall v s.
(VectorSpace v, s ~ Scalar v, Fractional s) =>
v -> s -> v
^/ Scalar (Needle x)
2
                               Just Needle x
cv₁ = x
c₁forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
cc
                               Just Needle x
cv₂ = x
c₂forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
cc
                           in forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade x
cc forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Metric' x
e₁ forall a. Semigroup a => a -> a -> a
<> Metric' x
e₂ forall a. Semigroup a => a -> a -> a
<> forall v. LSpace v => [v] -> Variance v
spanVariance [Needle x
cv₁, Needle x
cv₂]
           | Bool
otherwise  = forall a. Maybe a
Nothing
shadesMerge ℝ
_ [Shade x]
shs = [Shade x]
shs

-- | Weakened version of 'intersectShade's'. What this function calculates is
--   rather the /weighted mean/ of ellipsoid regions. If you interpret the
--   shades as uncertain physical measurements with normal distribution,
--   it gives the maximum-likelyhood result for multiple measurements of the
--   same quantity.
mixShade's :: ∀ y . (WithField ℝ Manifold y, SimpleSpace (Needle y))
                 => NonEmpty (Shade' y) -> Maybe (Shade' y)
mixShade's :: forall y.
(WithField ℝ Manifold y, SimpleSpace (Needle y)) =>
NonEmpty (Shade' y) -> Maybe (Shade' y)
mixShade's = PseudoAffineWitness y
-> DualNeedleWitness y -> NonEmpty (Shade' y) -> Maybe (Shade' y)
ms forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness
 where ms :: PseudoAffineWitness y -> DualNeedleWitness y
                  -> NonEmpty (Shade' y) -> Maybe (Shade' y)
       ms :: PseudoAffineWitness y
-> DualNeedleWitness y -> NonEmpty (Shade' y) -> Maybe (Shade' y)
ms (PseudoAffineWitness (SemimanifoldWitness y
SemimanifoldWitness)) DualNeedleWitness y
DualSpaceWitness
                 (Shade' y
c₀ (Norm Needle y -+> Needle' y
e₁):|[Shade' y]
shs) = forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [Maybe (Needle y)]
ciso forall (k :: * -> * -> *) (m :: * -> *) b a.
(WellPointed k, Monad m k, ObjectPair k b (UnitObject k),
 ObjectPair k (m b) (UnitObject k),
 ObjectPair k (UnitObject k) (m b), ObjectPair k b a,
 ObjectPair k a b, Object k (m (a, b)), ObjectPair k (m a) (m b),
 ObjectPoint k (m a)) =>
m a -> k (m b) (m b)
>> forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a.
(Applicative f r t, Object r a, Object t (f a)) =>
t a (f a)
pure Shade' y
mixed
        where ciso :: [Maybe (Needle y)]
ciso = [y
ciforall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.y
c₀ | Shade' y
ci Norm (Needle y)
shi <- [Shade' y]
shs]
              cis :: [Needle y]
cis = [Needle y
v | Just Needle y
v <- [Maybe (Needle y)]
ciso]
              σe :: LinearMap ℝ (Needle y) (Needle' y)
σe = 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 κ (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 (f :: * -> *) v. (Foldable f, AdditiveGroup v) => f v -> v
sumV forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Needle y -+> Needle' y
e₁ forall a. a -> [a] -> [a]
: (forall v. Norm v -> v -+> DualVector v
applyNorm 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 x. Shade' x -> Metric x
_shade'Narrownessforall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>[Shade' y]
shs)
              cc :: Needle y
cc = LinearMap ℝ (Needle y) (Needle' y)
σe forall u v.
(SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v) =>
(u +> v) -> v -> u
\$ forall (f :: * -> *) v. (Foldable f, AdditiveGroup v) => f v -> v
sumV [Needle y -+> Needle' y
ei forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Needle y
ci | Needle y
ci <- [Needle y]
cis
                                       | Shade' y
_ (Norm Needle y -+> Needle' y
ei) <- [Shade' y]
shs]
              mixed :: Shade' y
mixed = forall x. x -> Metric x -> Shade' x
Shade' (y
c₀y -> Needle y -> y
+^Needle y
cc) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall v. LSpace v => Norm v -> Norm v
densifyNorm ( forall a. Monoid a => [a] -> a
mconcat
                             [ forall v. (v -+> DualVector v) -> Norm v
Norm forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Needle y -+> Needle' y
ei forall v s.
(VectorSpace v, s ~ Scalar v, Fractional s) =>
v -> s -> v
^/ (ℝ
1forall a. Num a => a -> a -> a
+(forall v. LSpace v => Seminorm v -> v -> Scalar v
normSq Norm (Needle y)
ni forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Needle y
ciforall v. AdditiveGroup v => v -> v -> v
^-^Needle y
cc))
                             | ni :: Norm (Needle y)
ni@(Norm Needle y -+> Needle' y
ei) <- forall v. (v -+> DualVector v) -> Norm v
Norm Needle y -+> Needle' y
e₁ forall a. a -> [a] -> [a]
: (forall x. Shade' x -> Metric x
_shade'Narrownessforall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>[Shade' y]
shs)
                             | Needle y
ci <- forall v. AdditiveGroup v => v
zeroV forall a. a -> [a] -> [a]
: [Needle y]
cis
                             ] )
              +^ :: y -> Needle y -> y
(+^) = forall x. Semimanifold x => x -> Needle x -> x
(.+~^)
  -- cc should minimise the quadratic form
  -- β(cc) = ∑ᵢ ⟨cc−cᵢ|eᵢ|cc−cᵢ⟩
  -- = ⟨cc|e₁|cc⟩ + ∑ᵢ₌₁… ⟨cc−c₂|e₂|cc−c₂⟩
  -- = ⟨cc|e₁|cc⟩ + ∑ᵢ₌₁…( ⟨cc|eᵢ|cc⟩ − 2⋅⟨cᵢ|eᵢ|cc⟩ + ⟨cᵢ|eᵢ|cᵢ⟩ )
  -- It is thus
  -- β(cc + δ⋅v) − β cc
  -- = ⟨cc + δ⋅v|e₁|cc + δ⋅v⟩
  --     + ∑ᵢ₌₁…( ⟨cc + δ⋅v|eᵢ|cc + δ⋅v⟩ − 2⋅⟨cᵢ|eᵢ|cc + δ⋅v⟩ + ⟨cᵢ|eᵢ|cᵢ⟩ )
  --     − ⟨cc|e₁|cc⟩
  --     − ∑ᵢ₌₁…( ⟨cc|eᵢ|cc⟩ + 2⋅⟨cᵢ|eᵢ|cc⟩ − ⟨cᵢ|eᵢ|cᵢ⟩ )
  -- = ⟨cc + δ⋅v|e₁|cc + δ⋅v⟩
  --     + ∑ᵢ₌₁…( ⟨cc + δ⋅v|eᵢ|cc + δ⋅v⟩ − 2⋅⟨cᵢ|eᵢ|δ⋅v⟩ )
  --     − ⟨cc|e₁|cc⟩
  --     − ∑ᵢ₌₁…( ⟨cc|eᵢ|cc⟩ )
  -- = 2⋅⟨δ⋅v|e₁|cc⟩ + ⟨δ⋅v|e₁|δ⋅v⟩
  --     + ∑ᵢ₌₁…( 2⋅⟨δ⋅v|eᵢ|cc⟩ + ⟨δ⋅v|eᵢ|δ⋅v⟩ − 2⋅⟨cᵢ|eᵢ|δ⋅v⟩ )
  -- = 2⋅⟨δ⋅v|∑ᵢeᵢ|cc⟩ − 2⋅∑ᵢ₌₁… ⟨cᵢ|eᵢ|δ⋅v⟩ + 𝓞(δ²)
  -- This should vanish for all v, which is fulfilled by
  -- (∑ᵢeᵢ)|cc⟩ = ∑ᵢ₌₁… eᵢ|cᵢ⟩.

-- | Evaluate the shade as a quadratic form; essentially
-- @
-- minusLogOcclusion sh x = x <.>^ (sh^.shadeExpanse $ x - sh^.shadeCtr)
-- @
-- where 'shadeExpanse' gives a metric (matrix) that characterises the
-- width of the shade.
minusLogOcclusion' :: ∀ x s . ( PseudoAffine x, LinearSpace (Needle x)
                              , s ~ (Scalar (Needle x)), RealFloat' s )
              => Shade' x -> x -> s
minusLogOcclusion' :: forall x s.
(PseudoAffine x, LinearSpace (Needle x), s ~ Scalar (Needle x),
 RealFloat' s) =>
Shade' x -> x -> s
minusLogOcclusion' (Shade' x
p₀ Metric x
δinv)
        = PseudoAffineWitness x -> DualSpaceWitness (Needle x) -> x -> s
occ (forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness :: PseudoAffineWitness x)
              (forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualNeedleWitness x)
 where occ :: PseudoAffineWitness x -> DualSpaceWitness (Needle x) -> x -> s
occ (PseudoAffineWitness (SemimanifoldWitness x
SemimanifoldWitness)) DualSpaceWitness (Needle x)
DualSpaceWitness
           x
p = case x
pforall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
p₀ of
         (Just Needle x
vd) | Scalar (Needle x)
mSq <- forall v. LSpace v => Seminorm v -> v -> Scalar v
normSq Metric x
δinv Needle x
vd
                   , Scalar (Needle x)
mSq forall a. Eq a => a -> a -> Bool
== Scalar (Needle x)
mSq  -- avoid NaN
                   -> Scalar (Needle x)
mSq
         Maybe (Needle x)
_         -> s
1forall a. Fractional a => a -> a -> a
/s
0
minusLogOcclusion :: ∀ x s . ( PseudoAffine x, SimpleSpace (Needle x)
                             , s ~ (Scalar (Needle x)), RealFloat' s )
              => Shade x -> x -> s
minusLogOcclusion :: forall x s.
(PseudoAffine x, SimpleSpace (Needle x), s ~ Scalar (Needle x),
 RealFloat' s) =>
Shade x -> x -> s
minusLogOcclusion (Shade x
p₀ Metric' x
δ)
        = PseudoAffineWitness x -> DualSpaceWitness (Needle x) -> x -> s
occ (forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness :: PseudoAffineWitness x)
              (forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualNeedleWitness x)
 where occ :: PseudoAffineWitness x -> DualSpaceWitness (Needle x) -> x -> s
occ (PseudoAffineWitness (SemimanifoldWitness x
SemimanifoldWitness)) DualSpaceWitness (Needle x)
DualSpaceWitness
            = \x
p -> case x
pforall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
p₀ of
         (Just Needle x
vd) | Scalar (Needle x)
mSq <- forall v. LSpace v => Seminorm v -> v -> Scalar v
normSq Variance (DualVector (Needle x))
δinv Needle x
vd
                   , Scalar (Needle x)
mSq forall a. Eq a => a -> a -> Bool
== Scalar (Needle x)
mSq  -- avoid NaN
                   -> Scalar (Needle x)
mSq
         Maybe (Needle x)
_         -> s
1forall a. Fractional a => a -> a -> a
/s
0
        where δinv :: Variance (DualVector (Needle x))
δinv = forall v. SimpleSpace v => Norm v -> Variance v
dualNorm Metric' x
δ



rangeWithinVertices :: ∀ i m t s
        . ( Geodesic i
          , Geodesic m
          , WithField s AffineManifold (Interior i)
          , WithField s AffineManifold (Interior m)
          , SimpleSpace (Needle (Interior i))
          , SimpleSpace (Needle (Interior m))
          , SimpleSpace (Needle' (Interior i))
          , SimpleSpace (Needle' (Interior m))
          , RealFrac' s
          , Hask.Traversable t )
          => (Interior i,Interior m) -> t (i,m)
               -> Maybe (Shade (Interior i) -> Shade (Interior m))
rangeWithinVertices :: forall i m (t :: * -> *) s.
(Geodesic i, Geodesic m, WithField s AffineManifold (Interior i),
 WithField s AffineManifold (Interior m),
 SimpleSpace (Needle (Interior i)),
 SimpleSpace (Needle (Interior m)),
 SimpleSpace (Needle' (Interior i)),
 SimpleSpace (Needle' (Interior m)), RealFrac' s, Traversable t) =>
(Interior i, Interior m)
-> t (i, m) -> Maybe (Shade (Interior i) -> Shade (Interior m))
rangeWithinVertices (Interior i
cii,Interior m
cmi) t (i, m)
verts = do
           [(Diff (Interior i), Diff (Interior m))]
vs <- forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [ forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Monoidal f r t, ObjectPair r a b, ObjectPair t (f a) (f b),
 Object t (f (a, b))) =>
t (f a, f b) (f (a, b))
fzip ( forall x. Geodesic x => x -> x -> Maybe x
middleBetween i
pi i
ci forall (f :: * -> * -> *) (m :: * -> *) a b.
(Function f, Monad m f, Object f a, Object f b, Object f (m a),
 Object f (m b), Object f (m (m b))) =>
m a -> f a (m b) -> m b
>>= (forall m. SemimanifoldWithBoundary m => m -> Maybe (Interior m)
toInteriorforall (m :: * -> *) (k :: * -> * -> *) a b c.
(Monad m k, Object k a, Object k b, Object k c, Object k (m b),
 Object k (m c), Object k (m (m c))) =>
k a (m b) -> k b (m c) -> k a (m c)
>=>(forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.Interior i
cii))
                                  , forall x. Geodesic x => x -> x -> Maybe x
middleBetween m
pm m
cm forall (f :: * -> * -> *) (m :: * -> *) a b.
(Function f, Monad m f, Object f a, Object f b, Object f (m a),
 Object f (m b), Object f (m (m b))) =>
m a -> f a (m b) -> m b
>>= (forall m. SemimanifoldWithBoundary m => m -> Maybe (Interior m)
toInteriorforall (m :: * -> *) (k :: * -> * -> *) a b c.
(Monad m k, Object k a, Object k b, Object k c, Object k (m b),
 Object k (m c), Object k (m (m c))) =>
k a (m b) -> k b (m c) -> k a (m c)
>=>(forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.Interior m
cmi)) )
                           | (i
pi, m
pm) <- forall (t :: * -> *) a. Foldable t => t a -> [a]
Hask.toList t (i, m)
verts ]
           Embedding (Affine s) (Interior i) (Interior m)
affinSys <- forall x c (t :: * -> *) s.
(WithField s AffineManifold c, WithField s AffineManifold x,
 SemiInner (Needle c), SemiInner (Needle x), RealFrac' s,
 Traversable t) =>
(c, x)
-> t (Needle c, Needle x) -> Maybe (Embedding (Affine s) c x)
correspondingDirections @(Interior m) @(Interior i)
                         (Interior i
cii,Interior m
cmi) [(Diff (Interior i), Diff (Interior m))]
vs
           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, SemiInner (Needle x),
 SimpleSpace (Needle y)) =>
Embedding (Affine s) x y -> shade x -> shade y
embedShade Embedding (Affine s) (Interior i) (Interior m)
affinSys
 where ci :: i
ci = forall m. SemimanifoldWithBoundary m => Interior m -> m
fromInterior Interior i
cii
       cm :: m
cm = forall m. SemimanifoldWithBoundary m => Interior m -> m
fromInterior Interior m
cmi





data DebugView x where
  DebugView :: ( Show x, Show (Needle x+>Needle' x), LinearShowable (Needle x)
               , Needle' x ~ Needle x ) => DebugView x

-- | Class of manifolds which can use 'Shade'' as a basic set type.
--   This is easily possible for vector spaces with the default implementations.
class (WithField ℝ PseudoAffine y, SimpleSpace (Needle y)) => Refinable y where
  debugView :: Maybe (DebugView y)
  default debugView :: ( Show y, Show (Needle y+>Needle' y)
                       , Needle' y~Needle y, LinearShowable (Needle y) )
                         => Maybe (DebugView y)
  debugView = forall a. a -> Maybe a
Just forall x.
(Show x, Show (Needle x +> Needle' x), LinearShowable (Needle x),
 Needle' x ~ Needle x) =>
DebugView x
DebugView
  
  -- | @a `subShade'` b ≡ True@ means @a@ is fully contained in @b@, i.e. from
  --   @'minusLogOcclusion'' a p < 1@ follows also @minusLogOcclusion' b p < 1@.
  subShade' :: Shade' y -> Shade' y -> Bool
  subShade' (Shade' y
ac Metric y
ae) (Shade' y
tc Metric y
te)
        = case forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness :: PseudoAffineWitness y of
   PseudoAffineWitness (SemimanifoldWitness y
SemimanifoldWitness)
    | Just Needle y
v <- y
tcforall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.y
ac
    , Scalar (Needle y)
v² <- forall v. LSpace v => Seminorm v -> v -> Scalar v
normSq Metric y
te Needle y
v
    , Scalar (Needle y)
v² forall a. Ord a => a -> a -> Bool
<= ℝ
1
     -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(Needle' y
y',Maybe (Scalar (Needle y))
μ) -> case Maybe (Scalar (Needle y))
μ of
            Maybe (Scalar (Needle y))
Nothing -> Bool
True  -- 'te' has infinite extension in this direction
            Just Scalar (Needle y)
ξ
              | Scalar (Needle y)
ξforall a. Ord a => a -> a -> Bool
<Scalar (Needle y)
1 -> Bool
False -- 'ae' would be vaster than 'te' in this direction
              | Scalar (Needle y)
ω <- forall a. Num a => a -> a
abs forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Needle' y
y'forall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^Needle y
v
                    -> (Scalar (Needle y)
ω forall a. Num a => a -> a -> a
+ Scalar (Needle y)
1forall a. Fractional a => a -> a -> a
/Scalar (Needle y)
ξ)forall a. Num a => a -> Int -> a
^Int
2 forall a. Ord a => a -> a -> Bool
<= Scalar (Needle y)
1 forall a. Num a => a -> a -> a
- Scalar (Needle y)
v² forall a. Num a => a -> a -> a
+ Scalar (Needle y)
ωforall a. Num a => a -> Int -> a
^Int
2
                 -- See @images/constructions/subellipse-check-heuristic.svg@
         ) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall v.
SimpleSpace v =>
Seminorm v -> Seminorm v -> [(DualVector v, Maybe (Scalar v))]
sharedSeminormSpanningSystem Metric y
te Metric y
ae
   PseudoAffineWitness y
_ -> Bool
False
  
  -- | Intersection between two shades.
  refineShade' :: Shade' y -> Shade' y -> Maybe (Shade' y)
  refineShade' (Shade' y
c₀ (Norm Needle y -+> Needle' y
e₁)) (Shade' y
c₀₂ (Norm Needle y -+> Needle' y
e₂))
      = case ( forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualNeedleWitness y
             , forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness :: PseudoAffineWitness y ) of
          (DualSpaceWitness (Needle y)
DualSpaceWitness, PseudoAffineWitness (SemimanifoldWitness y
SemimanifoldWitness))
               -> do
           Needle y
c₂ <- y
c₀₂forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.y
c₀
           let σe :: LinearMap ℝ (Needle y) (Needle' y)
σe = 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
$ Needle y -+> Needle' y
e₁forall v. AdditiveGroup v => v -> v -> v
^+^Needle y -+> Needle' y
e₂
               e₁c₂ :: Needle' y
e₁c₂ = Needle y -+> Needle' y
e₁ forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Needle y
c₂
               e₂c₂ :: Needle' y
e₂c₂ = Needle y -+> Needle' y
e₂ forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Needle y
c₂
               cc :: Needle y
cc = LinearMap ℝ (Needle y) (Needle' y)
σe forall u v.
(SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v) =>
(u +> v) -> v -> u
\$ Needle' y
e₂c₂
               cc₂ :: Needle y
cc₂ = Needle y
cc forall v. AdditiveGroup v => v -> v -> v
^-^ Needle y
c₂
               e₁cc :: Needle' y
e₁cc = Needle y -+> Needle' y
e₁ forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Needle y
cc
               e₂cc :: Needle' y
e₂cc = Needle y -+> Needle' y
e₂ forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Needle y
cc
               α :: ℝ
α = ℝ
2 forall a. Num a => a -> a -> a
+ Needle' y
e₂c₂forall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^Needle y
cc₂
           forall (m :: * -> *) (k :: * -> * -> *).
(MonadPlus m k, Arrow k (->), Function k, UnitObject k ~ (),
 Object k Bool) =>
k Bool (m ())
guard (ℝ
α forall a. Ord a => a -> a -> Bool
> ℝ
0)
           let ee :: LinearMap ℝ (Needle y) (Needle' y)
ee = LinearMap ℝ (Needle y) (Needle' y)
σe forall v s.
(VectorSpace v, s ~ Scalar v, Fractional s) =>
v -> s -> v
^/ ℝ
α
               c₂e₁c₂ :: Scalar (Needle y)
c₂e₁c₂ = Needle' y
e₁c₂forall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^Needle y
c₂
               c₂e₂c₂ :: Scalar (Needle y)
c₂e₂c₂ = Needle' y
e₂c₂forall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^Needle y
c₂
               c₂eec₂ :: ℝ
c₂eec₂ = (Scalar (Needle y)
c₂e₁c₂ forall a. Num a => a -> a -> a
+ Scalar (Needle y)
c₂e₂c₂) forall a. Fractional a => a -> a -> a
/ ℝ
α
           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
$ case forall {a}. [a] -> [a]
middle 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. Ord a => [a] -> [a]
sort
                forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall {a}. (Ord a, Floating a) => a -> a -> a -> [a]
quadraticEqnSol Scalar (Needle y)
c₂e₁c₂
                                  (ℝ
2 forall a. Num a => a -> a -> a
* (Needle' y
e₁ccforall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^Needle y
c₂))
                                  (Needle' y
e₁ccforall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^Needle y
cc forall a. Num a => a -> a -> a
- ℝ
1)
                forall a. [a] -> [a] -> [a]
++forall {a}. (Ord a, Floating a) => a -> a -> a -> [a]
quadraticEqnSol Scalar (Needle y)
c₂e₂c₂
                                  (ℝ
2 forall a. Num a => a -> a -> a
* (Needle' y
e₂ccforall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^Needle y
c₂ forall a. Num a => a -> a -> a
- Scalar (Needle y)
c₂e₂c₂))
                                  (Needle' y
e₂ccforall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^Needle y
cc forall a. Num a => a -> a -> a
- ℝ
2 forall a. Num a => a -> a -> a
* (Needle' y
e₂c₂forall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^Needle y
cc) forall a. Num a => a -> a -> a
+ Scalar (Needle y)
c₂e₂c₂ forall a. Num a => a -> a -> a
- ℝ
1) of
            [ℝ
γ₁,ℝ
γ₂] | forall a. Num a => a -> a
abs (ℝ
γ₁forall a. Num a => a -> a -> a
+ℝ
γ₂) forall a. Ord a => a -> a -> Bool
< ℝ
2 -> let
               cc' :: Needle y
cc' = Needle y
cc forall v. AdditiveGroup v => v -> v -> v
^+^ ((ℝ
γ₁forall a. Num a => a -> a -> a
+ℝ
γ₂)forall a. Fractional a => a -> a -> a
/ℝ
2)forall v. VectorSpace v => Scalar v -> v -> v
*^Needle y
c₂
               rγ :: ℝ
rγ = forall a. Num a => a -> a
abs (ℝ
γ₁ forall a. Num a => a -> a -> a
- ℝ
γ₂) forall a. Fractional a => a -> a -> a
/ ℝ
2
               η :: ℝ
η = if ℝ
rγ forall a. Num a => a -> a -> a
* ℝ
c₂eec₂ forall a. Eq a => a -> a -> Bool
/= ℝ
0 Bool -> Bool -> Bool
&& ℝ
1 forall a. Num a => a -> a -> a
- ℝ
rγforall a. Num a => a -> Int -> a
^Int
2 forall a. Num a => a -> a -> a
* ℝ
c₂eec₂ forall a. Ord a => a -> a -> Bool
> ℝ
0
                   then forall a. Floating a => a -> a
sqrt (ℝ
1 forall a. Num a => a -> a -> a
- ℝ
rγforall a. Num a => a -> Int -> a
^Int
2 forall a. Num a => a -> a -> a
* ℝ
c₂eec₂) forall a. Fractional a => a -> a -> a
/ (ℝ
rγ forall a. Num a => a -> a -> a
* ℝ
c₂eec₂)
                   else ℝ
0
             in forall x. x -> Metric x -> Shade' x
Shade' (y
c₀forall x. Semimanifold x => x -> Needle x -> x
.+~^Needle y
cc')
                       (forall v. (v -+> DualVector v) -> Norm v
Norm (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 LinearMap ℝ (Needle y) (Needle' y)
ee) forall a. Semigroup a => a -> a -> a
<> forall v. LSpace v => [DualVector v] -> Seminorm v
spanNorm [LinearMap ℝ (Needle y) (Needle' y)
ee forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Needle y
c₂forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^*ℝ
η])
            [ℝ]
_ -> forall x. x -> Metric x -> Shade' x
Shade' (y
c₀forall x. Semimanifold x => x -> Needle x -> x
.+~^Needle y
cc) (forall v. (v -+> DualVector v) -> Norm v
Norm forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ 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 LinearMap ℝ (Needle y) (Needle' y)
ee)
   where quadraticEqnSol :: a -> a -> a -> [a]
quadraticEqnSol a
a a
b a
c
             | a
a forall a. Eq a => a -> a -> Bool
== a
0, a
b forall a. Eq a => a -> a -> Bool
/= a
0       = [-a
cforall a. Fractional a => a -> a -> a
/a
b]
             | a
a forall a. Eq a => a -> a -> Bool
/= a
0 Bool -> Bool -> Bool
&& a
disc forall a. Eq a => a -> a -> Bool
== a
0  = [- a
b forall a. Fractional a => a -> a -> a
/ (a
2forall a. Num a => a -> a -> a
*a
a)]
             | a
a forall a. Eq a => a -> a -> Bool
/= a
0 Bool -> Bool -> Bool
&& a
disc forall a. Ord a => a -> a -> Bool
> a
0   = [ (a
σ forall a. Num a => a -> a -> a
* forall a. Floating a => a -> a
sqrt a
disc forall a. Num a => a -> a -> a
- a
b) forall a. Fractional a => a -> a -> a
/ (a
2forall a. Num a => a -> a -> a
*a
a)
                                      | a
σ <- [-a
1, a
1] ]
             | Bool
otherwise            = []
          where disc :: a
disc = a
bforall a. Num a => a -> Int -> a
^Int
2 forall a. Num a => a -> a -> a
- a
4forall a. Num a => a -> a -> a
*a
aforall a. Num a => a -> a -> a
*a
c
         middle :: [a] -> [a]
middle (a
_:a
x:a
y:[a]
_) = [a
x,a
y]
         middle [a]
l = [a]
l
  -- ⟨x−c₁|e₁|x−c₁⟩ < 1  ∧  ⟨x−c₂|e₂|x−c₂⟩ < 1
  -- We search (cc,ee) such that this implies
  -- ⟨x−cc|ee|x−cc⟩ < 1.
  -- Let WLOG c₁ = 0, so
  -- ⟨x|e₁|x⟩ < 1.
  -- cc should minimise the quadratic form
  -- β(cc) = ⟨cc−c₁|e₁|cc−c₁⟩ + ⟨cc−c₂|e₂|cc−c₂⟩
  -- = ⟨cc|e₁|cc⟩ + ⟨cc−c₂|e₂|cc−c₂⟩
  -- = ⟨cc|e₁|cc⟩ + ⟨cc|e₂|cc⟩ − 2⋅⟨c₂|e₂|cc⟩ + ⟨c₂|e₂|c₂⟩
  -- It is thus
  -- β(cc + δ⋅v) − β cc
  -- = ⟨cc + δ⋅v|e₁|cc + δ⋅v⟩ + ⟨cc + δ⋅v|e₂|cc + δ⋅v⟩ − 2⋅⟨c₂|e₂|cc + δ⋅v⟩ + ⟨c₂|e₂|c₂⟩
  --     − ⟨cc|e₁|cc⟩ − ⟨cc|e₂|cc⟩ + 2⋅⟨c₂|e₂|cc⟩ − ⟨c₂|e₂|c₂⟩
  -- = ⟨cc + δ⋅v|e₁|cc + δ⋅v⟩ + ⟨cc + δ⋅v|e₂|cc + δ⋅v⟩ − 2⋅⟨c₂|e₂|δ⋅v⟩
  --     − ⟨cc|e₁|cc⟩ − ⟨cc|e₂|cc⟩
  -- = 2⋅⟨δ⋅v|e₁|cc⟩ + ⟨δ⋅v|e₁|δ⋅v⟩ + 2⋅⟨δ⋅v|e₂|cc⟩ + ⟨δ⋅v|e₂|δ⋅v⟩ − 2⋅⟨c₂|e₂|δ⋅v⟩
  -- = 2⋅δ⋅⟨v|e₁+e₂|cc⟩ − 2⋅δ⋅⟨v|e₂|c₂⟩ + 𝓞(δ²)
  -- This should vanish for all v, which is fulfilled by
  -- (e₁+e₂)|cc⟩ = e₂|c₂⟩.
  -- 
  -- If we now choose
  -- ee = (e₁+e₂) / α
  -- then
  -- ⟨x−cc|ee|x−cc⟩ ⋅ α
  --  = ⟨x−cc|ee|x⟩ ⋅ α − ⟨x−cc|ee|cc⟩ ⋅ α
  --  = ⟨x|ee|x−cc⟩ ⋅ α − ⟨x−cc|e₂|c₂⟩
  --  = ⟨x|ee|x⟩ ⋅ α − ⟨x|ee|cc⟩ ⋅ α − ⟨x−cc|e₂|c₂⟩
  --  = ⟨x|e₁+e₂|x⟩ − ⟨x|e₂|c₂⟩ − ⟨x−cc|e₂|c₂⟩
  --  = ⟨x|e₁|x⟩ + ⟨x|e₂|x⟩ − ⟨x|e₂|c₂⟩ − ⟨x−cc|e₂|c₂⟩
  --  < 1 + ⟨x|e₂|x−c₂⟩ − ⟨x−cc|e₂|c₂⟩
  --  = 1 + ⟨x−c₂|e₂|x−c₂⟩ + ⟨c₂|e₂|x−c₂⟩ − ⟨x−cc|e₂|c₂⟩
  --  < 2 + ⟨x−c₂−x+cc|e₂|c₂⟩
  --  = 2 + ⟨cc−c₂|e₂|c₂⟩
  -- Really we want
  -- ⟨x−cc|ee|x−cc⟩ ⋅ α < α
  -- So choose α = 2 + ⟨cc−c₂|e₂|c₂⟩.
  -- 
  -- The ellipsoid "cc±√ee" captures perfectly the intersection
  -- of the boundary of the shades, but it tends to significantly
  -- overshoot the interior intersection in perpendicular direction,
  -- i.e. in direction of c₂−c₁. E.g.
  -- https://github.com/leftaroundabout/manifolds/blob/bc0460b9/manifolds/images/examples/ShadeCombinations/EllipseIntersections.png
  -- 1. Really, the relevant points are those where either of the
  --    intersector badnesses becomes 1. The intersection shade should
  --    be centered between those points. We perform according corrections,
  --    but only in c₂ direction, so this can be handled efficiently
  --    as a 1D quadratic equation.
  --    Consider
  --       dⱼ c := ⟨c−cⱼ|eⱼ|c−cⱼ⟩ =! 1
  --       dⱼ (cc + γ⋅c₂)
  --           = ⟨cc+γ⋅c₂−cⱼ|eⱼ|cc+γ⋅c₂−cⱼ⟩
  --           = ⟨cc−cⱼ|eⱼ|cc−cⱼ⟩ + 2⋅γ⋅⟨c₂|eⱼ|cc−cⱼ⟩ + γ²⋅⟨c₂|eⱼ|c₂⟩
  --           =! 1
  --    So
  --    γⱼ = (- b ± √(b²−4⋅a⋅c)) / 2⋅a
  --     where a = ⟨c₂|eⱼ|c₂⟩
  --           b = 2 ⋅ (⟨c₂|eⱼ|cc⟩ − ⟨c₂|eⱼ|cⱼ⟩)
  --           c = ⟨cc|eⱼ|cc⟩ − 2⋅⟨cc|eⱼ|cⱼ⟩ + ⟨cⱼ|eⱼ|cⱼ⟩ − 1
  --    The ± sign should be chosen to get the smaller |γ| (otherwise
  --    we end up on the wrong side of the shade), i.e.
  --    γⱼ = (sgn bⱼ ⋅ √(bⱼ²−4⋅aⱼ⋅cⱼ) − bⱼ) / 2⋅aⱼ
  -- 2. Trim the result in that direction to the actual
  --    thickness of the lens-shaped intersection: we want
  --    ⟨rγ⋅c₂|ee'|rγ⋅c₂⟩ = 1
  --    for a squeezed version of ee,
  --    ee' = ee + ee|η⋅c₂⟩⟨η⋅c₂|ee
  --    ee' = ee + η² ⋅ ee|c₂⟩⟨c₂|ee
  --    ⟨rγ⋅c₂|ee'|rγ⋅c₂⟩
  --        = rγ² ⋅ (⟨c₂|ee|c₂⟩ + η² ⋅ ⟨c₂|ee|c₂⟩²)
  --        = rγ² ⋅ ⟨c₂|ee|c₂⟩ + η² ⋅ rγ² ⋅ ⟨c₂|ee|c₂⟩²
  --    η² = (1 − rγ²⋅⟨c₂|ee|c₂⟩) / (rγ² ⋅ ⟨c₂|ee|c₂⟩²)
  --    η = √(1 − rγ²⋅⟨c₂|ee|c₂⟩) / (rγ ⋅ ⟨c₂|ee|c₂⟩)
  --    With ⟨c₂|ee|c₂⟩ = (⟨c₂|e₁|c₂⟩ + ⟨c₂|e₂|c₂⟩)/α.

  
  -- | If @p@ is in @a@ (red) and @δ@ is in @b@ (green),
  --   then @p.+~^δ@ is in @convolveShade' a b@ (blue).
  -- 
--   Example: https://nbviewer.jupyter.org/github/leftaroundabout/manifolds/blob/master/test/ShadeCombinations.ipynb#shadeConvolutions
-- 
-- <<images/examples/ShadeCombinations/2Dconvolution-skewed.png>>
  convolveMetric :: Hask.Functor p => p y -> Metric y -> Metric y -> Metric y
  convolveMetric p y
_ Metric y
ey Metric y
eδ = case forall v. LinearSpace v => Norm v -> Maybe (Norm v)
wellDefinedNorm Metric y
result of
          Just Metric y
r  -> Metric y
r
          Maybe (Metric y)
Nothing -> case forall y. Refinable y => Maybe (DebugView y)
debugView :: Maybe (DebugView y) of
            Just DebugView y
DebugView -> forall a. HasCallStack => String -> a
error forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ String
"Can not convolve norms "
                               forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show (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 v. Norm v -> v -+> DualVector v
applyNorm Metric y
ey) :: Needle y+>Needle' y)
                               forall a. [a] -> [a] -> [a]
++String
" and "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show (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 v. Norm v -> v -+> DualVector v
applyNorm Metric y
eδ) :: Needle y+>Needle' y)
   where eδsp :: [(Needle' y, Maybe (Scalar (Needle y)))]
eδsp = forall v.
SimpleSpace v =>
Seminorm v -> Seminorm v -> [(DualVector v, Maybe (Scalar v))]
sharedSeminormSpanningSystem Metric y
ey Metric y
eδ
         result :: Metric y
result = forall v. LSpace v => [DualVector v] -> Seminorm v
spanNorm [ Needle' y
f forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^* Maybe ℝ -> ℝ
ζ Maybe ℝ
crl | (Needle' y
f,Maybe ℝ
crl) <- [(Needle' y, Maybe (Scalar (Needle y)))]
eδsp ]
         ζ :: Maybe ℝ -> ℝ
ζ = case forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a.
(SumToProduct f r t, Object r a, Object r Bool, Object t (f a)) =>
r a Bool -> t (f a) (f a)
filter (forall a. Ord a => a -> a -> Bool
>ℝ
0) 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. [Maybe a] -> [a]
catMaybes forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
sndforall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>[(Needle' y, Maybe (Scalar (Needle y)))]
eδsp of
            [] -> forall (a :: * -> * -> *) b x.
(WellPointed a, Object a b, ObjectPoint a x) =>
x -> a b x
const ℝ
0
            [ℝ]
nzrelap
               -> let cre₁ :: ℝ
cre₁ = ℝ
1forall a. Fractional a => a -> a -> a
/forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [ℝ]
nzrelap
                      cre₂ :: ℝ
cre₂ =  forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [ℝ]
nzrelap
                      edgeFactor :: ℝ
edgeFactor = forall a. Floating a => a -> a
sqrt ( (ℝ
1 forall a. Num a => a -> a -> a
+ ℝ
cre₁)forall a. Num a => a -> Int -> a
^Int
2 forall a. Num a => a -> a -> a
+ (ℝ
1 forall a. Num a => a -> a -> a
+ ℝ
cre₂)forall a. Num a => a -> Int -> a
^Int
2 )
                                forall a. Fractional a => a -> a -> a
/ (forall a. Floating a => a -> a
sqrt (ℝ
1 forall a. Num a => a -> a -> a
+ ℝ
cre₁forall a. Num a => a -> Int -> a
^Int
2) forall a. Num a => a -> a -> a
+ forall a. Floating a => a -> a
sqrt (ℝ
1 forall a. Num a => a -> a -> a
+ ℝ
cre₂forall a. Num a => a -> Int -> a
^Int
2))
                  in \case
                        Maybe ℝ
Nothing -> ℝ
0
                        Just ℝ
0  -> ℝ
0
                        Just ℝ
sq -> ℝ
edgeFactor forall a. Fractional a => a -> a -> a
/ (forall a. Fractional a => a -> a
recip ℝ
sq forall a. Num a => a -> a -> a
+ ℝ
1)
  
  convolveShade' :: Shade' y -> Shade' (Needle y) -> Shade' y
  convolveShade' = forall y. Refinable y => Shade' y -> Shade' (Needle y) -> Shade' y
defaultConvolveShade'
  
defaultConvolveShade' :: ∀ y . Refinable y => Shade' y -> Shade' (Needle y) -> Shade' y
defaultConvolveShade' :: forall y. Refinable y => Shade' y -> Shade' (Needle y) -> Shade' y
defaultConvolveShade' = case (forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness :: PseudoAffineWitness y) of
  PseudoAffineWitness (SemimanifoldWitness y
SemimanifoldWitness)
    -> \(Shade' y
y₀ Norm (Needle y)
ey) (Shade' Needle y
δ₀ Metric (Needle y)
eδ) -> forall x. x -> Metric x -> Shade' x
Shade' (y
y₀forall x. Semimanifold x => x -> Needle x -> x
.+~^Needle y
δ₀)
                                          forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall y (p :: * -> *).
(Refinable y, Functor p) =>
p y -> Metric y -> Metric y -> Metric y
convolveMetric ([]::[y]) Norm (Needle y)
ey Metric (Needle y)
eδ

instance Refinable ℝ where
  refineShade' :: Shade' ℝ -> Shade' ℝ -> Maybe (Shade' ℝ)
refineShade' (Shade' ℝ
cl Metric ℝ
el) (Shade' ℝ
cr Metric ℝ
er)
         = case (forall v. LSpace v => Seminorm v -> v -> Scalar v
normSq Metric ℝ
el ℝ
1, forall v. LSpace v => Seminorm v -> v -> Scalar v
normSq Metric ℝ
er ℝ
1) of
             (Scalar ℝ
0, Scalar ℝ
_) -> 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 x. x -> Metric x -> Shade' x
Shade' ℝ
cr Metric ℝ
er
             (Scalar ℝ
_, Scalar ℝ
0) -> 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 x. x -> Metric x -> Shade' x
Shade' ℝ
cl Metric ℝ
el
             (Scalar ℝ
ql,Scalar ℝ
qr) | Scalar ℝ
qlforall a. Ord a => a -> a -> Bool
>Scalar ℝ
0, Scalar ℝ
qrforall a. Ord a => a -> a -> Bool
>Scalar ℝ
0
                    -> let [ℝ
rl,ℝ
rr] = forall a. Floating a => a -> a
sqrt 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. Fractional a => a -> a
recip forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> [Scalar ℝ
ql,Scalar ℝ
qr]
                           b :: ℝ
b = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (-) [ℝ
cl,ℝ
cr] [ℝ
rl,ℝ
rr]
                           t :: ℝ
t = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Num a => a -> a -> a
(+) [ℝ
cl,ℝ
cr] [ℝ
rl,ℝ
rr]
                       in forall (m :: * -> *) (k :: * -> * -> *).
(MonadPlus m k, Arrow k (->), Function k, UnitObject k ~ (),
 Object k Bool) =>
k Bool (m ())
guard (ℝ
bforall a. Ord a => a -> a -> Bool
<ℝ
t) forall (k :: * -> * -> *) (m :: * -> *) b a.
(WellPointed k, Monad m k, ObjectPair k b (UnitObject k),
 ObjectPair k (m b) (UnitObject k),
 ObjectPair k (UnitObject k) (m b), ObjectPair k b a,
 ObjectPair k a b, Object k (m (a, b)), ObjectPair k (m a) (m b),
 ObjectPoint k (m a)) =>
m a -> k (m b) (m b)
>>
                           let cm :: ℝ
cm = (ℝ
bforall a. Num a => a -> a -> a
+ℝ
t)forall a. Fractional a => a -> a -> a
/ℝ
2
                               rm :: ℝ
rm = (ℝ
tforall a. Num a => a -> a -> a
-ℝ
b)forall a. Fractional a => a -> a -> a
/ℝ
2
                           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
$ forall x. x -> Metric x -> Shade' x
Shade' ℝ
cm (forall v. LSpace v => [DualVector v] -> Seminorm v
spanNorm [forall a. Fractional a => a -> a
recip ℝ
rm])
--   convolveShade' (Shade' y₀ ey) (Shade' δ₀ eδ)
--          = case (metricSq ey 1, metricSq eδ 1) of
--              (wy,wδ) | wy>0, wδ>0
--                  -> Shade' (y₀.+~^δ₀)
--                            ( projector . recip
--                                   $ recip (sqrt wy) + recip (sqrt wδ) )
--              (_ , _) -> Shade' y₀ zeroV

instance ∀ a b . ( Refinable a, Refinable b
                 , Scalar (DualVector (DualVector (Needle b)))
                      ~ Scalar (DualVector (DualVector (Needle a))) )
    => Refinable (a,b) where
  debugView :: Maybe (DebugView (a, b))
debugView = case ( forall y. Refinable y => Maybe (DebugView y)
debugView :: Maybe (DebugView a)
                   , forall y. Refinable y => Maybe (DebugView y)
debugView :: Maybe (DebugView b)
                   , forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualSpaceWitness (Needle a)
                   , forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualSpaceWitness (Needle b) ) of
      (Just DebugView a
DebugView, Just DebugView b
DebugView, DualSpaceWitness (Needle a)
DualSpaceWitness, DualSpaceWitness (Needle b)
DualSpaceWitness)
              -> forall a. a -> Maybe a
Just forall x.
(Show x, Show (Needle x +> Needle' x), LinearShowable (Needle x),
 Needle' x ~ Needle x) =>
DebugView x
DebugView
  
instance Refinable ℝ⁰
instance Refinable ℝ¹
instance Refinable ℝ²
instance Refinable ℝ³
instance Refinable ℝ⁴
                            
instance ( SimpleSpace a, SimpleSpace b
         , Refinable a, Refinable b
         , Scalar a ~ ℝ, Scalar b ~ ℝ
         , Scalar (DualVector a) ~ ℝ, Scalar (DualVector b) ~ ℝ
         , Scalar (DualVector (DualVector a)) ~ ℝ, Scalar (DualVector (DualVector b)) ~ ℝ )
            => Refinable (LinearMap ℝ a b) where
  debugView :: Maybe (DebugView (LinearMap ℝ a b))
debugView = forall a. Maybe a
Nothing

intersectShade's :: ∀ y . Refinable y => NonEmpty (Shade' y) -> Maybe (Shade' y)
intersectShade's :: forall y. Refinable y => NonEmpty (Shade' y) -> Maybe (Shade' y)
intersectShade's (Shade' y
sh:|[Shade' y]
shs) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
Hask.foldrM forall y. Refinable y => Shade' y -> Shade' y -> Maybe (Shade' y)
refineShade' Shade' y
sh [Shade' y]
shs










-- | Essentially the same as @(x,y)@, but not considered as a product topology.
--   The 'Semimanifold' etc. instances just copy the topology of @x@, ignoring @y@.
data x`WithAny`y
      = WithAny { forall x y. WithAny x y -> y
_untopological :: y
                , forall x y. WithAny x y -> x
_topological :: !x  }
 deriving (forall a b. a -> WithAny x b -> WithAny x a
forall a b. (a -> b) -> WithAny x a -> WithAny x b
forall x a b. a -> WithAny x b -> WithAny x a
forall x a b. (a -> b) -> WithAny x a -> WithAny x b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> WithAny x b -> WithAny x a
$c<$ :: forall x a b. a -> WithAny x b -> WithAny x a
fmap :: forall a b. (a -> b) -> WithAny x a -> WithAny x b
$cfmap :: forall x a b. (a -> b) -> WithAny x a -> WithAny x b
Hask.Functor, Int -> WithAny x y -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall x y. (Show y, Show x) => Int -> WithAny x y -> ShowS
forall x y. (Show y, Show x) => [WithAny x y] -> ShowS
forall x y. (Show y, Show x) => WithAny x y -> String
showList :: [WithAny x y] -> ShowS
$cshowList :: forall x y. (Show y, Show x) => [WithAny x y] -> ShowS
show :: WithAny x y -> String
$cshow :: forall x y. (Show y, Show x) => WithAny x y -> String
showsPrec :: Int -> WithAny x y -> ShowS
$cshowsPrec :: forall x y. (Show y, Show x) => Int -> WithAny x y -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall x y x. Rep (WithAny x y) x -> WithAny x y
forall x y x. WithAny x y -> Rep (WithAny x y) x
$cto :: forall x y x. Rep (WithAny x y) x -> WithAny x y
$cfrom :: forall x y x. WithAny x y -> Rep (WithAny x y) x
Generic)

instance (NFData x, NFData y) => NFData (WithAny x y)

instance ∀ x y . (Semimanifold x) => Semimanifold (x`WithAny`y) where
  type Needle (WithAny x y) = Needle x
  WithAny y
y x
x .+~^ :: WithAny x y -> Needle (WithAny x y) -> WithAny x y
.+~^ Needle (WithAny x y)
δx = forall x y. y -> x -> WithAny x y
WithAny y
y forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ x
xforall x. Semimanifold x => x -> Needle x -> x
.+~^Needle (WithAny x y)
δx
  semimanifoldWitness :: SemimanifoldWitness (WithAny x y)
semimanifoldWitness = case forall x. Semimanifold x => SemimanifoldWitness x
semimanifoldWitness :: SemimanifoldWitness x of
      SemimanifoldWitness x
SemimanifoldWitness -> forall x.
(Semimanifold (Needle x), Needle (Needle x) ~ Needle x) =>
SemimanifoldWitness x
SemimanifoldWitness
            
instance (PseudoAffine x) => PseudoAffine (x`WithAny`y) where
  WithAny y
_ x
x .-~! :: HasCallStack => WithAny x y -> WithAny x y -> Needle (WithAny x y)
.-~! WithAny y
_ x
ξ = x
xforall x. (PseudoAffine x, HasCallStack) => x -> x -> Needle x
.-~!x
ξ
  WithAny y
_ x
x .-~. :: WithAny x y -> WithAny x y -> Maybe (Needle (WithAny x y))
.-~. WithAny y
_ x
ξ = x
xforall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
ξ
  pseudoAffineWitness :: PseudoAffineWitness (WithAny x y)
pseudoAffineWitness = case forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness :: PseudoAffineWitness x of
      PseudoAffineWitness (SemimanifoldWitness x
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 (AffineSpace x) => AffineSpace (x`WithAny`y) where
  type Diff (WithAny x y) = Diff x
  WithAny y
_ x
x .-. :: WithAny x y -> WithAny x y -> Diff (WithAny x y)
.-. WithAny y
_ x
ξ = x
xforall p. AffineSpace p => p -> p -> Diff p
.-.x
ξ
  WithAny y
y x
x .+^ :: WithAny x y -> Diff (WithAny x y) -> WithAny x y
.+^ Diff (WithAny x y)
δx = forall x y. y -> x -> WithAny x y
WithAny y
y forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ x
xforall p. AffineSpace p => p -> Diff p -> p
.+^Diff (WithAny x y)
δx 

instance (VectorSpace x, Monoid y) => VectorSpace (x`WithAny`y) where
  type Scalar (WithAny x y) = Scalar x
  Scalar (WithAny x y)
μ *^ :: Scalar (WithAny x y) -> WithAny x y -> WithAny x y
*^ WithAny y
y x
x = forall x y. y -> x -> WithAny x y
WithAny y
y forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Scalar (WithAny x y)
μforall v. VectorSpace v => Scalar v -> v -> v
*^x
x 

instance (AdditiveGroup x, Monoid y) => AdditiveGroup (x`WithAny`y) where
  zeroV :: WithAny x y
zeroV = forall x y. y -> x -> WithAny x y
WithAny forall a. Monoid a => a
mempty forall v. AdditiveGroup v => v
zeroV
  negateV :: WithAny x y -> WithAny x y
negateV (WithAny y
y x
x) = forall x y. y -> x -> WithAny x y
WithAny y
y forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall v. AdditiveGroup v => v -> v
negateV x
x
  WithAny y
y x
x ^+^ :: WithAny x y -> WithAny x y -> WithAny x y
^+^ WithAny y
υ x
ξ = forall x y. y -> x -> WithAny x y
WithAny (forall a. Monoid a => a -> a -> a
mappend y
y y
υ) (x
xforall v. AdditiveGroup v => v -> v -> v
^+^x
ξ)

instance (AdditiveGroup x) => Hask.Applicative (WithAny x) where
  pure :: forall a. a -> WithAny x a
pure a
x = forall x y. y -> x -> WithAny x y
WithAny a
x forall v. AdditiveGroup v => v
zeroV
  WithAny a -> b
f x
x <*> :: forall a b. WithAny x (a -> b) -> WithAny x a -> WithAny x b
<*> WithAny a
t x
ξ = forall x y. y -> x -> WithAny x y
WithAny (a -> b
f a
t) (x
xforall v. AdditiveGroup v => v -> v -> v
^+^x
ξ)
  
instance (AdditiveGroup x) => Hask.Monad (WithAny x) where
  return :: forall a. a -> WithAny x a
return a
x = forall x y. y -> x -> WithAny x y
WithAny a
x forall v. AdditiveGroup v => v
zeroV
  WithAny a
y x
x >>= :: forall a b. WithAny x a -> (a -> WithAny x b) -> WithAny x b
>>= a -> WithAny x b
f = forall x y. y -> x -> WithAny x y
WithAny b
r forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ x
xforall v. AdditiveGroup v => v -> v -> v
^+^x
q
   where WithAny b
r x
q = a -> WithAny x b
f a
y

shadeWithAny :: y -> Shade x -> Shade (x`WithAny`y)
shadeWithAny :: forall y x. y -> Shade x -> Shade (WithAny x y)
shadeWithAny y
y (Shade x
x Metric' x
xe) = forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade (forall x y. y -> x -> WithAny x y
WithAny y
y x
x) Metric' x
xe

shadeWithoutAnything :: Semimanifold x => Shade (x`WithAny`y) -> Shade x
shadeWithoutAnything :: forall x y. Semimanifold x => Shade (WithAny x y) -> Shade x
shadeWithoutAnything (Shade (WithAny y
_ x
b) Metric' (WithAny x y)
e) = forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade x
b Metric' (WithAny x y)
e

                      




extractJust :: (a->Maybe b) -> [a] -> (Maybe b, [a])
extractJust :: forall a b. (a -> Maybe b) -> [a] -> (Maybe b, [a])
extractJust a -> Maybe b
f [] = (forall a. Maybe a
Nothing,[])
extractJust a -> Maybe b
f (a
x:[a]
xs) | Just b
r <- a -> Maybe b
f a
x  = (forall a. a -> Maybe a
Just b
r, [a]
xs)
                     | Bool
otherwise      = forall (a :: * -> * -> *) d b c.
(Morphism a, ObjectPair a d b, ObjectPair a d c) =>
a b c -> a (d, b) (d, c)
second (a
xforall a. a -> [a] -> [a]
:) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> (Maybe b, [a])
extractJust a -> Maybe b
f [a]
xs


prettyShowShade' :: LtdErrorShow x => Shade' x -> String
prettyShowShade' :: forall x. LtdErrorShow x => Shade' x -> String
prettyShowShade' Shade' x
sh = forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
prettyShowsPrecShade' Int
0 Shade' x
sh []

instance LtdErrorShow x => SP.Show (Shade' x) where
  showsPrec :: Int -> Shade' x -> ShowS
showsPrec = forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
prettyShowsPrecShade'
instance LtdErrorShow x => SP.Show (Shade x) where
  showsPrec :: Int -> Shade x -> ShowS
showsPrec = forall x. LtdErrorShow x => Int -> Shade x -> ShowS
prettyShowsPrecShade


wellDefinedShade' :: LinearSpace (Needle x) => Shade' x -> Maybe (Shade' x)
wellDefinedShade' :: forall x. LinearSpace (Needle x) => Shade' x -> Maybe (Shade' x)
wellDefinedShade' (Shade' x
c Norm (Needle x)
e) = forall x. x -> Metric x -> Shade' x
Shade' x
c forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> forall v. LinearSpace v => Norm v -> Maybe (Norm v)
wellDefinedNorm Norm (Needle x)
e



data LtdErrorShowWitness m where
   LtdErrorShowWitness :: (LtdErrorShow m, LtdErrorShow (Needle m))
                  => PseudoAffineWitness m -> LtdErrorShowWitness m

class Refinable m => LtdErrorShow m where
  ltdErrorShowWitness :: LtdErrorShowWitness m
  default ltdErrorShowWitness :: (LtdErrorShow m, LtdErrorShow (Needle m))
                         => LtdErrorShowWitness m
  ltdErrorShowWitness = forall m.
(LtdErrorShow m, LtdErrorShow (Needle m)) =>
PseudoAffineWitness m -> LtdErrorShowWitness m
LtdErrorShowWitness forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness
  showsPrecShade'_errorLtdC :: Int -> Shade' m -> ShowS
  prettyShowsPrecShade :: Int -> Shade m -> ShowS
  prettyShowsPrecShade Int
p sh :: Shade m
sh@(Shade m
c Metric' m
e')
              = Bool -> ShowS -> ShowS
showParen (Int
pforall a. Ord a => a -> a -> Bool
>Int
6) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ ShowS
v
                   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
. (String
":±["forall a. [a] -> [a] -> [a]
++) 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 c. (a -> b -> c) -> b -> a -> c
flip (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id) (forall a. a -> [a] -> [a]
intersperse (Char
','forall a. a -> [a] -> [a]
:) [ShowS]
u) 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
. (Char
']'forall a. a -> [a] -> [a]
:)
   where v :: ShowS
v = forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
showsPrecShade'_errorLtdC Int
6 (forall x. x -> Metric x -> Shade' x
Shade' m
c Norm (Needle m)
e :: Shade' m)
         [ShowS]
u :: [ShowS] = case forall m. LtdErrorShow m => LtdErrorShowWitness m
ltdErrorShowWitness :: LtdErrorShowWitness m of
           LtdErrorShowWitness (PseudoAffineWitness SemimanifoldWitness m
SemimanifoldWitness) ->
             [ forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
showsPrecShade'_errorLtdC Int
6 (forall x. x -> Metric x -> Shade' x
Shade' Needle m
δ Norm (Needle m)
e :: Shade' (Needle m))
             | Needle m
δ <- forall v. SimpleSpace v => Variance v -> [v]
varianceSpanningSystem Metric' m
e']
         e :: Norm (Needle m)
e = forall v. SimpleSpace v => Variance v -> Norm v
dualNorm' Metric' m
e'
  prettyShowsPrecShade' :: Int -> Shade' m -> ShowS
  prettyShowsPrecShade' Int
p sh :: Shade' m
sh@(Shade' m
c Norm (Needle m)
e)
              = Bool -> ShowS -> ShowS
showParen (Int
pforall a. Ord a => a -> a -> Bool
>Int
6) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ ShowS
v
                   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
. (String
"|±|["forall a. [a] -> [a] -> [a]
++) 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 c. (a -> b -> c) -> b -> a -> c
flip (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id) (forall a. a -> [a] -> [a]
intersperse (Char
','forall a. a -> [a] -> [a]
:) [ShowS]
u) 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
. (Char
']'forall a. a -> [a] -> [a]
:)
   where v :: ShowS
v = forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
showsPrecShade'_errorLtdC Int
6 Shade' m
sh
         [ShowS]
u :: [ShowS] = case forall m. LtdErrorShow m => LtdErrorShowWitness m
ltdErrorShowWitness :: LtdErrorShowWitness m of
           LtdErrorShowWitness (PseudoAffineWitness SemimanifoldWitness m
SemimanifoldWitness) ->
             [ forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
showsPrecShade'_errorLtdC Int
6 (forall x. x -> Metric x -> Shade' x
Shade' Needle m
δ Norm (Needle m)
e :: Shade' (Needle m))
             | Needle m
δ <- forall v. SimpleSpace v => Variance v -> [v]
varianceSpanningSystem Metric' m
e']
         e' :: Metric' m
e' = forall v. SimpleSpace v => Norm v -> Variance v
dualNorm Norm (Needle m)
e

instance LtdErrorShow ℝ⁰ where
  showsPrecShade'_errorLtdC :: Int -> Shade' ℝ⁰ -> ShowS
showsPrecShade'_errorLtdC Int
_ Shade' ℝ⁰
_ = (String
"zeroV"forall a. [a] -> [a] -> [a]
++)
instance LtdErrorShow ℝ where
  showsPrecShade'_errorLtdC :: Int -> Shade' ℝ -> ShowS
showsPrecShade'_errorLtdC Int
_ (Shade' ℝ
v Metric ℝ
u) = forall n. RealFloat n => n -> n -> ShowS
errorLtdShow (ℝ
δforall a. Fractional a => a -> a -> a
/ℝ
2) ℝ
v
   where δ :: ℝ
δ = case Metric ℝ
uforall v. LSpace v => Norm v -> v -> DualVector v
<$|ℝ
1 of
          DualVector ℝ
σ | DualVector ℝ
σforall a. Ord a => a -> a -> Bool
>ℝ
0 -> forall a. Floating a => a -> a
sqrt forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ ℝ
1forall a. Fractional a => a -> a -> a
/DualVector ℝ
σ
          DualVector ℝ
_       -> ℝ
vforall a. Num a => a -> a -> a
*ℝ
10
instance LtdErrorShow ℝ² where
  showsPrecShade'_errorLtdC :: Int -> Shade' ℝ² -> ShowS
showsPrecShade'_errorLtdC Int
_ Shade' ℝ²
sh = (String
"V2 "forall a. [a] -> [a] -> [a]
++) 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
. ShowS
shshx 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
. (Char
' 'forall a. a -> [a] -> [a]
:) 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
. ShowS
shshy
   where shx :: Shade' ℝ
shx = 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 (k :: * -> * -> *) x c s.
(Num' s, LinearSpace x, LinearSpace c, Object k x, Object k c,
 Scalar x ~ s, Scalar c ~ s, EnhancedCat k (LinearMap s)) =>
Lens' x c -> Embedding k c x
lensEmbedding forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x) Shade' ℝ²
sh :: Shade' ℝ
         shy :: Shade' ℝ
shy = 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 (k :: * -> * -> *) x c s.
(Num' s, LinearSpace x, LinearSpace c, Object k x, Object k c,
 Scalar x ~ s, Scalar c ~ s, EnhancedCat k (LinearMap s)) =>
Lens' x c -> Embedding k c x
lensEmbedding forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y) Shade' ℝ²
sh :: Shade' ℝ
         shshx :: ShowS
shshx = forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
showsPrecShade'_errorLtdC Int
0 Shade' ℝ
shx 
         shshy :: ShowS
shshy = forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
showsPrecShade'_errorLtdC Int
0 Shade' ℝ
shy 
instance LtdErrorShow ℝ³ where
  showsPrecShade'_errorLtdC :: Int -> Shade' ℝ³ -> ShowS
showsPrecShade'_errorLtdC Int
_ Shade' ℝ³
sh = (String
"V3 "forall a. [a] -> [a] -> [a]
++) 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
. ShowS
shshx 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
. (Char
' 'forall a. a -> [a] -> [a]
:) 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
. ShowS
shshy 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
. (Char
' 'forall a. a -> [a] -> [a]
:) 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
. ShowS
shshz
   where shx :: Shade' ℝ
shx = 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 (k :: * -> * -> *) x c s.
(Num' s, LinearSpace x, LinearSpace c, Object k x, Object k c,
 Scalar x ~ s, Scalar c ~ s, EnhancedCat k (LinearMap s)) =>
Lens' x c -> Embedding k c x
lensEmbedding forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x) Shade' ℝ³
sh :: Shade' ℝ
         shy :: Shade' ℝ
shy = 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 (k :: * -> * -> *) x c s.
(Num' s, LinearSpace x, LinearSpace c, Object k x, Object k c,
 Scalar x ~ s, Scalar c ~ s, EnhancedCat k (LinearMap s)) =>
Lens' x c -> Embedding k c x
lensEmbedding forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y) Shade' ℝ³
sh :: Shade' ℝ
         shz :: Shade' ℝ
shz = 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 (k :: * -> * -> *) x c s.
(Num' s, LinearSpace x, LinearSpace c, Object k x, Object k c,
 Scalar x ~ s, Scalar c ~ s, EnhancedCat k (LinearMap s)) =>
Lens' x c -> Embedding k c x
lensEmbedding forall (t :: * -> *) a. R3 t => Lens' (t a) a
_z) Shade' ℝ³
sh :: Shade' ℝ
         shshx :: ShowS
shshx = forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
showsPrecShade'_errorLtdC Int
0 Shade' ℝ
shx 
         shshy :: ShowS
shshy = forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
showsPrecShade'_errorLtdC Int
0 Shade' ℝ
shy 
         shshz :: ShowS
shshz = forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
showsPrecShade'_errorLtdC Int
0 Shade' ℝ
shz 
instance LtdErrorShow ℝ⁴ where
  showsPrecShade'_errorLtdC :: Int -> Shade' ℝ⁴ -> ShowS
showsPrecShade'_errorLtdC Int
_ Shade' ℝ⁴
sh
           = (String
"V4 "forall a. [a] -> [a] -> [a]
++) 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
. ShowS
shshx 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
. (Char
' 'forall a. a -> [a] -> [a]
:) 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
. ShowS
shshy 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
. (Char
' 'forall a. a -> [a] -> [a]
:) 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
. ShowS
shshz 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
. (Char
' 'forall a. a -> [a] -> [a]
:) 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
. ShowS
shshw
   where shx :: Shade' ℝ
shx = 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 (k :: * -> * -> *) x c s.
(Num' s, LinearSpace x, LinearSpace c, Object k x, Object k c,
 Scalar x ~ s, Scalar c ~ s, EnhancedCat k (LinearMap s)) =>
Lens' x c -> Embedding k c x
lensEmbedding forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x) Shade' ℝ⁴
sh :: Shade' ℝ
         shy :: Shade' ℝ
shy = 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 (k :: * -> * -> *) x c s.
(Num' s, LinearSpace x, LinearSpace c, Object k x, Object k c,
 Scalar x ~ s, Scalar c ~ s, EnhancedCat k (LinearMap s)) =>
Lens' x c -> Embedding k c x
lensEmbedding forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y) Shade' ℝ⁴
sh :: Shade' ℝ
         shz :: Shade' ℝ
shz = 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 (k :: * -> * -> *) x c s.
(Num' s, LinearSpace x, LinearSpace c, Object k x, Object k c,
 Scalar x ~ s, Scalar c ~ s, EnhancedCat k (LinearMap s)) =>
Lens' x c -> Embedding k c x
lensEmbedding forall (t :: * -> *) a. R3 t => Lens' (t a) a
_z) Shade' ℝ⁴
sh :: Shade' ℝ
         shw :: Shade' ℝ
shw = 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 (k :: * -> * -> *) x c s.
(Num' s, LinearSpace x, LinearSpace c, Object k x, Object k c,
 Scalar x ~ s, Scalar c ~ s, EnhancedCat k (LinearMap s)) =>
Lens' x c -> Embedding k c x
lensEmbedding forall (t :: * -> *) a. R4 t => Lens' (t a) a
_w) Shade' ℝ⁴
sh :: Shade' ℝ
         shshx :: ShowS
shshx = forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
showsPrecShade'_errorLtdC Int
0 Shade' ℝ
shx 
         shshy :: ShowS
shshy = forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
showsPrecShade'_errorLtdC Int
0 Shade' ℝ
shy 
         shshz :: ShowS
shshz = forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
showsPrecShade'_errorLtdC Int
0 Shade' ℝ
shz 
         shshw :: ShowS
shshw = forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
showsPrecShade'_errorLtdC Int
0 Shade' ℝ
shw 
instance ∀ x y .
         ( LtdErrorShow x, LtdErrorShow y
         , Scalar (DualVector (Needle' x)) ~ Scalar (DualVector (Needle' y)) )
              => LtdErrorShow (x,y) where
  ltdErrorShowWitness :: LtdErrorShowWitness (x, y)
ltdErrorShowWitness = case ( forall m. LtdErrorShow m => LtdErrorShowWitness m
ltdErrorShowWitness :: LtdErrorShowWitness x
                             , forall m. LtdErrorShow m => LtdErrorShowWitness m
ltdErrorShowWitness :: LtdErrorShowWitness y ) of
   (  LtdErrorShowWitness(PseudoAffineWitness(SemimanifoldWitness x
SemimanifoldWitness))
    , LtdErrorShowWitness(PseudoAffineWitness(SemimanifoldWitness y
SemimanifoldWitness)) )
    ->forall m.
(LtdErrorShow m, LtdErrorShow (Needle m)) =>
PseudoAffineWitness m -> LtdErrorShowWitness m
LtdErrorShowWitness(forall x.
PseudoAffine (Needle x) =>
SemimanifoldWitness x -> PseudoAffineWitness x
PseudoAffineWitness(forall x.
(Semimanifold (Needle x), Needle (Needle x) ~ Needle x) =>
SemimanifoldWitness x
SemimanifoldWitness))
  showsPrecShade'_errorLtdC :: Int -> Shade' (x, y) -> ShowS
showsPrecShade'_errorLtdC Int
_ Shade' (x, y)
sh = (Char
'('forall a. a -> [a] -> [a]
:) 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
. ShowS
shshx 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
. (Char
','forall a. a -> [a] -> [a]
:) 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
. ShowS
shshy 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
. (Char
')'forall a. a -> [a] -> [a]
:)
   where (Shade' x
shx,Shade' y
shy) = forall (shade :: * -> *) x y.
(IsShade shade, PseudoAffine x, SimpleSpace (Needle x),
 PseudoAffine y, SimpleSpace (Needle y),
 Scalar (Needle x) ~ Scalar (Needle y)) =>
shade (x, y) -> (shade x, shade y)
factoriseShade Shade' (x, y)
sh
         shshx :: ShowS
shshx = forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
showsPrecShade'_errorLtdC Int
0 Shade' x
shx 
         shshy :: ShowS
shshy = forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
showsPrecShade'_errorLtdC Int
0 Shade' y
shy 

instance ∀ v .
    (HilbertSpace v, SemiInner v, FiniteDimensional v, LtdErrorShow v, Scalar v ~ ℝ)
              => LtdErrorShow (LinearMap ℝ v ℝ) where
  showsPrecShade'_errorLtdC :: Int -> Shade' (LinearMap ℝ v ℝ) -> ShowS
showsPrecShade'_errorLtdC Int
p Shade' (LinearMap ℝ v ℝ)
sh = Bool -> ShowS -> ShowS
showParen (Int
pforall a. Ord a => a -> a -> Bool
>Int
7) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$
         (String
"().<"forall a. [a] -> [a] -> [a]
++) 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 m. LtdErrorShow m => Int -> Shade' m -> ShowS
showsPrecShade'_errorLtdC Int
7
                        (forall (shade :: * -> *) x y.
(IsShade shade, SimpleSpace x, SimpleSpace y, Scalar x ~ Scalar y,
 Num' (Scalar x)) =>
(x +> y) -> shade x -> shade y
linIsoTransformShade (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 v. LinearSpace v => (v +> Scalar v) -+> DualVector v
fromLinearForm) Shade' (LinearMap ℝ v ℝ)
sh :: Shade' v)
instance ∀ v .
    (HilbertSpace v, SemiInner v, FiniteDimensional v, LtdErrorShow v, Scalar v ~ ℝ)
              => LtdErrorShow (LinearMap ℝ v (ℝ,ℝ)) where
  showsPrecShade'_errorLtdC :: Int -> Shade' (LinearMap ℝ v (ℝ, ℝ)) -> ShowS
showsPrecShade'_errorLtdC Int
p Shade' (LinearMap ℝ v (ℝ, ℝ))
sh = Bool -> ShowS -> ShowS
showParen (Int
pforall a. Ord a => a -> a -> Bool
>Int
7) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$
         (   String
"Left ().<"forall a. [a] -> [a] -> [a]
++) 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 m. LtdErrorShow m => Int -> Shade' m -> ShowS
showsPrecShade'_errorLtdC Int
7 Shade' v
shx
       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
. (String
"^+^Right().<"forall a. [a] -> [a] -> [a]
++) 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 m. LtdErrorShow m => Int -> Shade' m -> ShowS
showsPrecShade'_errorLtdC Int
7 Shade' v
shy
   where (Shade' v
shx,Shade' v
shy) = forall (shade :: * -> *) x y.
(IsShade shade, PseudoAffine x, SimpleSpace (Needle x),
 PseudoAffine y, SimpleSpace (Needle y),
 Scalar (Needle x) ~ Scalar (Needle y)) =>
shade (x, y) -> (shade x, shade y)
factoriseShade
                        (forall (shade :: * -> *) x y.
(IsShade shade, SimpleSpace x, SimpleSpace y, Scalar x ~ Scalar y,
 Num' (Scalar x)) =>
(x +> y) -> shade x -> shade y
linIsoTransformShade (forall (f :: * -> * -> *) s u v.
(EnhancedCat f (LinearFunction s), LinearSpace u, TensorSpace v,
 Scalar u ~ s, Scalar v ~ s, Object f u, Object f v) =>
(u -> v) -> f u v
lfun forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \LinearMap ℝ v (ℝ, ℝ)
f
                                                -> ( forall v. LinearSpace v => (v +> Scalar v) -+> DualVector v
fromLinearForm forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst 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
. LinearMap ℝ v (ℝ, ℝ)
f
                                                   , forall v. LinearSpace v => (v +> Scalar v) -+> DualVector v
fromLinearForm forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd 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
. LinearMap ℝ v (ℝ, ℝ)
f ) ) Shade' (LinearMap ℝ v (ℝ, ℝ))
sh
                             :: Shade' (v,v))
        
                       
instance LtdErrorShow x => Show (Shade' x) where
  showsPrec :: Int -> Shade' x -> ShowS
showsPrec = forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
prettyShowsPrecShade'