-- |
-- 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))
           =>  { Shade x -> x
_shadeCtr :: !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' { Shade' x -> x
_shade'Ctr :: !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 :: (x +> y) -> Shade x -> Shade y
linearProjectShade = case ( LinearManifoldWitness x
forall v. TensorSpace v => LinearManifoldWitness v
linearManifoldWitness :: LinearManifoldWitness x
                          , LinearManifoldWitness y
forall v. TensorSpace v => LinearManifoldWitness v
linearManifoldWitness :: LinearManifoldWitness y
                          , DualSpaceWitness x
forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualSpaceWitness x
                          , DualSpaceWitness y
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) -> y -> Metric' y -> Shade y
forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade (LinearMap s x y
x +> y
f LinearMap s x y -> x -> y
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ x
x) ((x +> y) -> Variance x -> Variance y
forall v w.
(LSpace v, LSpace w, Scalar v ~ Scalar w) =>
(v +> w) -> Variance v -> Variance w
transformVariance x +> y
f Variance x
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)
✠ :: shade x -> shade y -> shade (x, 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 :: (x -> f x) -> Shade x -> f (Shade x)
shadeCtr x -> f x
f (Shade x
c Metric' x
e) = (x -> Shade x) -> f x -> f (Shade x)
forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (x -> Metric' x -> Shade x
forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
`Shade`Metric' x
e) (f x -> f (Shade x)) -> f x -> f (Shade x)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ x -> f x
f x
c
  occlusion :: Shade x -> x -> s
occlusion = PseudoAffineWitness x -> DualNeedleWitness x -> Shade x -> x -> s
forall x s.
(PseudoAffine x, SimpleSpace (Needle x), Scalar (Needle x) ~ s,
 RealFloat' s) =>
PseudoAffineWitness x -> DualNeedleWitness x -> Shade x -> x -> s
occ PseudoAffineWitness x
forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness DualNeedleWitness x
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 :: PseudoAffineWitness x -> DualNeedleWitness x -> Shade x -> x -> s
occ (PseudoAffineWitness SemimanifoldWitness x
SemimanifoldWitness) DualNeedleWitness x
DualSpaceWitness (Shade x
p₀ Metric' x
δ)
                 = \x
p -> case x
px -> x -> Maybe (Needle x)
forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
p₀ of
           (Just Needle x
vd) | Scalar (Needle x)
mSq <- Seminorm (Needle x) -> Needle x -> Scalar (Needle x)
forall v. LSpace v => Seminorm v -> v -> Scalar v
normSq Variance (DualVector (Needle x))
Seminorm (Needle x)
δinv Needle x
vd
                     , s
Scalar (Needle x)
mSq s -> s -> Bool
forall a. Eq a => a -> a -> Bool
== s
Scalar (Needle x)
mSq  -- avoid NaN
                     -> s -> s
forall a. Floating a => a -> a
exp (s -> s
forall a. Num a => a -> a
negate s
Scalar (Needle x)
mSq)
           Maybe (Needle x)
_         -> s
forall v. AdditiveGroup v => v
zeroV
          where δinv :: Variance (DualVector (Needle x))
δinv = Metric' x -> Variance (DualVector (Needle x))
forall v. SimpleSpace v => Norm v -> Variance v
dualNorm Metric' x
δ
  factoriseShade :: Shade (x, y) -> (Shade x, Shade y)
factoriseShade = DualNeedleWitness x
-> DualNeedleWitness y -> Shade (x, y) -> (Shade x, Shade y)
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 DualNeedleWitness x
forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness DualNeedleWitness y
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 :: DualNeedleWitness x
-> DualNeedleWitness y -> Shade (x, y) -> (Shade x, Shade y)
fs DualNeedleWitness x
DualSpaceWitness DualNeedleWitness y
DualSpaceWitness (Shade (x
x₀,y
y₀) Metric' (x, y)
δxy)
                   = (x -> Metric' x -> Shade x
forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade x
x₀ Metric' x
δx, y -> Metric' y -> Shade y
forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade y
y₀ Metric' y
δy)
          where (Metric' x
δx,Metric' y
δy) = Norm (DualVector (Needle x), DualVector (Needle y))
-> (Metric' x, Metric' y)
forall u v.
(SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v) =>
Norm (u, v) -> (Norm u, Norm v)
summandSpaceNorms Norm (DualVector (Needle x), DualVector (Needle y))
Metric' (x, y)
δxy
  orthoShades :: Shade x -> Shade y -> Shade (x, y)
orthoShades = DualNeedleWitness x
-> DualNeedleWitness y -> Shade x -> Shade y -> Shade (x, y)
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 DualNeedleWitness x
forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness DualNeedleWitness y
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 :: DualNeedleWitness x
-> DualNeedleWitness y -> Shade x -> Shade y -> Shade (x, y)
fs DualNeedleWitness x
DualSpaceWitness DualNeedleWitness y
DualSpaceWitness (Shade x
x Metric' x
δx) (Shade y
y Metric' y
δy)
             = (x, y) -> Metric' (x, y) -> Shade (x, y)
forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade (x
x,y
y) (Norm (DualVector (Needle x), DualVector (Needle y))
 -> Shade (x, y))
-> Norm (DualVector (Needle x), DualVector (Needle y))
-> Shade (x, y)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Metric' x
-> Metric' y -> Norm (DualVector (Needle x), DualVector (Needle y))
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 :: Shade x -> Shade y
coerceShade = DualNeedleWitness x -> DualNeedleWitness y -> Shade x -> Shade y
forall x y.
(LocallyCoercible x y, SimpleSpace (Needle y)) =>
DualNeedleWitness x -> DualNeedleWitness y -> Shade x -> Shade y
cS DualNeedleWitness x
forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness DualNeedleWitness y
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 :: DualNeedleWitness x -> DualNeedleWitness y -> Shade x -> Shade y
cS DualNeedleWitness x
DualSpaceWitness DualNeedleWitness y
DualSpaceWitness
                    = \(Shade x
x Metric' x
δxym)
                         -> y -> Metric' y -> Shade y
forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade (x -> y
forall x ξ. LocallyCoercible x ξ => x -> ξ
locallyTrivialDiffeomorphism x
x) (Metric' x -> Metric' y
tN Metric' x
δxym)
          where tN :: Metric' x -> Metric' y
tN = case CanonicalDiffeomorphism y x
forall x ξ. LocallyCoercible x ξ => CanonicalDiffeomorphism ξ x
oppositeLocalCoercion :: CanonicalDiffeomorphism y x of
                      CanonicalDiffeomorphism y x
CanonicalDiffeomorphism ->
                       LinearMap
  (Scalar (DualVector (Needle y)))
  (DualVector (Needle y))
  (DualVector (Needle x))
-> Metric' x -> Metric' y
forall v w.
(LSpace v, LSpace w, Scalar v ~ Scalar w) =>
(v +> w) -> Norm w -> Norm v
transformNorm (LinearMap
   (Scalar (DualVector (Needle y)))
   (DualVector (Needle y))
   (DualVector (Needle x))
 -> Metric' x -> Metric' y)
-> (LinearFunction
      (Scalar (Needle y)) (DualVector (Needle y)) (DualVector (Needle x))
    -> LinearMap
         (Scalar (DualVector (Needle y)))
         (DualVector (Needle y))
         (DualVector (Needle x)))
-> LinearFunction
     (Scalar (Needle y)) (DualVector (Needle y)) (DualVector (Needle x))
-> Metric' x
-> Metric' y
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. LinearFunction
  (Scalar (Needle y)) (DualVector (Needle y)) (DualVector (Needle x))
-> LinearMap
     (Scalar (DualVector (Needle y)))
     (DualVector (Needle y))
     (DualVector (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 (LinearFunction
   (Scalar (Needle y)) (DualVector (Needle y)) (DualVector (Needle x))
 -> Metric' x -> Metric' y)
-> LinearFunction
     (Scalar (Needle y)) (DualVector (Needle y)) (DualVector (Needle x))
-> Metric' x
-> Metric' y
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ [(y, x)] -> DualVector (Needle y) -+> DualVector (Needle x)
forall x ξ (p :: * -> *).
(LocallyCoercible x ξ, Functor p) =>
p (x, ξ) -> Needle' x -+> Needle' ξ
coerceNeedle' ([]::[(y,x)])
  linIsoTransformShade :: (x +> y) -> Shade x -> Shade y
linIsoTransformShade = LinearManifoldWitness x
-> LinearManifoldWitness y
-> DualSpaceWitness x
-> DualSpaceWitness y
-> (x +> y)
-> Shade x
-> Shade y
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
forall v. TensorSpace v => LinearManifoldWitness v
linearManifoldWitness LinearManifoldWitness y
forall v. TensorSpace v => LinearManifoldWitness v
linearManifoldWitness
                              DualSpaceWitness x
forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness DualSpaceWitness y
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 :: 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)
                  = y -> Metric' y -> Shade y
forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade (x +> y
LinearMap (Scalar y) x y
f LinearMap (Scalar y) x y -> x -> y
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ x
x) ((DualVector y +> DualVector x)
-> Norm (DualVector x) -> Norm (DualVector y)
forall v w.
(LSpace v, LSpace w, Scalar v ~ Scalar w) =>
(v +> w) -> Norm w -> Norm v
transformNorm (LinearFunction
  (Scalar (DualVector y))
  (LinearMap (Scalar x) x (DualVector (DualVector y)))
  (DualVector y +> DualVector x)
forall v w.
(LinearSpace v, LinearSpace w, Scalar v ~ Scalar w) =>
(v +> DualVector w) -+> (w +> DualVector v)
adjoint LinearFunction
  (Scalar (DualVector y))
  (LinearMap (Scalar x) x (DualVector (DualVector y)))
  (DualVector y +> DualVector x)
-> LinearMap (Scalar x) x (DualVector (DualVector y))
-> DualVector y +> DualVector x
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ x +> y
LinearMap (Scalar x) x (DualVector (DualVector y))
f) Norm (DualVector x)
Metric' x
δx)
  embedShade :: Embedding (Affine s) x y -> Shade x -> Shade y
embedShade = (SemimanifoldWitness x, SemimanifoldWitness y)
-> Embedding (Affine s) x y -> Shade x -> Shade y
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
forall x. Semimanifold x => SemimanifoldWitness x
semimanifoldWitness, SemimanifoldWitness y
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' :: (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) = y -> Metric' y -> Shade y
forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade y
y ((Needle x +> Needle y) -> Metric' x -> Metric' 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)
Needle x +> Needle y
j Metric' x
e)
          where y :: y
y = Affine s x y
q Affine s x y -> x -> y
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) = Affine s x y -> x -> (y, LinearMap s (Needle x) (Needle y))
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 :: Embedding (Affine s) x y -> Shade y -> Shade x
projectShade = (SemimanifoldWitness x, SemimanifoldWitness y)
-> Embedding (Affine s) x y -> Shade y -> Shade x
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
forall x. Semimanifold x => SemimanifoldWitness x
semimanifoldWitness, SemimanifoldWitness y
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' :: (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) = x -> Metric' x -> Shade x
forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade x
y ((Needle y +> Needle x) -> Metric' y -> Metric' x
forall v w.
(LSpace v, LSpace w, Scalar v ~ Scalar w) =>
(v +> w) -> Variance v -> Variance w
transformVariance LinearMap s (Needle y) (Needle x)
Needle y +> Needle x
j Metric' y
e)
          where y :: x
y = Affine s y x
q Affine s y x -> y -> x
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) = Affine s y x -> y -> (x, LinearMap s (Needle y) (Needle x))
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 :: Shade x -> Shade' x
dualShade = case DualSpaceWitness (Needle x)
forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualSpaceWitness (Needle x) of
    DualSpaceWitness (Needle x)
DualSpaceWitness -> \(Shade x
c Metric' x
e) -> x -> Norm (Needle x) -> Shade' x
forall x. x -> Metric x -> Shade' x
Shade' x
c (Norm (Needle x) -> Shade' x) -> Norm (Needle x) -> Shade' x
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Metric' x -> Variance (DualVector (Needle x))
forall v. SimpleSpace v => Norm v -> Variance v
dualNorm Metric' x
e

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

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

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

newtype ShadeNeedle x = ShadeNeedle { 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
(.+~^) = 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 SemimanifoldWitness x
forall x. Semimanifold x => SemimanifoldWitness x
semimanifoldWitness :: SemimanifoldWitness x of
             SemimanifoldWitness x
SemimanifoldWitness
                   -> \(Shade x
c Metric' x
e) (ShadeNeedle v) -> x -> Metric' x -> Shade x
forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade (x
cx -> Needle x -> x
forall x. Semimanifold x => x -> Needle x -> x
.+~^Needle x
v) Metric' x
e
  .-~^ :: Shade x -> Needle (Shade x) -> Shade x
(.-~^) = case SemimanifoldWitness x
forall x. Semimanifold x => SemimanifoldWitness x
semimanifoldWitness :: SemimanifoldWitness x of
             SemimanifoldWitness x
SemimanifoldWitness
                   -> \(Shade x
c Metric' x
e) (ShadeNeedle v) -> x -> Metric' x -> Shade x
forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade (x
cx -> Needle x -> x
forall x. Semimanifold x => x -> Needle x -> x
.-~^Needle x
v) Metric' x
e
  semimanifoldWitness :: SemimanifoldWitness (Shade x)
semimanifoldWitness = case SemimanifoldWitness x
forall x. Semimanifold x => SemimanifoldWitness x
semimanifoldWitness :: SemimanifoldWitness x of
                         (SemimanifoldWitness x
SemimanifoldWitness)
                          -> SemimanifoldWitness (Shade x)
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 = ShadeHalfNeedle x
forall a. HasCallStack => a
undefined
  addHVs :: ShadeHalfNeedle x -> ShadeHalfNeedle x -> ShadeHalfNeedle x
addHVs = ShadeHalfNeedle x -> ShadeHalfNeedle x -> ShadeHalfNeedle x
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 = Ray (ShadeHalfNeedle x) -> ShadeHalfNeedle x -> ShadeHalfNeedle x
forall a. HasCallStack => a
undefined
  fromFullSubspace :: FullSubspace (ShadeHalfNeedle x) -> ShadeHalfNeedle x
fromFullSubspace = FullSubspace (ShadeHalfNeedle x) -> ShadeHalfNeedle x
forall a. HasCallStack => a
undefined
  projectToFullSubspace :: ShadeHalfNeedle x -> FullSubspace (ShadeHalfNeedle x)
projectToFullSubspace = ShadeHalfNeedle x -> FullSubspace (ShadeHalfNeedle x)
forall a. HasCallStack => a
undefined
  fullSubspaceIsVectorSpace :: ((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
_ = r
forall a. HasCallStack => a
undefined
  rayIsHalfSpace :: (HalfSpace (Ray (ShadeHalfNeedle x)) => r) -> r
rayIsHalfSpace HalfSpace (Ray (ShadeHalfNeedle x)) => r
_ = r
forall a. HasCallStack => a
undefined
  mirrorJoinIsVectorSpace :: ((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
_ = r
forall a. HasCallStack => a
undefined
  fromPositiveHalf :: ShadeHalfNeedle x -> MirrorJoin (ShadeHalfNeedle x)
fromPositiveHalf = ShadeHalfNeedle x -> MirrorJoin (ShadeHalfNeedle x)
forall a. HasCallStack => a
undefined
  fromNegativeHalf :: ShadeHalfNeedle x -> MirrorJoin (ShadeHalfNeedle x)
fromNegativeHalf = ShadeHalfNeedle x -> MirrorJoin (ShadeHalfNeedle x)
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 = Interior (Shade x)
-> Needle (Interior (Shade x)) -> Maybe (Boundary (Shade x))
forall a. HasCallStack => a
undefined
  smfdWBoundWitness :: SmfdWBoundWitness (Shade x)
smfdWBoundWitness = SmfdWBoundWitness (Shade x)
forall a. HasCallStack => a
undefined
  needleIsOpenMfd :: (OpenManifold (Needle (Interior (Shade x))) => r) -> r
needleIsOpenMfd OpenManifold (Needle (Interior (Shade x))) => r
_ = r
forall a. HasCallStack => a
undefined
  scalarIsOpenMfd :: (OpenManifold (Scalar (Needle (Interior (Shade x)))) => r) -> r
scalarIsOpenMfd OpenManifold (Scalar (Needle (Interior (Shade x)))) => r
_ = 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 DualNeedleWitness x
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)
η)) = (D¹ -> Shade x) -> Maybe (D¹ -> Shade 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) = x -> Norm (Needle' x) -> Shade x
forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade (D¹ -> x
pinterp D¹
t)
                                 (LinearFunction
  (Scalar (Needle x)) (Needle' x) (DualVector (Needle' x))
-> Norm (Needle' x)
forall v. (v -+> DualVector v) -> Norm v
Norm (LinearFunction
   (Scalar (Needle x)) (Needle' x) (DualVector (Needle' x))
 -> Norm (Needle' x))
-> (ℝ
    -> LinearFunction
         (Scalar (Needle x)) (Needle' x) (DualVector (Needle' x)))
-> ℝ
-> Norm (Needle' x)
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. LinearMap ℝ (Needle' x) (Needle x)
-> LinearFunction
     (Scalar (Needle x)) (Needle' x) (DualVector (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 (LinearMap ℝ (Needle' x) (Needle x)
 -> LinearFunction
      (Scalar (Needle x)) (Needle' x) (DualVector (Needle' x)))
-> (ℝ -> LinearMap ℝ (Needle' x) (Needle x))
-> ℝ
-> LinearFunction
     (Scalar (Needle x)) (Needle' x) (DualVector (Needle' x))
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. LinearMap ℝ (Needle' x) (Needle x)
-> LinearMap ℝ (Needle' x) (Needle x)
-> Scalar (LinearMap ℝ (Needle' x) (Needle x))
-> LinearMap ℝ (Needle' x) (Needle x)
forall v. VectorSpace v => v -> v -> Scalar v -> v
lerp LinearMap ℝ (Needle' x) (Needle x)
ed LinearMap ℝ (Needle' x) (Needle x)
ηd (ℝ -> Norm (Needle' x)) -> ℝ -> Norm (Needle' x)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (ℝ
qℝ -> ℝ -> ℝ
forall 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)
_) = LinearFunction ℝ (Needle' x) (Needle x)
-> LinearMap ℝ (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 LinearFunction ℝ (Needle' x) (Needle x)
Needle' x -+> DualVector (Needle' x)
e
                ηd :: LinearMap ℝ (Needle' x) (Needle x)
ηd@(LinearMap TensorProduct (DualVector (Needle' x)) (Needle x)
_) = LinearFunction ℝ (Needle' x) (Needle x)
-> LinearMap ℝ (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 LinearFunction ℝ (Needle' x) (Needle x)
Needle' x -+> DualVector (Needle' x)
η
                Just D¹ -> x
pinterp = x -> x -> Maybe (D¹ -> x)
forall x. Geodesic x => x -> x -> Maybe (D¹ -> x)
geodesicBetween x
c x
ζ

newtype Shade'Needle x = Shade'Needle { 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
(.+~^) = 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 v = x -> Metric x -> Shade' x
forall x. x -> Metric x -> Shade' x
Shade' (x
cx -> Needle x -> x
forall 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 v = x -> Metric x -> Shade' x
forall x. x -> Metric x -> Shade' x
Shade' (x
cx -> Needle x -> x
forall x. Semimanifold x => x -> Needle x -> x
.-~^Needle x
v) Metric x
e
  semimanifoldWitness :: SemimanifoldWitness (Shade' x)
semimanifoldWitness = case SemimanifoldWitness x
forall x. Semimanifold x => SemimanifoldWitness x
semimanifoldWitness :: SemimanifoldWitness x of
     SemimanifoldWitness x
SemimanifoldWitness -> SemimanifoldWitness (Shade' x)
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 = Shade'HalfNeedle x
forall a. HasCallStack => a
undefined
  addHVs :: Shade'HalfNeedle x -> Shade'HalfNeedle x -> Shade'HalfNeedle x
addHVs = Shade'HalfNeedle x -> Shade'HalfNeedle x -> Shade'HalfNeedle x
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 = Ray (Shade'HalfNeedle x)
-> Shade'HalfNeedle x -> Shade'HalfNeedle x
forall a. HasCallStack => a
undefined
  fromFullSubspace :: FullSubspace (Shade'HalfNeedle x) -> Shade'HalfNeedle x
fromFullSubspace = FullSubspace (Shade'HalfNeedle x) -> Shade'HalfNeedle x
forall a. HasCallStack => a
undefined
  projectToFullSubspace :: Shade'HalfNeedle x -> FullSubspace (Shade'HalfNeedle x)
projectToFullSubspace = Shade'HalfNeedle x -> FullSubspace (Shade'HalfNeedle x)
forall a. HasCallStack => a
undefined
  fullSubspaceIsVectorSpace :: ((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
_ = r
forall a. HasCallStack => a
undefined
  rayIsHalfSpace :: (HalfSpace (Ray (Shade'HalfNeedle x)) => r) -> r
rayIsHalfSpace HalfSpace (Ray (Shade'HalfNeedle x)) => r
_ = r
forall a. HasCallStack => a
undefined
  mirrorJoinIsVectorSpace :: ((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
_ = r
forall a. HasCallStack => a
undefined
  fromPositiveHalf :: Shade'HalfNeedle x -> MirrorJoin (Shade'HalfNeedle x)
fromPositiveHalf = Shade'HalfNeedle x -> MirrorJoin (Shade'HalfNeedle x)
forall a. HasCallStack => a
undefined
  fromNegativeHalf :: Shade'HalfNeedle x -> MirrorJoin (Shade'HalfNeedle x)
fromNegativeHalf = Shade'HalfNeedle x -> MirrorJoin (Shade'HalfNeedle x)
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 = Interior (Shade' x)
-> Needle (Interior (Shade' x)) -> Maybe (Boundary (Shade' x))
forall a. HasCallStack => a
undefined
  smfdWBoundWitness :: SmfdWBoundWitness (Shade' x)
smfdWBoundWitness = SmfdWBoundWitness (Shade' x)
forall a. HasCallStack => a
undefined
  needleIsOpenMfd :: (OpenManifold (Needle (Interior (Shade' x))) => r) -> r
needleIsOpenMfd OpenManifold (Needle (Interior (Shade' x))) => r
_ = r
forall a. HasCallStack => a
undefined
  scalarIsOpenMfd :: (OpenManifold (Scalar (Needle (Interior (Shade' x)))) => r) -> r
scalarIsOpenMfd OpenManifold (Scalar (Needle (Interior (Shade' x)))) => r
_ = 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
η) = (D¹ -> Shade' x) -> Maybe (D¹ -> Shade' 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 = Norm (Diff x)
-> Norm (Diff x) -> [(DualVector (Diff x), Scalar (Diff x))]
forall v.
SimpleSpace v =>
Norm v -> Norm v -> [(DualVector v, Scalar v)]
sharedNormSpanningSystem Norm (Diff x)
Metric x
e Norm (Diff x)
Metric x
η
         interp :: D¹ -> Shade' x
interp D¹
t = x -> Metric x -> Shade' x
forall x. x -> Metric x -> Shade' x
Shade' (D¹ -> x
pinterp D¹
t)
                           ([DualVector (Diff x)] -> Norm (Diff x)
forall v. LSpace v => [DualVector v] -> Seminorm v
spanNorm [ DualVector (Needle x)
v DualVector (Needle x) -> ℝ -> DualVector (Needle x)
forall v s.
(VectorSpace v, s ~ Scalar v, Fractional s) =>
v -> s -> v
^/ (ℝ -> ℝ -> D¹ -> ℝ
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 (Needle x)
v,ℝ
qη) <- [(DualVector (Diff x), Scalar (Diff x))]
[(DualVector (Needle x), ℝ)]
sharedSpan ])
         Just D¹ -> x
pinterp = x -> x -> Maybe (D¹ -> x)
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 :: x -> Metric' x -> Shade x
fullShade x
ctr Metric' x
expa = x -> Metric' x -> Shade x
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' :: x -> Metric x -> Shade' x
fullShade' x
ctr Metric x
expa = x -> Metric x -> Shade' x
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:± :: x -> [Needle x] -> Shade x
$m:± :: forall r x.
Shade x
-> ((Semimanifold x, SimpleSpace (Needle x)) =>
    x -> [Needle x] -> r)
-> (Void# -> r)
-> r
:± shs <- (Shade x (varianceSpanningSystem -> shs))
 where x
x :± [Needle x]
shs = x -> Norm (DualVector (Needle x)) -> Shade x
forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
fullShade x
x (Norm (DualVector (Needle x)) -> Shade x)
-> Norm (DualVector (Needle x)) -> Shade x
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ [Needle x] -> Norm (DualVector (Needle x))
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|±| :: x -> [Needle x] -> Shade' x
|±|[Needle x]
shs = x -> Metric x -> Shade' x
forall x. x -> Metric x -> Shade' x
Shade' x
x (Norm (Diff x) -> Shade' x) -> Norm (Diff x) -> Shade' x
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ [DualVector (Diff x)] -> Norm (Diff x)
forall v. LSpace v => [DualVector v] -> Seminorm v
spanNorm [Diff x
vDiff x -> ℝ -> Diff x
forall v s.
(VectorSpace v, s ~ Scalar v, Fractional s) =>
v -> s -> v
^/(Diff x
vDiff x -> Diff x -> Scalar (Diff x)
forall v. InnerSpace v => v -> v -> Scalar v
<.>Diff x
v) | Diff x
v<-[Diff x]
[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 :: [x] -> [Shade x]
pointsShades = (([(x, ())], Shade x) -> Shade x)
-> [([(x, ())], Shade x)] -> [Shade x]
forall a b. (a -> b) -> [a] -> [b]
map ([(x, ())], Shade x) -> Shade x
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd ([([(x, ())], Shade x)] -> [Shade x])
-> ([x] -> [([(x, ())], Shade x)]) -> [x] -> [Shade x]
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. Metric' x -> [(x, ())] -> [([(x, ())], Shade x)]
forall x y.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
Metric' x -> [(x, y)] -> [([(x, y)], Shade x)]
pointsShades' Metric' x
forall a. Monoid a => a
mempty ([(x, ())] -> [([(x, ())], Shade x)])
-> ([x] -> [(x, ())]) -> [x] -> [([(x, ())], Shade x)]
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. (x -> (x, ())) -> [x] -> [(x, ())]
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 :: x -> [Needle x] -> Shade x
coverAllAround x
x₀ [Needle x]
offs = x -> Norm (DualVector (Needle x)) -> Shade x
forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade x
x₀
         (Norm (DualVector (Needle x)) -> Shade x)
-> Norm (DualVector (Needle x)) -> Shade 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 DualNeedleWitness x
forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness [Needle x]
offs
               (Scalar (DualVector (Needle x))
-> Norm (DualVector (Needle x)) -> Norm (DualVector (Needle x))
forall v. LSpace v => Scalar v -> Norm v -> Norm v
scaleNorm (s
1s -> s -> s
forall a. Fractional a => a -> a -> a
/Int -> s
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Needle x] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Needle x]
offs)) (Norm (DualVector (Needle x)) -> Norm (DualVector (Needle x)))
-> Norm (DualVector (Needle x)) -> Norm (DualVector (Needle x))
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ [Needle x] -> Norm (DualVector (Needle x))
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 [Needle x]
-> (Needle x -> [(Needle x, Norm (DualVector (Needle x)))])
-> [(Needle x, Norm (DualVector (Needle x)))]
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 -> Bool -> [()]
forall (m :: * -> *) (k :: * -> * -> *).
(MonadPlus m k, Arrow k (->), Function k, UnitObject k ~ (),
 Object k Bool) =>
k Bool (m ())
guard ((Variance (DualVector (Needle x))
Norm (Needle x)
ex'Norm (Needle x) -> Needle x -> Scalar (Needle x)
forall v.
(LSpace v, Floating (Scalar v)) =>
Seminorm v -> v -> Scalar v
|$|Needle x
v) s -> s -> Bool
forall a. Ord a => a -> a -> Bool
> s
1) [()]
-> [(Needle x, Norm (DualVector (Needle x)))]
-> [(Needle x, Norm (DualVector (Needle x)))]
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, [Needle x] -> Norm (DualVector (Needle x))
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 ((Needle x, Norm (DualVector (Needle x))) -> Needle x
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst((Needle x, Norm (DualVector (Needle x))) -> Needle x)
-> [(Needle x, Norm (DualVector (Needle x)))] -> [Needle x]
forall (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)
                                 ( Norm (DualVector (Needle x)) -> Norm (DualVector (Needle x))
forall v. LSpace v => Norm v -> Norm v
densifyNorm (Norm (DualVector (Needle x)) -> Norm (DualVector (Needle x)))
-> Norm (DualVector (Needle x)) -> Norm (DualVector (Needle x))
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$
                                    Norm (DualVector (Needle x))
ex Norm (DualVector (Needle x))
-> Norm (DualVector (Needle x)) -> Norm (DualVector (Needle x))
forall a. Semigroup a => a -> a -> a
<> Scalar (DualVector (Needle x))
-> Norm (DualVector (Needle x)) -> Norm (DualVector (Needle x))
forall v. LSpace v => Scalar v -> Norm v -> Norm v
scaleNorm
                                                (s -> s
forall a. Floating a => a -> a
sqrt (s -> s) -> (Int -> s) -> Int -> s
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
. s -> s
forall a. Fractional a => a -> a
recip (s -> s) -> (Int -> s) -> Int -> s
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
. Int -> s
forall a b. (Integral a, Num b) => a -> b
fromIntegral
                                                            (Int -> s) -> Int -> s
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [(Needle x, Norm (DualVector (Needle x)))] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Needle x, Norm (DualVector (Needle x)))]
outs)
                                                ([Norm (DualVector (Needle x))] -> Norm (DualVector (Needle x))
forall a. Monoid a => [a] -> a
mconcat ([Norm (DualVector (Needle x))] -> Norm (DualVector (Needle x)))
-> [Norm (DualVector (Needle x))] -> Norm (DualVector (Needle x))
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (Needle x, Norm (DualVector (Needle x)))
-> Norm (DualVector (Needle x))
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd((Needle x, Norm (DualVector (Needle x)))
 -> Norm (DualVector (Needle x)))
-> [(Needle x, Norm (DualVector (Needle x)))]
-> [Norm (DualVector (Needle x))]
forall (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' = Norm (DualVector (Needle x)) -> Variance (DualVector (Needle x))
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 :: [x] -> [Shade x]
pointsCovers = case PseudoAffineWitness x
forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness :: PseudoAffineWitness x of
                 (PseudoAffineWitness (SemimanifoldWitness x
SemimanifoldWitness)) ->
                  \[x]
ps -> (([(x, ())], Shade x) -> Shade x)
-> [([(x, ())], Shade x)] -> [Shade x]
forall a b. (a -> b) -> [a] -> [b]
map (\([(x, ())]
ps', Shade x
x₀ Metric' x
_)
                                -> x -> [Needle x] -> Shade 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
px -> x -> Maybe (Needle x)
forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
x₀])
                             (Metric' x -> [(x, ())] -> [([(x, ())], Shade x)]
forall x y.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
Metric' x -> [(x, y)] -> [([(x, y)], Shade x)]
pointsShades' Metric' x
forall a. Monoid a => a
mempty ((,())(x -> (x, ())) -> [x] -> [(x, ())]
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 :: [x] -> [Shade' x]
pointsShade's = case DualSpaceWitness (Needle x)
forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualNeedleWitness x of
 DualSpaceWitness (Needle x)
DualSpaceWitness -> (Shade x -> Shade' x) -> [Shade x] -> [Shade' x]
forall a b. (a -> b) -> [a] -> [b]
map (\(Shade x
c Metric' x
e :: Shade x) -> x -> Norm (Needle x) -> Shade' x
forall x. x -> Metric x -> Shade' x
Shade' x
c (Norm (Needle x) -> Shade' x) -> Norm (Needle x) -> Shade' x
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Metric' x -> Variance (DualVector (Needle x))
forall v. SimpleSpace v => Norm v -> Variance v
dualNorm Metric' x
e) ([Shade x] -> [Shade' x])
-> ([x] -> [Shade x]) -> [x] -> [Shade' x]
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. [x] -> [Shade x]
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 :: [x] -> [Shade' x]
pointsCover's = case DualSpaceWitness (Needle x)
forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualNeedleWitness x of
 DualSpaceWitness (Needle x)
DualSpaceWitness -> (Shade x -> Shade' x) -> [Shade x] -> [Shade' x]
forall a b. (a -> b) -> [a] -> [b]
map (\(Shade x
c Metric' x
e :: Shade x) -> x -> Norm (Needle x) -> Shade' x
forall x. x -> Metric x -> Shade' x
Shade' x
c (Norm (Needle x) -> Shade' x) -> Norm (Needle x) -> Shade' x
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Metric' x -> Variance (DualVector (Needle x))
forall v. SimpleSpace v => Norm v -> Variance v
dualNorm Metric' x
e) ([Shade x] -> [Shade' x])
-> ([x] -> [Shade x]) -> [x] -> [Shade' x]
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. [x] -> [Shade x]
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 :: p x -> NonEmpty (x, y) -> (x, ([(x, y)], [(x, y)]))
pseudoECM = case SemimanifoldWitness x
forall x. Semimanifold x => SemimanifoldWitness x
semimanifoldWitness :: SemimanifoldWitness x of
 SemimanifoldWitness x
SemimanifoldWitness ->
   \p x
_ ((x
p₀,y
y₀) NE.:| [(x, y)]
psr) -> ((x, ([(x, y)], [(x, y)]))
 -> (ℝ, (x, y)) -> (x, ([(x, y)], [(x, y)])))
-> (x, ([(x, y)], [(x, y)]))
-> [(ℝ, (x, y))]
-> (x, ([(x, y)], [(x, y)]))
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
px -> x -> Maybe (Needle x)
forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
acc, x
acc) of 
                                      (Just Needle x
δ, x
acci)
                                        -> (x
acci x -> Needle x -> x
forall x. Semimanifold x => x -> Needle x -> x
.+~^ Needle x
δNeedle x -> ℝ -> Needle x
forall v s.
(VectorSpace v, s ~ Scalar v, Fractional s) =>
v -> s -> v
^/ℝ
i, ((x
p,y
y)(x, y) -> [(x, y)] -> [(x, 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)(x, y) -> [(x, y)] -> [(x, y)]
forall a. a -> [a] -> [a]
:[(x, y)]
nr)) )
                             (x
p₀, ([(x, y)], [(x, y)])
forall a. Monoid a => a
mempty)
                             ( [ℝ] -> [(x, y)] -> [(ℝ, (x, y))]
forall a b. [a] -> [b] -> [(a, b)]
zip [ℝ
1..] ([(x, y)] -> [(ℝ, (x, y))]) -> [(x, y)] -> [(ℝ, (x, y))]
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (x
p₀,y
y₀)(x, y) -> [(x, y)] -> [(x, 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' :: Metric' x -> [(x, y)] -> [([(x, y)], Shade x)]
pointsShades' Metric' x
_ [] = []
pointsShades' Metric' x
minExt [(x, y)]
ps = case (Maybe (Metric' x)
expa, x
ctr) of 
                           (Just Metric' x
e, x
c)
                             -> ([(x, y)]
ps, x -> Metric' x -> Shade x
forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
fullShade x
c Metric' x
e) ([(x, y)], Shade x)
-> [([(x, y)], Shade x)] -> [([(x, y)], Shade x)]
forall a. a -> [a] -> [a]
: Metric' x -> [(x, y)] -> [([(x, y)], Shade x)]
forall x y.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
Metric' x -> [(x, y)] -> [([(x, y)], Shade x)]
pointsShades' Metric' x
minExt [(x, y)]
unreachable
                           (Maybe (Metric' x), x)
_ -> Metric' x -> [(x, y)] -> [([(x, y)], Shade x)]
forall x y.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
Metric' x -> [(x, y)] -> [([(x, y)], Shade x)]
pointsShades' Metric' x
minExt [(x, y)]
inc'd
                                  [([(x, y)], Shade x)]
-> [([(x, y)], Shade x)] -> [([(x, y)], Shade x)]
forall a. [a] -> [a] -> [a]
++ Metric' x -> [(x, y)] -> [([(x, y)], Shade x)]
forall x y.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
Metric' x -> [(x, y)] -> [([(x, y)], Shade x)]
pointsShades' Metric' x
minExt [(x, y)]
unreachable
 where (x
ctr,([(x, y)]
inc'd,[(x, y)]
unreachable)) = [x] -> NonEmpty (x, y) -> (x, ([(x, y)], [(x, y)]))
forall x y (p :: * -> *).
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x), Functor p) =>
p x -> NonEmpty (x, y) -> (x, ([(x, y)], [(x, y)]))
pseudoECM ([]::[x]) (NonEmpty (x, y) -> (x, ([(x, y)], [(x, y)])))
-> NonEmpty (x, y) -> (x, ([(x, y)], [(x, y)]))
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ [(x, y)] -> NonEmpty (x, y)
forall a. [a] -> NonEmpty a
NE.fromList [(x, y)]
ps
       expa :: Maybe (Metric' x)
expa = ( (Metric' x -> Metric' x -> Metric' x
forall a. Semigroup a => a -> a -> a
<>Metric' x
minExt) (Metric' x -> Metric' x)
-> ([Needle x] -> Metric' x) -> [Needle x] -> Metric' x
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. [Needle x] -> Metric' x
forall v. LSpace v => [v] -> Variance v
spanVariance ([Needle x] -> Metric' x)
-> ([Needle x] -> [Needle x]) -> [Needle x] -> Metric' x
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. (Needle x -> Needle x) -> [Needle x] -> [Needle x]
forall a b. (a -> b) -> [a] -> [b]
map (Needle x -> ℝ -> Needle x
forall v s.
(VectorSpace v, s ~ Scalar v, Fractional s) =>
v -> s -> v
^/ Int -> ℝ
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([(x, y)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(x, y)]
ps)) )
              ([Needle x] -> Metric' x) -> Maybe [Needle x] -> Maybe (Metric' x)
forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> ((x, y) -> Maybe (Needle x)) -> [(x, y)] -> Maybe [Needle x]
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 ((x -> x -> Maybe (Needle x)
forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
ctr) (x -> Maybe (Needle x))
-> ((x, y) -> x) -> (x, y) -> Maybe (Needle x)
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. (x, y) -> x
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 :: ℝ -> [Shade x] -> [Shade x]
shadesMerge ℝ
fuzz (sh :: Shade x
sh@(Shade x
c₁ Metric' x
e₁) : [Shade x]
shs)
    = case (Shade x -> Maybe (Shade x))
-> [Shade x] -> (Maybe (Shade x), [Shade x])
forall a b. (a -> Maybe b) -> [a] -> (Maybe b, [a])
extractJust (PseudoAffineWitness x
-> DualNeedleWitness x -> Shade x -> Maybe (Shade x)
tryMerge PseudoAffineWitness x
forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness DualNeedleWitness x
forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness)
                 [Shade x]
shs of
          (Just Shade x
mg₁, [Shade x]
shs') -> ℝ -> [Shade x] -> [Shade x]
forall x.
(WithField ℝ Manifold x, SimpleSpace (Needle x)) =>
ℝ -> [Shade x] -> [Shade x]
shadesMerge ℝ
fuzz
                                ([Shade x] -> [Shade x]) -> [Shade x] -> [Shade x]
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ [Shade x]
shs'[Shade x] -> [Shade x] -> [Shade x]
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 Shade x -> [Shade x] -> [Shade x]
forall a. a -> [a] -> [a]
: ℝ -> [Shade x] -> [Shade x]
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₁x -> x -> Maybe (Needle x)
forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
c₂
           , [Norm (Needle x)
e₁',Norm (Needle x)
e₂'] <- Metric' x -> Norm (Needle x)
forall v. SimpleSpace v => Norm v -> Variance v
dualNorm(Metric' x -> Norm (Needle x)) -> [Metric' x] -> [Norm (Needle x)]
forall (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 (Needle x)
b₁ <- Norm (Needle x)
e₂'Norm (Needle x) -> Needle x -> Scalar (Needle x)
forall v.
(LSpace v, Floating (Scalar v)) =>
Seminorm v -> v -> Scalar v
|$|Needle x
v
           , Scalar (Needle x)
b₂ <- Norm (Needle x)
e₁'Norm (Needle x) -> Needle x -> Scalar (Needle x)
forall v.
(LSpace v, Floating (Scalar v)) =>
Seminorm v -> v -> Scalar v
|$|Needle x
v
           , ℝ
fuzzℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
*ℝ
Scalar (Needle x)
b₁ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
*ℝ
Scalar (Needle x)
b₂ ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
<= ℝ
Scalar (Needle x)
b₁ ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
+ ℝ
Scalar (Needle x)
b₂
                  = Shade x -> Maybe (Shade x)
forall a. a -> Maybe a
Just (Shade x -> Maybe (Shade x)) -> Shade x -> Maybe (Shade x)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ let cc :: x
cc = x
c₂ x -> Needle x -> x
forall x. Semimanifold x => x -> Needle x -> x
.+~^ Needle x
v Needle x -> ℝ -> Needle x
forall v s.
(VectorSpace v, s ~ Scalar v, Fractional s) =>
v -> s -> v
^/ ℝ
2
                               Just Needle x
cv₁ = x
c₁x -> x -> Maybe (Needle x)
forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
cc
                               Just Needle x
cv₂ = x
c₂x -> x -> Maybe (Needle x)
forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
cc
                           in x -> Metric' x -> Shade x
forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade x
cc (Metric' x -> Shade x) -> Metric' x -> Shade x
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Metric' x
e₁ Metric' x -> Metric' x -> Metric' x
forall a. Semigroup a => a -> a -> a
<> Metric' x
e₂ Metric' x -> Metric' x -> Metric' x
forall a. Semigroup a => a -> a -> a
<> [Needle x] -> Metric' x
forall v. LSpace v => [v] -> Variance v
spanVariance [Needle x
cv₁, Needle x
cv₂]
           | Bool
otherwise  = Maybe (Shade x)
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 :: NonEmpty (Shade' y) -> Maybe (Shade' y)
mixShade's = PseudoAffineWitness y
-> DualNeedleWitness y -> NonEmpty (Shade' y) -> Maybe (Shade' y)
ms PseudoAffineWitness y
forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness DualNeedleWitness y
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 -+> DualVector (Needle y)
e₁):|[Shade' y]
shs) = [Maybe (Needle y)] -> Maybe [Needle y]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [Maybe (Needle y)]
ciso Maybe [Needle y] -> Maybe (Shade' y) -> Maybe (Shade' y)
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)
>> Shade' y -> Maybe (Shade' y)
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
ciy -> y -> Maybe (Needle y)
forall 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) (DualVector (Needle y))
σe = LinearFunction ℝ (Needle y) (DualVector (Needle y))
-> LinearMap ℝ (Needle y) (DualVector (Needle y))
forall (a :: * -> * -> *) (k :: * -> * -> *) b c.
(EnhancedCat a k, Object k b, Object k c, Object a b,
 Object a c) =>
k b c -> a b c
arr (LinearFunction ℝ (Needle y) (DualVector (Needle y))
 -> LinearMap ℝ (Needle y) (DualVector (Needle y)))
-> ([LinearFunction ℝ (Needle y) (DualVector (Needle y))]
    -> LinearFunction ℝ (Needle y) (DualVector (Needle y)))
-> [LinearFunction ℝ (Needle y) (DualVector (Needle y))]
-> LinearMap ℝ (Needle y) (DualVector (Needle y))
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. [LinearFunction ℝ (Needle y) (DualVector (Needle y))]
-> LinearFunction ℝ (Needle y) (DualVector (Needle y))
forall (f :: * -> *) v. (Foldable f, AdditiveGroup v) => f v -> v
sumV ([LinearFunction ℝ (Needle y) (DualVector (Needle y))]
 -> LinearMap ℝ (Needle y) (DualVector (Needle y)))
-> [LinearFunction ℝ (Needle y) (DualVector (Needle y))]
-> LinearMap ℝ (Needle y) (DualVector (Needle y))
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ LinearFunction ℝ (Needle y) (DualVector (Needle y))
Needle y -+> DualVector (Needle y)
e₁ LinearFunction ℝ (Needle y) (DualVector (Needle y))
-> [LinearFunction ℝ (Needle y) (DualVector (Needle y))]
-> [LinearFunction ℝ (Needle y) (DualVector (Needle y))]
forall a. a -> [a] -> [a]
: (Norm (Needle y)
-> LinearFunction ℝ (Needle y) (DualVector (Needle y))
forall v. Norm v -> v -+> DualVector v
applyNorm (Norm (Needle y)
 -> LinearFunction ℝ (Needle y) (DualVector (Needle y)))
-> (Shade' y -> Norm (Needle y))
-> Shade' y
-> LinearFunction ℝ (Needle y) (DualVector (Needle y))
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. Shade' y -> Norm (Needle y)
forall x. Shade' x -> Metric x
_shade'Narrowness(Shade' y -> LinearFunction ℝ (Needle y) (DualVector (Needle y)))
-> [Shade' y]
-> [LinearFunction ℝ (Needle y) (DualVector (Needle y))]
forall (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) (DualVector (Needle y))
LinearMap (Scalar (Needle y)) (Needle y) (DualVector (Needle y))
σe LinearMap (Scalar (Needle y)) (Needle y) (DualVector (Needle y))
-> DualVector (Needle y) -> Needle y
forall u v.
(SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v) =>
(u +> v) -> v -> u
\$ [DualVector (Needle y)] -> DualVector (Needle y)
forall (f :: * -> *) v. (Foldable f, AdditiveGroup v) => f v -> v
sumV [LinearFunction ℝ (Needle y) (DualVector (Needle y))
Needle y -+> DualVector (Needle y)
ei LinearFunction ℝ (Needle y) (DualVector (Needle y))
-> Needle y -> DualVector (Needle y)
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 -+> DualVector (Needle y)
ei) <- [Shade' y]
shs]
              mixed :: Shade' y
mixed = y -> Norm (Needle y) -> Shade' y
forall x. x -> Metric x -> Shade' x
Shade' (y
c₀y -> Needle y -> y
+^Needle y
cc) (Norm (Needle y) -> Shade' y) -> Norm (Needle y) -> Shade' y
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Norm (Needle y) -> Norm (Needle y)
forall v. LSpace v => Norm v -> Norm v
densifyNorm ( [Norm (Needle y)] -> Norm (Needle y)
forall a. Monoid a => [a] -> a
mconcat
                             [ (Needle y -+> DualVector (Needle y)) -> Norm (Needle y)
forall v. (v -+> DualVector v) -> Norm v
Norm ((Needle y -+> DualVector (Needle y)) -> Norm (Needle y))
-> (Needle y -+> DualVector (Needle y)) -> Norm (Needle y)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Needle y -+> DualVector (Needle y)
ei (Needle y -+> DualVector (Needle y))
-> ℝ -> Needle y -+> DualVector (Needle y)
forall v s.
(VectorSpace v, s ~ Scalar v, Fractional s) =>
v -> s -> v
^/ (ℝ
1ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
+(Norm (Needle y) -> Needle y -> Scalar (Needle y)
forall v. LSpace v => Seminorm v -> v -> Scalar v
normSq Norm (Needle y)
ni (Needle y -> ℝ) -> Needle y -> ℝ
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Needle y
ciNeedle y -> Needle y -> Needle y
forall v. AdditiveGroup v => v -> v -> v
^-^Needle y
cc))
                             | ni :: Norm (Needle y)
ni@(Norm Needle y -+> DualVector (Needle y)
ei) <- (Needle y -+> DualVector (Needle y)) -> Norm (Needle y)
forall v. (v -+> DualVector v) -> Norm v
Norm Needle y -+> DualVector (Needle y)
e₁ Norm (Needle y) -> [Norm (Needle y)] -> [Norm (Needle y)]
forall a. a -> [a] -> [a]
: (Shade' y -> Norm (Needle y)
forall x. Shade' x -> Metric x
_shade'Narrowness(Shade' y -> Norm (Needle y)) -> [Shade' y] -> [Norm (Needle y)]
forall (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 <- Needle y
forall v. AdditiveGroup v => v
zeroV Needle y -> [Needle y] -> [Needle y]
forall a. a -> [a] -> [a]
: [Needle y]
cis
                             ] )
              +^ :: y -> Needle y -> y
(+^) = 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' :: Shade' x -> x -> s
minusLogOcclusion' (Shade' x
p₀ Metric x
δinv)
        = PseudoAffineWitness x -> DualSpaceWitness (Needle x) -> x -> s
occ (PseudoAffineWitness x
forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness :: PseudoAffineWitness x)
              (DualSpaceWitness (Needle 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
px -> x -> Maybe (Needle x)
forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
p₀ of
         (Just Needle x
vd) | Scalar (Needle x)
mSq <- Metric x -> Needle x -> Scalar (Needle x)
forall v. LSpace v => Seminorm v -> v -> Scalar v
normSq Metric x
δinv Needle x
vd
                   , s
Scalar (Needle x)
mSq s -> s -> Bool
forall a. Eq a => a -> a -> Bool
== s
Scalar (Needle x)
mSq  -- avoid NaN
                   -> s
Scalar (Needle x)
mSq
         Maybe (Needle x)
_         -> s
1s -> s -> s
forall 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 :: Shade x -> x -> s
minusLogOcclusion (Shade x
p₀ Metric' x
δ)
        = PseudoAffineWitness x -> DualSpaceWitness (Needle x) -> x -> s
occ (PseudoAffineWitness x
forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness :: PseudoAffineWitness x)
              (DualSpaceWitness (Needle 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
px -> x -> Maybe (Needle x)
forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
p₀ of
         (Just Needle x
vd) | Scalar (Needle x)
mSq <- Seminorm (Needle x) -> Needle x -> Scalar (Needle x)
forall v. LSpace v => Seminorm v -> v -> Scalar v
normSq Variance (DualVector (Needle x))
Seminorm (Needle x)
δinv Needle x
vd
                   , s
Scalar (Needle x)
mSq s -> s -> Bool
forall a. Eq a => a -> a -> Bool
== s
Scalar (Needle x)
mSq  -- avoid NaN
                   -> s
Scalar (Needle x)
mSq
         Maybe (Needle x)
_         -> s
1s -> s -> s
forall a. Fractional a => a -> a -> a
/s
0
        where δinv :: Variance (DualVector (Needle x))
δinv = Metric' x -> Variance (DualVector (Needle x))
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 :: (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 <- [Maybe (Diff (Interior i), Diff (Interior m))]
-> Maybe [(Diff (Interior i), Diff (Interior m))]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [ (Maybe (Diff (Interior i)), Maybe (Diff (Interior m)))
-> Maybe (Diff (Interior i), Diff (Interior m))
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 ( i -> i -> Maybe i
forall x. Geodesic x => x -> x -> Maybe x
middleBetween i
pi i
ci Maybe i
-> (i -> Maybe (Diff (Interior i))) -> Maybe (Diff (Interior i))
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
>>= (i -> Maybe (Interior i)
forall m. SemimanifoldWithBoundary m => m -> Maybe (Interior m)
toInterior(i -> Maybe (Interior i))
-> (Interior i -> Maybe (Diff (Interior i)))
-> i
-> Maybe (Diff (Interior i))
forall (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)
>=>(Interior i -> Interior i -> Maybe (Needle (Interior i))
forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.Interior i
cii))
                                  , m -> m -> Maybe m
forall x. Geodesic x => x -> x -> Maybe x
middleBetween m
pm m
cm Maybe m
-> (m -> Maybe (Diff (Interior m))) -> Maybe (Diff (Interior m))
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
>>= (m -> Maybe (Interior m)
forall m. SemimanifoldWithBoundary m => m -> Maybe (Interior m)
toInterior(m -> Maybe (Interior m))
-> (Interior m -> Maybe (Diff (Interior m)))
-> m
-> Maybe (Diff (Interior m))
forall (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)
>=>(Interior m -> Interior m -> Maybe (Needle (Interior m))
forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.Interior m
cmi)) )
                           | (i
pi, m
pm) <- t (i, m) -> [(i, m)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Hask.toList t (i, m)
verts ]
           Embedding (Affine s) (Interior i) (Interior m)
affinSys <- (Interior i, Interior m)
-> [(Needle (Interior i), Needle (Interior m))]
-> Maybe (Embedding (Affine s) (Interior i) (Interior m))
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))]
[(Needle (Interior i), Needle (Interior m))]
vs
           (Shade (Interior i) -> Shade (Interior m))
-> Maybe (Shade (Interior i) -> Shade (Interior m))
forall (m :: * -> *) a. Monad m (->) => a -> m a
return ((Shade (Interior i) -> Shade (Interior m))
 -> Maybe (Shade (Interior i) -> Shade (Interior m)))
-> (Shade (Interior i) -> Shade (Interior m))
-> Maybe (Shade (Interior i) -> Shade (Interior m))
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Embedding (Affine s) (Interior i) (Interior m)
-> Shade (Interior i) -> Shade (Interior m)
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 = Interior i -> i
forall m. SemimanifoldWithBoundary m => Interior m -> m
fromInterior Interior i
cii
       cm :: m
cm = Interior m -> m
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 = DebugView y -> Maybe (DebugView y)
forall a. a -> Maybe a
Just DebugView y
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 PseudoAffineWitness y
forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness :: PseudoAffineWitness y of
   PseudoAffineWitness (SemimanifoldWitness y
SemimanifoldWitness)
    | Just Needle y
v <- y
tcy -> y -> Maybe (Needle y)
forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.y
ac
    , Scalar (Needle y)
v² <- Metric y -> Needle y -> Scalar (Needle y)
forall v. LSpace v => Seminorm v -> v -> Scalar v
normSq Metric y
te Needle y
v
    , ℝ
Scalar (Needle y)
v² ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
<= ℝ
1
     -> ((DualVector (Needle y), Maybe ℝ) -> Bool)
-> [(DualVector (Needle y), Maybe ℝ)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(DualVector (Needle y)
y',Maybe ℝ
μ) -> case Maybe ℝ
μ of
            Maybe ℝ
Nothing -> Bool
True  -- 'te' has infinite extension in this direction
            Just ℝ
ξ
              | ℝ
ξℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
<ℝ
1 -> Bool
False -- 'ae' would be vaster than 'te' in this direction
              | ℝ
ω <- ℝ -> ℝ
forall a. Num a => a -> a
abs (ℝ -> ℝ) -> ℝ -> ℝ
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ DualVector (Needle y)
y'DualVector (Needle y) -> Needle y -> Scalar (Needle y)
forall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^Needle y
v
                    -> (ℝ
ω ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
+ ℝ
1ℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
ξ)ℝ -> Int -> ℝ
forall a. Num a => a -> Int -> a
^Int
2 ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
<= ℝ
1 ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
- ℝ
Scalar (Needle y)
v² ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
+ ℝ
ωℝ -> Int -> ℝ
forall a. Num a => a -> Int -> a
^Int
2
                 -- See @images/constructions/subellipse-check-heuristic.svg@
         ) ([(DualVector (Needle y), Maybe ℝ)] -> Bool)
-> [(DualVector (Needle y), Maybe ℝ)] -> Bool
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Metric y
-> Metric y -> [(DualVector (Needle y), Maybe (Scalar (Needle y)))]
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 -+> DualVector (Needle y)
e₁)) (Shade' y
c₀₂ (Norm Needle y -+> DualVector (Needle y)
e₂))
      = case ( DualSpaceWitness (Needle y)
forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualNeedleWitness y
             , PseudoAffineWitness y
forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness :: PseudoAffineWitness y ) of
          (DualSpaceWitness (Needle y)
DualSpaceWitness, PseudoAffineWitness (SemimanifoldWitness y
SemimanifoldWitness))
               -> do
           Needle y
c₂ <- y
c₀₂y -> y -> Maybe (Needle y)
forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.y
c₀
           let σe :: LinearMap ℝ (Needle y) (DualVector (Needle y))
σe = LinearFunction ℝ (Needle y) (DualVector (Needle y))
-> LinearMap ℝ (Needle y) (DualVector (Needle y))
forall (a :: * -> * -> *) (k :: * -> * -> *) b c.
(EnhancedCat a k, Object k b, Object k c, Object a b,
 Object a c) =>
k b c -> a b c
arr (LinearFunction ℝ (Needle y) (DualVector (Needle y))
 -> LinearMap ℝ (Needle y) (DualVector (Needle y)))
-> LinearFunction ℝ (Needle y) (DualVector (Needle y))
-> LinearMap ℝ (Needle y) (DualVector (Needle y))
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ LinearFunction ℝ (Needle y) (DualVector (Needle y))
Needle y -+> DualVector (Needle y)
e₁LinearFunction ℝ (Needle y) (DualVector (Needle y))
-> LinearFunction ℝ (Needle y) (DualVector (Needle y))
-> LinearFunction ℝ (Needle y) (DualVector (Needle y))
forall v. AdditiveGroup v => v -> v -> v
^+^LinearFunction ℝ (Needle y) (DualVector (Needle y))
Needle y -+> DualVector (Needle y)
e₂
               e₁c₂ :: DualVector (Needle y)
e₁c₂ = LinearFunction ℝ (Needle y) (DualVector (Needle y))
Needle y -+> DualVector (Needle y)
e₁ LinearFunction ℝ (Needle y) (DualVector (Needle y))
-> Needle y -> DualVector (Needle y)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Needle y
c₂
               e₂c₂ :: DualVector (Needle y)
e₂c₂ = LinearFunction ℝ (Needle y) (DualVector (Needle y))
Needle y -+> DualVector (Needle y)
e₂ LinearFunction ℝ (Needle y) (DualVector (Needle y))
-> Needle y -> DualVector (Needle y)
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) (DualVector (Needle y))
LinearMap (Scalar (Needle y)) (Needle y) (DualVector (Needle y))
σe LinearMap (Scalar (Needle y)) (Needle y) (DualVector (Needle y))
-> DualVector (Needle y) -> Needle y
forall u v.
(SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v) =>
(u +> v) -> v -> u
\$ DualVector (Needle y)
e₂c₂
               cc₂ :: Needle y
cc₂ = Needle y
cc Needle y -> Needle y -> Needle y
forall v. AdditiveGroup v => v -> v -> v
^-^ Needle y
c₂
               e₁cc :: DualVector (Needle y)
e₁cc = LinearFunction ℝ (Needle y) (DualVector (Needle y))
Needle y -+> DualVector (Needle y)
e₁ LinearFunction ℝ (Needle y) (DualVector (Needle y))
-> Needle y -> DualVector (Needle y)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Needle y
cc
               e₂cc :: DualVector (Needle y)
e₂cc = LinearFunction ℝ (Needle y) (DualVector (Needle y))
Needle y -+> DualVector (Needle y)
e₂ LinearFunction ℝ (Needle y) (DualVector (Needle y))
-> Needle y -> DualVector (Needle y)
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
+ DualVector (Needle y)
e₂c₂DualVector (Needle y) -> Needle y -> Scalar (Needle y)
forall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^Needle y
cc₂
           Bool -> Maybe ()
forall (m :: * -> *) (k :: * -> * -> *).
(MonadPlus m k, Arrow k (->), Function k, UnitObject k ~ (),
 Object k Bool) =>
k Bool (m ())
guard (ℝ
α ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
> ℝ
0)
           let ee :: LinearMap ℝ (Needle y) (DualVector (Needle y))
ee = LinearMap ℝ (Needle y) (DualVector (Needle y))
σe LinearMap ℝ (Needle y) (DualVector (Needle y))
-> ℝ -> LinearMap ℝ (Needle y) (DualVector (Needle y))
forall v s.
(VectorSpace v, s ~ Scalar v, Fractional s) =>
v -> s -> v
^/ ℝ
α
               c₂e₁c₂ :: Scalar (Needle y)
c₂e₁c₂ = DualVector (Needle y)
e₁c₂DualVector (Needle y) -> Needle y -> Scalar (Needle y)
forall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^Needle y
c₂
               c₂e₂c₂ :: Scalar (Needle y)
c₂e₂c₂ = DualVector (Needle y)
e₂c₂DualVector (Needle y) -> Needle y -> Scalar (Needle y)
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
/ ℝ
α
           Shade' y -> Maybe (Shade' y)
forall (m :: * -> *) a. Monad m (->) => a -> m a
return (Shade' y -> Maybe (Shade' y)) -> Shade' y -> Maybe (Shade' y)
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
* (DualVector (Needle y)
e₁ccDualVector (Needle y) -> Needle y -> Scalar (Needle y)
forall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^Needle y
c₂))
                                  (DualVector (Needle y)
e₁ccDualVector (Needle y) -> Needle y -> Scalar (Needle y)
forall 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
* (DualVector (Needle y)
e₂ccDualVector (Needle y) -> Needle y -> Scalar (Needle y)
forall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^Needle y
c₂ ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
- ℝ
Scalar (Needle y)
c₂e₂c₂))
                                  (DualVector (Needle y)
e₂ccDualVector (Needle y) -> Needle y -> Scalar (Needle y)
forall 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
* (DualVector (Needle y)
e₂c₂DualVector (Needle y) -> Needle y -> Scalar (Needle y)
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
+ℝ
γ₂) ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
< ℝ
2 -> let
               cc' :: Needle y
cc' = Needle y
cc Needle y -> Needle y -> Needle y
forall v. AdditiveGroup v => v -> v -> v
^+^ ((ℝ
γ₁ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
+ℝ
γ₂)ℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
2)Scalar (Needle y) -> Needle y -> Needle y
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₂ ℝ -> ℝ -> Bool
forall a. Eq a => a -> a -> Bool
/= ℝ
0 Bool -> Bool -> Bool
&& ℝ
1 ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
- ℝ
rγℝ -> Int -> ℝ
forall a. Num a => a -> Int -> a
^Int
2 ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
* ℝ
c₂eec₂ ℝ -> ℝ -> Bool
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γℝ -> Int -> ℝ
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 y -> Metric y -> Shade' y
forall x. x -> Metric x -> Shade' x
Shade' (y
c₀y -> Needle y -> y
forall x. Semimanifold x => x -> Needle x -> x
.+~^Needle y
cc')
                       ((Needle y -+> DualVector (Needle y)) -> Metric y
forall v. (v -+> DualVector v) -> Norm v
Norm (LinearMap ℝ (Needle y) (DualVector (Needle y))
-> LinearFunction ℝ (Needle y) (DualVector (Needle y))
forall (a :: * -> * -> *) (k :: * -> * -> *) b c.
(EnhancedCat a k, Object k b, Object k c, Object a b,
 Object a c) =>
k b c -> a b c
arr LinearMap ℝ (Needle y) (DualVector (Needle y))
ee) Metric y -> Metric y -> Metric y
forall a. Semigroup a => a -> a -> a
<> [DualVector (Needle y)] -> Metric y
forall v. LSpace v => [DualVector v] -> Seminorm v
spanNorm [LinearMap ℝ (Needle y) (DualVector (Needle y))
ee LinearMap ℝ (Needle y) (DualVector (Needle y))
-> Needle y -> DualVector (Needle y)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Needle y
c₂Needle y -> ℝ -> Needle y
forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^*ℝ
η])
            [ℝ]
_ -> y -> Metric y -> Shade' y
forall x. x -> Metric x -> Shade' x
Shade' (y
c₀y -> Needle y -> y
forall x. Semimanifold x => x -> Needle x -> x
.+~^Needle y
cc) ((Needle y -+> DualVector (Needle y)) -> Metric y
forall v. (v -+> DualVector v) -> Norm v
Norm ((Needle y -+> DualVector (Needle y)) -> Metric y)
-> (Needle y -+> DualVector (Needle y)) -> Metric y
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ LinearMap ℝ (Needle y) (DualVector (Needle y))
-> Needle y -+> DualVector (Needle y)
forall (a :: * -> * -> *) (k :: * -> * -> *) b c.
(EnhancedCat a k, Object k b, Object k c, Object a b,
 Object a c) =>
k b c -> a b c
arr LinearMap ℝ (Needle y) (DualVector (Needle y))
ee)
   where quadraticEqnSol :: a -> a -> a -> [a]
quadraticEqnSol a
a a
b a
c
             | a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0, a
b a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0       = [-a
ca -> a -> a
forall a. Fractional a => a -> a -> a
/a
b]
             | a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0 Bool -> Bool -> Bool
&& a
disc a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0  = [- a
b a -> a -> a
forall a. Fractional a => a -> a -> a
/ (a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
a)]
             | a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0 Bool -> Bool -> Bool
&& a
disc a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0   = [ (a
σ a -> a -> a
forall a. Num a => a -> a -> a
* a -> a
forall a. Floating a => a -> a
sqrt a
disc a -> a -> a
forall a. Num a => a -> a -> a
- a
b) a -> a -> a
forall a. Fractional a => a -> a -> a
/ (a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
a)
                                      | a
σ <- [-a
1, a
1] ]
             | Bool
otherwise            = []
          where disc :: a
disc = a
ba -> Int -> a
forall a. Num a => a -> Int -> a
^Int
2 a -> a -> a
forall a. Num a => a -> a -> a
- a
4a -> a -> a
forall a. Num a => a -> a -> a
*a
aa -> a -> a
forall 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 Metric y -> Maybe (Metric y)
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 Maybe (DebugView y)
forall y. Refinable y => Maybe (DebugView y)
debugView :: Maybe (DebugView y) of
            Just DebugView y
DebugView -> String -> Metric y
forall a. HasCallStack => String -> a
error (String -> Metric y) -> String -> Metric y
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ String
"Can not convolve norms "
                               String -> ShowS
forall a. [a] -> [a] -> [a]
++LinearMap ℝ (Needle y) (Needle y) -> String
forall a. Show a => a -> String
show (LinearFunction (Scalar (Needle y)) (Needle y) (Needle y)
-> LinearMap ℝ (Needle y) (Needle y)
forall (a :: * -> * -> *) (k :: * -> * -> *) b c.
(EnhancedCat a k, Object k b, Object k c, Object a b,
 Object a c) =>
k b c -> a b c
arr (Metric y -> Needle y -+> DualVector (Needle y)
forall v. Norm v -> v -+> DualVector v
applyNorm Metric y
ey) :: Needle y+>Needle' y)
                               String -> ShowS
forall a. [a] -> [a] -> [a]
++String
" and "String -> ShowS
forall a. [a] -> [a] -> [a]
++LinearMap ℝ (Needle y) (Needle y) -> String
forall a. Show a => a -> String
show (LinearFunction (Scalar (Needle y)) (Needle y) (Needle y)
-> LinearMap ℝ (Needle y) (Needle y)
forall (a :: * -> * -> *) (k :: * -> * -> *) b c.
(EnhancedCat a k, Object k b, Object k c, Object a b,
 Object a c) =>
k b c -> a b c
arr (Metric y -> Needle y -+> DualVector (Needle y)
forall v. Norm v -> v -+> DualVector v
applyNorm Metric y
eδ) :: Needle y+>Needle' y)
   where eδsp :: [(DualVector (Needle y), Maybe (Scalar (Needle y)))]
eδsp = Metric y
-> Metric y -> [(DualVector (Needle y), Maybe (Scalar (Needle y)))]
forall v.
SimpleSpace v =>
Seminorm v -> Seminorm v -> [(DualVector v, Maybe (Scalar v))]
sharedSeminormSpanningSystem Metric y
ey Metric y
eδ
         result :: Metric y
result = [DualVector (Needle y)] -> Metric y
forall v. LSpace v => [DualVector v] -> Seminorm v
spanNorm [ DualVector (Needle y)
f DualVector (Needle y) -> ℝ -> DualVector (Needle y)
forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^* Maybe ℝ -> ℝ
Maybe (Scalar (Needle y)) -> ℝ
ζ Maybe (Scalar (Needle y))
crl | (DualVector (Needle y)
f,Maybe (Scalar (Needle y))
crl) <- [(DualVector (Needle y), Maybe (Scalar (Needle y)))]
eδsp ]
         ζ :: Maybe ℝ -> ℝ
ζ = case (ℝ -> Bool) -> [ℝ] -> [ℝ]
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 (ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
>ℝ
0) ([ℝ] -> [ℝ]) -> ([Maybe ℝ] -> [ℝ]) -> [Maybe ℝ] -> [ℝ]
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
. [Maybe ℝ] -> [ℝ]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe ℝ] -> [ℝ]) -> [Maybe ℝ] -> [ℝ]
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (DualVector (Needle y), Maybe ℝ) -> Maybe ℝ
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd((DualVector (Needle y), Maybe ℝ) -> Maybe ℝ)
-> [(DualVector (Needle y), Maybe ℝ)] -> [Maybe ℝ]
forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>[(DualVector (Needle y), Maybe ℝ)]
[(DualVector (Needle y), Maybe (Scalar (Needle y)))]
eδsp of
            [] -> ℝ -> Maybe ℝ -> ℝ
forall (a :: * -> * -> *) b x.
(WellPointed a, Object a b, ObjectPoint a x) =>
x -> a b x
const ℝ
0
            [ℝ]
nzrelap
               -> let cre₁ :: ℝ
cre₁ = ℝ
1ℝ -> ℝ -> ℝ
forall 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₁)ℝ -> Int -> ℝ
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₂)ℝ -> Int -> ℝ
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₁ℝ -> Int -> ℝ
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₂ℝ -> Int -> ℝ
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' = Shade' y -> Shade' (Needle y) -> Shade' y
forall y. Refinable y => Shade' y -> Shade' (Needle y) -> Shade' y
defaultConvolveShade'
  
defaultConvolveShade' :: ∀ y . Refinable y => Shade' y -> Shade' (Needle y) -> Shade' y
defaultConvolveShade' :: Shade' y -> Shade' (Needle y) -> Shade' y
defaultConvolveShade' = case (PseudoAffineWitness y
forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness :: PseudoAffineWitness y) of
  PseudoAffineWitness (SemimanifoldWitness y
SemimanifoldWitness)
    -> \(Shade' y
y₀ Metric y
ey) (Shade' Needle y
δ₀ Metric (Needle y)
eδ) -> y -> Metric y -> Shade' y
forall x. x -> Metric x -> Shade' x
Shade' (y
y₀y -> Needle y -> y
forall x. Semimanifold x => x -> Needle x -> x
.+~^Needle y
δ₀)
                                          (Metric y -> Shade' y) -> Metric y -> Shade' y
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ [y] -> Metric y -> Metric y -> Metric y
forall y (p :: * -> *).
(Refinable y, Functor p) =>
p y -> Metric y -> Metric y -> Metric y
convolveMetric ([]::[y]) Metric y
ey Metric y
Metric (Needle y)
eδ

instance Refinable ℝ where
  refineShade' :: Shade' ℝ -> Shade' ℝ -> Maybe (Shade' ℝ)
refineShade' (Shade' ℝ
cl Metric ℝ
el) (Shade' ℝ
cr Metric ℝ
er)
         = case (Seminorm ℝ -> ℝ -> Scalar ℝ
forall v. LSpace v => Seminorm v -> v -> Scalar v
normSq Seminorm ℝ
Metric ℝ
el ℝ
1, Seminorm ℝ -> ℝ -> Scalar ℝ
forall v. LSpace v => Seminorm v -> v -> Scalar v
normSq Seminorm ℝ
Metric ℝ
er ℝ
1) of
             (ℝ
0, ℝ
_) -> Shade' ℝ -> Maybe (Shade' ℝ)
forall (m :: * -> *) a. Monad m (->) => a -> m a
return (Shade' ℝ -> Maybe (Shade' ℝ)) -> Shade' ℝ -> Maybe (Shade' ℝ)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ ℝ -> Metric ℝ -> Shade' ℝ
forall x. x -> Metric x -> Shade' x
Shade' ℝ
cr Metric ℝ
er
             (ℝ
_, ℝ
0) -> Shade' ℝ -> Maybe (Shade' ℝ)
forall (m :: * -> *) a. Monad m (->) => a -> m a
return (Shade' ℝ -> Maybe (Shade' ℝ)) -> Shade' ℝ -> Maybe (Shade' ℝ)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ ℝ -> Metric ℝ -> Shade' ℝ
forall x. x -> Metric x -> Shade' x
Shade' ℝ
cl Metric ℝ
el
             (ℝ
ql,ℝ
qr) | ℝ
qlℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
>ℝ
0, ℝ
qrℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
>ℝ
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
<$> [ℝ
ql,ℝ
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 Bool -> Maybe ()
forall (m :: * -> *) (k :: * -> * -> *).
(MonadPlus m k, Arrow k (->), Function k, UnitObject k ~ (),
 Object k Bool) =>
k Bool (m ())
guard (ℝ
bℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
<ℝ
t) Maybe () -> Maybe (Shade' ℝ) -> Maybe (Shade' ℝ)
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 = (ℝ
bℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
+ℝ
t)ℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
2
                               rm :: ℝ
rm = (ℝ
tℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
-ℝ
b)ℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
2
                           in Shade' ℝ -> Maybe (Shade' ℝ)
forall (m :: * -> *) a. Monad m (->) => a -> m a
return (Shade' ℝ -> Maybe (Shade' ℝ)) -> Shade' ℝ -> Maybe (Shade' ℝ)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ ℝ -> Metric ℝ -> Shade' ℝ
forall x. x -> Metric x -> Shade' x
Shade' ℝ
cm ([DualVector ℝ] -> Seminorm ℝ
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 ( Maybe (DebugView a)
forall y. Refinable y => Maybe (DebugView y)
debugView :: Maybe (DebugView a)
                   , Maybe (DebugView b)
forall y. Refinable y => Maybe (DebugView y)
debugView :: Maybe (DebugView b)
                   , DualSpaceWitness (Needle a)
forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualSpaceWitness (Needle a)
                   , DualSpaceWitness (Needle b)
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)
              -> DebugView (a, b) -> Maybe (DebugView (a, b))
forall a. a -> Maybe a
Just DebugView (a, b)
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 = Maybe (DebugView (LinearMap ℝ a b))
forall a. Maybe a
Nothing

intersectShade's :: ∀ y . Refinable y => NonEmpty (Shade' y) -> Maybe (Shade' y)
intersectShade's :: NonEmpty (Shade' y) -> Maybe (Shade' y)
intersectShade's (Shade' y
sh:|[Shade' y]
shs) = (Shade' y -> Shade' y -> Maybe (Shade' y))
-> Shade' y -> [Shade' y] -> Maybe (Shade' y)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
Hask.foldrM Shade' y -> Shade' y -> Maybe (Shade' y)
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 { WithAny x y -> y
_untopological :: y
                , WithAny x y -> x
_topological :: !x  }
 deriving (a -> WithAny x b -> WithAny x a
(a -> b) -> WithAny x a -> WithAny x b
(forall a b. (a -> b) -> WithAny x a -> WithAny x b)
-> (forall a b. a -> WithAny x b -> WithAny x a)
-> Functor (WithAny x)
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
<$ :: a -> WithAny x b -> WithAny x a
$c<$ :: forall x a b. a -> WithAny x b -> WithAny x a
fmap :: (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
[WithAny x y] -> ShowS
WithAny x y -> String
(Int -> WithAny x y -> ShowS)
-> (WithAny x y -> String)
-> ([WithAny x y] -> ShowS)
-> Show (WithAny x y)
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 x. WithAny x y -> Rep (WithAny x y) x)
-> (forall x. Rep (WithAny x y) x -> WithAny x y)
-> Generic (WithAny x y)
forall x. Rep (WithAny x y) x -> WithAny x y
forall x. WithAny x y -> Rep (WithAny x y) x
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 = y -> x -> WithAny x y
forall x y. y -> x -> WithAny x y
WithAny y
y (x -> WithAny x y) -> x -> WithAny x y
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ x
xx -> Needle x -> x
forall x. Semimanifold x => x -> Needle x -> x
.+~^Needle x
Needle (WithAny x y)
δx
  semimanifoldWitness :: SemimanifoldWitness (WithAny x y)
semimanifoldWitness = case SemimanifoldWitness x
forall x. Semimanifold x => SemimanifoldWitness x
semimanifoldWitness :: SemimanifoldWitness x of
      SemimanifoldWitness x
SemimanifoldWitness -> SemimanifoldWitness (WithAny x y)
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 .-~! :: WithAny x y -> WithAny x y -> Needle (WithAny x y)
.-~! WithAny y
_ x
ξ = x
xx -> x -> Needle x
forall 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
xx -> x -> Maybe (Needle x)
forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
ξ
  pseudoAffineWitness :: PseudoAffineWitness (WithAny x y)
pseudoAffineWitness = case PseudoAffineWitness x
forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness :: PseudoAffineWitness x of
      PseudoAffineWitness (SemimanifoldWitness x
SemimanifoldWitness)
       -> SemimanifoldWitness (WithAny x y)
-> PseudoAffineWitness (WithAny x y)
forall x.
PseudoAffine (Needle x) =>
SemimanifoldWitness x -> PseudoAffineWitness x
PseudoAffineWitness (SemimanifoldWitness (WithAny x y)
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
xx -> x -> Diff x
forall 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 = y -> x -> WithAny x y
forall x y. y -> x -> WithAny x y
WithAny y
y (x -> WithAny x y) -> x -> WithAny x y
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ x
xx -> Diff x -> x
forall p. AffineSpace p => p -> Diff p -> p
.+^Diff x
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 = y -> x -> WithAny x y
forall x y. y -> x -> WithAny x y
WithAny y
y (x -> WithAny x y) -> x -> WithAny x y
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Scalar x
Scalar (WithAny x y)
μScalar x -> x -> x
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 = y -> x -> WithAny x y
forall x y. y -> x -> WithAny x y
WithAny y
forall a. Monoid a => a
mempty x
forall v. AdditiveGroup v => v
zeroV
  negateV :: WithAny x y -> WithAny x y
negateV (WithAny y
y x
x) = y -> x -> WithAny x y
forall x y. y -> x -> WithAny x y
WithAny y
y (x -> WithAny x y) -> x -> WithAny x y
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ x -> x
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
ξ = y -> x -> WithAny x y
forall x y. y -> x -> WithAny x y
WithAny (y -> y -> y
forall a. Monoid a => a -> a -> a
mappend y
y y
υ) (x
xx -> x -> x
forall v. AdditiveGroup v => v -> v -> v
^+^x
ξ)

instance (AdditiveGroup x) => Hask.Applicative (WithAny x) where
  pure :: a -> WithAny x a
pure a
x = a -> x -> WithAny x a
forall x y. y -> x -> WithAny x y
WithAny a
x x
forall v. AdditiveGroup v => v
zeroV
  WithAny a -> b
f x
x <*> :: WithAny x (a -> b) -> WithAny x a -> WithAny x b
<*> WithAny a
t x
ξ = b -> x -> WithAny x b
forall x y. y -> x -> WithAny x y
WithAny (a -> b
f a
t) (x
xx -> x -> x
forall v. AdditiveGroup v => v -> v -> v
^+^x
ξ)
  
instance (AdditiveGroup x) => Hask.Monad (WithAny x) where
  return :: a -> WithAny x a
return a
x = a -> x -> WithAny x a
forall x y. y -> x -> WithAny x y
WithAny a
x x
forall v. AdditiveGroup v => v
zeroV
  WithAny a
y x
x >>= :: WithAny x a -> (a -> WithAny x b) -> WithAny x b
>>= a -> WithAny x b
f = b -> x -> WithAny x b
forall x y. y -> x -> WithAny x y
WithAny b
r (x -> WithAny x b) -> x -> WithAny x b
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ x
xx -> x -> x
forall 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 :: y -> Shade x -> Shade (WithAny x y)
shadeWithAny y
y (Shade x
x Metric' x
xe) = WithAny x y -> Metric' (WithAny x y) -> Shade (WithAny x y)
forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade (y -> x -> WithAny x y
forall x y. y -> x -> WithAny x y
WithAny y
y x
x) Metric' x
Metric' (WithAny x y)
xe

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

                      




extractJust :: (a->Maybe b) -> [a] -> (Maybe b, [a])
extractJust :: (a -> Maybe b) -> [a] -> (Maybe b, [a])
extractJust a -> Maybe b
f [] = (Maybe b
forall a. Maybe a
Nothing,[])
extractJust a -> Maybe b
f (a
x:[a]
xs) | Just b
r <- a -> Maybe b
f a
x  = (b -> Maybe b
forall a. a -> Maybe a
Just b
r, [a]
xs)
                     | Bool
otherwise      = ([a] -> [a]) -> (Maybe b, [a]) -> (Maybe b, [a])
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
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ((Maybe b, [a]) -> (Maybe b, [a]))
-> (Maybe b, [a]) -> (Maybe b, [a])
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (a -> Maybe b) -> [a] -> (Maybe b, [a])
forall a b. (a -> Maybe b) -> [a] -> (Maybe b, [a])
extractJust a -> Maybe b
f [a]
xs


prettyShowShade' :: LtdErrorShow x => Shade' x -> String
prettyShowShade' :: Shade' x -> String
prettyShowShade' Shade' x
sh = Int -> Shade' x -> ShowS
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 = Int -> Shade' x -> ShowS
forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
prettyShowsPrecShade'
instance LtdErrorShow x => SP.Show (Shade x) where
  showsPrec :: Int -> Shade x -> ShowS
showsPrec = Int -> Shade x -> ShowS
forall x. LtdErrorShow x => Int -> Shade x -> ShowS
prettyShowsPrecShade


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

instance LtdErrorShow ℝ⁰ where
  showsPrecShade'_errorLtdC :: Int -> Shade' ℝ⁰ -> ShowS
showsPrecShade'_errorLtdC Int
_ Shade' ℝ⁰
_ = (String
"zeroV"String -> ShowS
forall a. [a] -> [a] -> [a]
++)
instance LtdErrorShow ℝ where
  showsPrecShade'_errorLtdC :: Int -> Shade' ℝ -> ShowS
showsPrecShade'_errorLtdC Int
_ (Shade' ℝ
v Metric ℝ
u) = ℝ -> ℝ -> ShowS
forall n. RealFloat n => n -> n -> ShowS
errorLtdShow (ℝ
δℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
2) ℝ
v
   where δ :: ℝ
δ = case Seminorm ℝ
Metric ℝ
uSeminorm ℝ -> ℝ -> DualVector ℝ
forall v. LSpace v => Norm v -> v -> DualVector v
<$|ℝ
1 of
          DualVector ℝ
σ | ℝ
DualVector ℝ
σℝ -> ℝ -> Bool
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
$ ℝ
1ℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
DualVector ℝ
σ
          DualVector ℝ
_       -> ℝ
vℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
*ℝ
10
instance LtdErrorShow ℝ² where
  showsPrecShade'_errorLtdC :: Int -> Shade' ℝ² -> ShowS
showsPrecShade'_errorLtdC Int
_ Shade' ℝ²
sh = (String
"V2 "String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
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 ShowS -> ShowS -> ShowS
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
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
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 = Embedding (Affine ℝ) ℝ ℝ² -> Shade' ℝ² -> Shade' ℝ
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 (Lens' ℝ² ℝ -> Embedding (Affine ℝ) ℝ ℝ²
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 Lens' ℝ² ℝ
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x) Shade' ℝ²
sh :: Shade' ℝ
         shy :: Shade' ℝ
shy = Embedding (Affine ℝ) ℝ ℝ² -> Shade' ℝ² -> Shade' ℝ
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 (Lens' ℝ² ℝ -> Embedding (Affine ℝ) ℝ ℝ²
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 Lens' ℝ² ℝ
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y) Shade' ℝ²
sh :: Shade' ℝ
         shshx :: ShowS
shshx = Int -> Shade' ℝ -> ShowS
forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
showsPrecShade'_errorLtdC Int
0 Shade' ℝ
shx 
         shshy :: ShowS
shshy = Int -> Shade' ℝ -> ShowS
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 "String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
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 ShowS -> ShowS -> ShowS
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
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
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 ShowS -> ShowS -> ShowS
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
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
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 = Embedding (Affine ℝ) ℝ ℝ³ -> Shade' ℝ³ -> Shade' ℝ
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 (Lens' ℝ³ ℝ -> Embedding (Affine ℝ) ℝ ℝ³
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 Lens' ℝ³ ℝ
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x) Shade' ℝ³
sh :: Shade' ℝ
         shy :: Shade' ℝ
shy = Embedding (Affine ℝ) ℝ ℝ³ -> Shade' ℝ³ -> Shade' ℝ
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 (Lens' ℝ³ ℝ -> Embedding (Affine ℝ) ℝ ℝ³
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 Lens' ℝ³ ℝ
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y) Shade' ℝ³
sh :: Shade' ℝ
         shz :: Shade' ℝ
shz = Embedding (Affine ℝ) ℝ ℝ³ -> Shade' ℝ³ -> Shade' ℝ
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 (Lens' ℝ³ ℝ -> Embedding (Affine ℝ) ℝ ℝ³
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 Lens' ℝ³ ℝ
forall (t :: * -> *) a. R3 t => Lens' (t a) a
_z) Shade' ℝ³
sh :: Shade' ℝ
         shshx :: ShowS
shshx = Int -> Shade' ℝ -> ShowS
forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
showsPrecShade'_errorLtdC Int
0 Shade' ℝ
shx 
         shshy :: ShowS
shshy = Int -> Shade' ℝ -> ShowS
forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
showsPrecShade'_errorLtdC Int
0 Shade' ℝ
shy 
         shshz :: ShowS
shshz = Int -> Shade' ℝ -> ShowS
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 "String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
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 ShowS -> ShowS -> ShowS
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
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
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 ShowS -> ShowS -> ShowS
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
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
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 ShowS -> ShowS -> ShowS
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
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
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 = Embedding (Affine ℝ) ℝ ℝ⁴ -> Shade' ℝ⁴ -> Shade' ℝ
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 (Lens' ℝ⁴ ℝ -> Embedding (Affine ℝ) ℝ ℝ⁴
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 Lens' ℝ⁴ ℝ
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x) Shade' ℝ⁴
sh :: Shade' ℝ
         shy :: Shade' ℝ
shy = Embedding (Affine ℝ) ℝ ℝ⁴ -> Shade' ℝ⁴ -> Shade' ℝ
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 (Lens' ℝ⁴ ℝ -> Embedding (Affine ℝ) ℝ ℝ⁴
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 Lens' ℝ⁴ ℝ
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y) Shade' ℝ⁴
sh :: Shade' ℝ
         shz :: Shade' ℝ
shz = Embedding (Affine ℝ) ℝ ℝ⁴ -> Shade' ℝ⁴ -> Shade' ℝ
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 (Lens' ℝ⁴ ℝ -> Embedding (Affine ℝ) ℝ ℝ⁴
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 Lens' ℝ⁴ ℝ
forall (t :: * -> *) a. R3 t => Lens' (t a) a
_z) Shade' ℝ⁴
sh :: Shade' ℝ
         shw :: Shade' ℝ
shw = Embedding (Affine ℝ) ℝ ℝ⁴ -> Shade' ℝ⁴ -> Shade' ℝ
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 (Lens' ℝ⁴ ℝ -> Embedding (Affine ℝ) ℝ ℝ⁴
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 Lens' ℝ⁴ ℝ
forall (t :: * -> *) a. R4 t => Lens' (t a) a
_w) Shade' ℝ⁴
sh :: Shade' ℝ
         shshx :: ShowS
shshx = Int -> Shade' ℝ -> ShowS
forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
showsPrecShade'_errorLtdC Int
0 Shade' ℝ
shx 
         shshy :: ShowS
shshy = Int -> Shade' ℝ -> ShowS
forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
showsPrecShade'_errorLtdC Int
0 Shade' ℝ
shy 
         shshz :: ShowS
shshz = Int -> Shade' ℝ -> ShowS
forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
showsPrecShade'_errorLtdC Int
0 Shade' ℝ
shz 
         shshw :: ShowS
shshw = Int -> Shade' ℝ -> ShowS
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 ( LtdErrorShowWitness x
forall m. LtdErrorShow m => LtdErrorShowWitness m
ltdErrorShowWitness :: LtdErrorShowWitness x
                             , LtdErrorShowWitness y
forall m. LtdErrorShow m => LtdErrorShowWitness m
ltdErrorShowWitness :: LtdErrorShowWitness y ) of
   (  LtdErrorShowWitness(PseudoAffineWitness(SemimanifoldWitness x
SemimanifoldWitness))
    , LtdErrorShowWitness(PseudoAffineWitness(SemimanifoldWitness y
SemimanifoldWitness)) )
    ->PseudoAffineWitness (x, y) -> LtdErrorShowWitness (x, y)
forall m.
(LtdErrorShow m, LtdErrorShow (Needle m)) =>
PseudoAffineWitness m -> LtdErrorShowWitness m
LtdErrorShowWitness(SemimanifoldWitness (x, y) -> PseudoAffineWitness (x, y)
forall x.
PseudoAffine (Needle x) =>
SemimanifoldWitness x -> PseudoAffineWitness x
PseudoAffineWitness(SemimanifoldWitness (x, y)
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
'('Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
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 ShowS -> ShowS -> ShowS
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
','Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
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 ShowS -> ShowS -> ShowS
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
')'Char -> ShowS
forall a. a -> [a] -> [a]
:)
   where (Shade' x
shx,Shade' y
shy) = Shade' (x, y) -> (Shade' x, Shade' 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, y) -> (shade x, shade y)
factoriseShade Shade' (x, y)
sh
         shshx :: ShowS
shshx = Int -> Shade' x -> ShowS
forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
showsPrecShade'_errorLtdC Int
0 Shade' x
shx 
         shshy :: ShowS
shshy = Int -> Shade' y -> ShowS
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
pInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
7) (ShowS -> ShowS) -> ShowS -> ShowS
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$
         (String
"().<"String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
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
. Int -> Shade' v -> ShowS
forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
showsPrecShade'_errorLtdC Int
7
                        ((LinearMap ℝ v ℝ +> v) -> Shade' (LinearMap ℝ v ℝ) -> Shade' v
forall (shade :: * -> *) x y.
(IsShade shade, SimpleSpace x, SimpleSpace y, Scalar x ~ Scalar y,
 Num' (Scalar x)) =>
(x +> y) -> shade x -> shade y
linIsoTransformShade (LinearFunction (Scalar v) (LinearMap ℝ v ℝ) v
-> LinearMap ℝ (LinearMap ℝ v ℝ) v
forall (a :: * -> * -> *) (k :: * -> * -> *) b c.
(EnhancedCat a k, Object k b, Object k c, Object a b,
 Object a c) =>
k b c -> a b c
arr LinearFunction (Scalar v) (LinearMap ℝ v ℝ) v
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
pInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
7) (ShowS -> ShowS) -> ShowS -> ShowS
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$
         (   String
"Left ().<"String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
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
. Int -> Shade' v -> ShowS
forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
showsPrecShade'_errorLtdC Int
7 Shade' v
shx
       ShowS -> ShowS -> ShowS
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().<"String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
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
. Int -> Shade' v -> ShowS
forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
showsPrecShade'_errorLtdC Int
7 Shade' v
shy
   where (Shade' v
shx,Shade' v
shy) = Shade' (v, v) -> (Shade' v, Shade' v)
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
                        ((LinearMap ℝ v (ℝ, ℝ) +> (v, v))
-> Shade' (LinearMap ℝ v (ℝ, ℝ)) -> Shade' (v, v)
forall (shade :: * -> *) x y.
(IsShade shade, SimpleSpace x, SimpleSpace y, Scalar x ~ Scalar y,
 Num' (Scalar x)) =>
(x +> y) -> shade x -> shade y
linIsoTransformShade ((LinearMap (Scalar v) v (ℝ, ℝ) -> (v, v))
-> LinearMap ℝ (LinearMap (Scalar v) v (ℝ, ℝ)) (v, v)
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 ((LinearMap (Scalar v) v (ℝ, ℝ) -> (v, v))
 -> LinearMap ℝ (LinearMap (Scalar v) v (ℝ, ℝ)) (v, v))
-> (LinearMap (Scalar v) v (ℝ, ℝ) -> (v, v))
-> LinearMap ℝ (LinearMap (Scalar v) v (ℝ, ℝ)) (v, v)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \LinearMap (Scalar v) v (ℝ, ℝ)
f
                                                -> ( LinearFunction (Scalar v) (LinearMap (Scalar v) v ℝ) v
forall v. LinearSpace v => (v +> Scalar v) -+> DualVector v
fromLinearForm LinearFunction (Scalar v) (LinearMap (Scalar v) v ℝ) v
-> LinearMap (Scalar v) v ℝ -> v
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ LinearMap (Scalar v) (ℝ, ℝ) ℝ
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst LinearMap (Scalar v) (ℝ, ℝ) ℝ
-> LinearMap (Scalar v) v (ℝ, ℝ) -> LinearMap (Scalar v) 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
. LinearMap (Scalar v) v (ℝ, ℝ)
f
                                                   , LinearFunction (Scalar v) (LinearMap (Scalar v) v ℝ) v
forall v. LinearSpace v => (v +> Scalar v) -+> DualVector v
fromLinearForm LinearFunction (Scalar v) (LinearMap (Scalar v) v ℝ) v
-> LinearMap (Scalar v) v ℝ -> v
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ LinearMap (Scalar v) (ℝ, ℝ) ℝ
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd LinearMap (Scalar v) (ℝ, ℝ) ℝ
-> LinearMap (Scalar v) v (ℝ, ℝ) -> LinearMap (Scalar v) 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
. LinearMap (Scalar v) v (ℝ, ℝ)
f ) ) Shade' (LinearMap ℝ v (ℝ, ℝ))
sh
                             :: Shade' (v,v))
        
                       
instance LtdErrorShow x => Show (Shade' x) where
  showsPrec :: Int -> Shade' x -> ShowS
showsPrec = Int -> Shade' x -> ShowS
forall m. LtdErrorShow m => Int -> Shade' m -> ShowS
prettyShowsPrecShade'