manifolds 0.3.0.0 → 0.4.0.0

raw patch · 22 files changed

+3061/−2771 lines, 22 filesdep +lensdep +manifolds-coredep −microlensdep −microlens-thdep −trivial-constraintdep ~linearmap-categorybinary-addedPVP ok

version bump matches the API change (PVP)

Dependencies added: lens, manifolds-core

Dependencies removed: microlens, microlens-th, trivial-constraint

Dependency ranges changed: linearmap-category

API changes (from Hackage documentation)

Files

• Data/CoNat.hs +2/−1
• Data/Function/Affine.hs +132/−358
• Data/Function/Differentiable.hs +156/−102
• Data/Function/Differentiable/Data.hs +4/−4
• Data/Manifold/Atlas.hs +80/−0
• Data/Manifold/Cone.hs +4/−5
• Data/Manifold/DifferentialEquation.hs +37/−11
• Data/Manifold/Griddable.hs +7/−3
• Data/Manifold/PseudoAffine.hs +44/−300
• Data/Manifold/Riemannian.hs +17/−6
• Data/Manifold/TreeCover.hs +1853/−1579
• Data/Manifold/Types.hs +119/−89
• Data/Manifold/Types/Primitive.hs +8/−43
• Data/Manifold/Types/Stiefel.hs +0/−1
• Data/Manifold/Web.hs +590/−261
• Data/SetLike/Intersection.hs +3/−4
• images/examples/ShadeCombinations/2Dconvolution-skewed.png binary
• images/examples/TreesAndWebs/2D-cartesian-strangeaspect.png binary
• images/examples/TreesAndWebs/2D-cartesiandisk.png binary
• images/examples/TreesAndWebs/2D-normaldistrib.png binary
• images/examples/TreesAndWebs/2D-scatter.png binary
• manifolds.cabal +5/−4

@@ -25,6 +25,7 @@ {-# LANGUAGE PatternGuards              #-} {-# LANGUAGE TypeOperators              #-} {-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE ExplicitNamespaces         #-} {-# LANGUAGE DataKinds                  #-} {-# LANGUAGE PolyKinds                  #-} @@ -34,7 +35,7 @@                   , ftorTryToMatch, ftorTryToMatchT, ftorTryToMatchTT                   , KnownNat(..)                   , Range(..)-                  , FreeVect(..), (^)(), freeVector, freeCons, freeSnoc+                  , FreeVect(..), type (^)(), freeVector, freeCons, freeSnoc                   , replicVector, indices, perfectZipWith, freeRotate                   , ) where 

@@ -30,20 +30,22 @@   module Data.Function.Affine (-              Affine-            , linearAffine-            , toOffsetSlope, toOffset'Slope +              Affine(..)+            , evalAffine+            , fromOffsetSlope             ) where        import Data.Semigroup +import Data.MemoTrie import Data.VectorSpace import Data.AffineSpace import Data.Tagged import Data.Manifold.Types.Primitive import Data.Manifold.PseudoAffine+import Data.Manifold.Atlas  import qualified Prelude import qualified Control.Applicative as Hask@@ -59,368 +61,140 @@   data Affine s d c where-   Subtract :: AffineManifold α => Affine s (α,α) (Needle α)-   AddTo :: Affine s (α, Needle α) α-   ScaleWith :: (LinearManifold α, LinearManifold β) => (α+>β) -> Affine s α β-   ReAffine :: ReWellPointed (Affine s) α β -> Affine s α β--reAffine :: ReWellPointed (Affine s) α β -> Affine s α β-reAffine (ReWellPointed f) = f-reAffine f = ReAffine f--pattern Specific f = ReWellPointed f-pattern Id = ReAffine WellPointedId-infixr 1 :>>>, :<<<-pattern f :>>> g <- ReAffine (WellPointedCompo (reAffine -> f) (reAffine -> g))-pattern g :<<< f <- ReAffine (WellPointedCompo (reAffine -> f) (reAffine -> g))-pattern Swap = ReAffine WellPointedSwap-pattern AttachUnit = ReAffine WellPointedAttachUnit-pattern DetachUnit = ReAffine WellPointedDetachUnit-pattern Regroup = ReAffine WellPointedRegroup-pattern Regroup' = ReAffine WellPointedRegroup_-pattern Terminal = ReAffine WellPointedTerminal-pattern Fst = ReAffine WellPointedFst-pattern Snd = ReAffine WellPointedSnd-infixr 3 :***, :&&&-pattern f :*** g <- ReAffine (WellPointedPar (reAffine -> f) (reAffine -> g))-pattern f :&&& g <- ReAffine (WellPointedFanout (reAffine -> f) (reAffine -> g))-pattern Const c = ReAffine (WellPointedConst c)---toOffsetSlope :: (MetricScalar s, WithField s LinearManifold d-                                 , WithField s AffineManifold c )-                      => Affine s d c -> (c, Needle d +> Needle c)-toOffsetSlope f = toOffset'Slope f zeroV--type MetricScalar s = (Num''' s, LSpace (ZeroDim s))--linear :: (LSpace a, LSpace b, Scalar a ~ Scalar b)-             => (a -> b) -> (a+>b)-linear = arr . LinearFunction---- | Basically evaluates an affine function as a generic differentiable one,---   yielding at a given reference point the result and Jacobian. Unlike with---   'Data.Function.Differentiable.Differentiable', the induced 1st-order Taylor---   series is equal to the function!-toOffset'Slope :: ( MetricScalar s, WithField s AffineManifold d-                                   , WithField s AffineManifold c )-                      => Affine s d c -> d -> (c, Needle d +> Needle c)-toOffset'Slope Subtract (a,b) = (a.-.b, linear $ uncurry(^-^))-toOffset'Slope AddTo (p,v) = (p.+^v, linear $ uncurry(^+^))-toOffset'Slope (ScaleWith q) ref = (q $ ref, q)-toOffset'Slope Id ref = (ref, linear id)-toOffset'Slope (f :>>> g) ref = case toOffset'Slope f ref of-                  (cf,sf) -> case toOffset'Slope g cf of-                     (cg,sg)     -> (cg, sg . sf)-toOffset'Slope Swap ref = (swap ref, linear swap)-toOffset'Slope AttachUnit ref = ((ref,Origin), linear (,Origin))-toOffset'Slope DetachUnit ref = (fst ref, linear fst)-toOffset'Slope Regroup ref = (regroup ref, linear regroup)-toOffset'Slope Regroup' ref = (regroup' ref, linear regroup')-toOffset'Slope (f:***g) ref = case ( toOffset'Slope f (fst ref)-                                 , toOffset'Slope g (snd ref) ) of-                  ((cf, sf), (cg, sg)) -> ((cf,cg), sf *** sg)-toOffset'Slope Terminal ref = (Origin, zeroV)-toOffset'Slope Fst ref = (fst ref, linear fst)-toOffset'Slope Snd ref = (snd ref, linear snd)-toOffset'Slope (f:&&&g) ref = case ( toOffset'Slope (arr f) ref-                                  , toOffset'Slope (arr g) ref ) of-                  ((cf, sf), (cg, sg)) -> ((cf,cg), sf &&& sg)-toOffset'Slope (Const c) ref = (c, zeroV)-            -coOffsetForm :: ( MetricScalar s, WithField s AffineManifold d-                                , WithField s AffineManifold c )-                      => Affine s d c -> Affine s d c-coOffsetForm (ScaleWith q) = id&&&const zeroV >>> Subtract >>> ScaleWith q-coOffsetForm ((coOffsetForm -> Id:&&&Const cof :>>> Subtract :>>> f) :>>> g)-                    = id&&&const cof >>> Subtract >>> (f >>> g)-coOffsetForm ( (coOffsetForm -> Id:&&&Const cof :>>> Subtract :>>> f)-          :*** (coOffsetForm -> Id:&&&Const cog :>>> Subtract :>>> g) )-     = id&&&const(cof,cog) >>> Subtract >>> (f***g)-coOffsetForm (Id:&&&Const cof :>>> Subtract)-           = (Id&&&Const cof >>> ReAffine (ReWellPointed Subtract`WellPointedCompo`WellPointedId))-coOffsetForm f = f--pattern PreSubtract c f <- (coOffsetForm -> Id:&&&Const c :>>> Subtract :>>> f)--preSubtract :: ( MetricScalar s, WithField s AffineManifold d-                               , WithField s AffineManifold c )-               => c -> Affine s (Diff c) d -> Affine s c d--- The specialised clauses may not actually be useful here.-preSubtract _ (Const d) = const d-preSubtract _ Terminal = Terminal-preSubtract c (f:>>>g) = preSubtract c f >>>! g--- preSubtract t (f:***g) | (c,d)<-t = preSubtract c f *** preSubtract d g-preSubtract c (f:&&&g) = preSubtract c f &&& preSubtract c g-preSubtract c f = id&&&const c >>>! Subtract >>>! f-   -pattern PostAdd c f <- f:&&&Const c :>>> AddTo-pattern PostAdd' c f <- Const c:&&&f :>>> AddTo--postAdd :: (MetricScalar s, WithField s AffineManifold d, WithField s AffineManifold c)-               => Diff d -> Affine s c d -> Affine s c d-postAdd c f = f&&&const c >>>! AddTo-postAdd' :: (MetricScalar s, WithField s AffineManifold d, WithField s AffineManifold c)-               => d -> Affine s c (Diff d) -> Affine s c d-postAdd' c f = const c&&&f >>>! AddTo--instance (MetricScalar s) => EnhancedCat (->) (Affine s) where-  arr f = fst . toOffset'Slope f--instance (MetricScalar s) => EnhancedCat (Affine s) (ReWellPointed (Affine s)) where-  arr (Specific c) = c-  arr c = ReAffine c--instance (MetricScalar s, WithField s AffineManifold d, WithField s AffineManifold c)-                  => AffineSpace (Affine s d c) where-  type Diff (Affine s d c) = Affine s d (Diff c)-  -  ScaleWith q .-. ScaleWith r = ScaleWith $ q^-^r-  (PostAdd c (ScaleWith q)) .-. g = let (d, r) = toOffsetSlope g-                                    in postAdd (c.-.d) $ ScaleWith (q^-^r)-  f .-. (PostAdd d (ScaleWith r)) = let (c, q) = toOffsetSlope f-                                    in postAdd (c.-.d) $ ScaleWith (q^-^r)-  (PostAdd' c (ScaleWith q)) .-. g = let (d, r) = toOffsetSlope g-                                     in postAdd (c.-.d) $ ScaleWith (q^-^r)-  f .-. (PostAdd' d (ScaleWith r)) = let (c, q) = toOffsetSlope f-                                     in postAdd (c.-.d) $ ScaleWith (q^-^r)-  -  Id .-. Id = const zeroV-  Fst .-. Fst = const zeroV-  Snd .-. Snd = const zeroV-  Swap .-. Swap = const zeroV-  AttachUnit .-. AttachUnit = const zeroV-  DetachUnit .-. DetachUnit = const zeroV-  Terminal .-. _ = Terminal-  _ .-. Terminal = Terminal-  Subtract .-. Subtract = const zeroV-  AddTo .-. AddTo = const zeroV-  -  Const c .-. Const d = Const $ c.-.d-  -  Fst .-. Snd = Subtract--  (f:***g) .-. (h:***i) = f.-.h *** g.-.i-  (f:***g) .-. Const (c,d) = f.-.const c *** g.-.const d-  ζ .-. (f:***g) | Const (c,d) <- ζ = const c.-.f *** const d.-.g-  (f:&&&g) .-. (h:&&&i) = f.-.h &&& g.-.i-  (f:&&&_) .-. AttachUnit = f.-.id >>>! AttachUnit-  (f:&&&g) .-. Const (c,d) = f.-.const c &&& g.-.const d-  ζ .-. (f:&&&g) | Const (c,d) <- ζ = const c.-.f &&& const d.-.g--  ScaleWith q .-. f = let (c, r) = toOffset'Slope f zeroV-                      in postAdd (negateV c) $ ScaleWith (q^-^r)-  f .-. ScaleWith q = let (c, r) = toOffset'Slope f zeroV-                      in postAdd c $ ScaleWith (r^-^q)-  -  PreSubtract b f .-. g = let (c, q) = toOffsetSlope f-                              (d, r) = toOffset'Slope g b-                          in preSubtract b . postAdd (c.-.d) $ ScaleWith (q^-^r)-      -- f x = q·x + c-      -- g x = r·x + w-      -- d = r·b + w-      -- (q−r)·(x−b) = q·x − q⋅b − r⋅x + r⋅b-      -- s x = f (x−b) − g x-      --     = q⋅(x−b) + c − r⋅x − w-      --     = q⋅x − q⋅b + c − r⋅x − w-      --     = (q−r)·(x−b) + c − r⋅b − w-      --     = (q−r)·(x−b) + c − d-  -  -- According to GHC, this clause overlaps with the above. Hm...-  f .-. PreSubtract b g = let (c, q) = toOffset'Slope f b-                              (d, r) = toOffsetSlope g-                          in preSubtract b $ postAdd (c.-.d) $ ScaleWith (q^-^r)-      -- f x = q·x + v-      -- g x = r·x + d-      -- c = q·b + v-      -- (q−r)·(x−b) = q·x − q⋅b − r⋅x + r⋅b-      -- s x = f x − g (x−b)-      --     = q⋅x + v − r⋅(x−b) − d-      --     = q⋅x + v − r⋅x + r⋅b − d-      --     = (q−r)·(x−b) + q⋅b + v − d-      --     = (q−r)·(x−b) + c − d-  -  f .-. g = f&&&g >>> Subtract-  -  -  ScaleWith q .+^ ScaleWith r = ScaleWith $ q^+^r-  (PostAdd c (ScaleWith q)) .+^ g = let (d, r) = toOffsetSlope g-                                    in postAdd (c.+^d) $ ScaleWith (q^+^r)-  f .+^ (PostAdd d (ScaleWith r)) = let (c, q) = toOffsetSlope f-                                    in postAdd' (c.+^d) $ ScaleWith (q^+^r)-  (PostAdd' c (ScaleWith q)) .+^ g = let (d, r) = toOffsetSlope g-                                     in postAdd' (c.+^d) $ ScaleWith (q^+^r)-  f .+^ (PostAdd' d (ScaleWith r)) = let (c, q) = toOffsetSlope f-                                     in postAdd' (c.+^d) $ ScaleWith (q^+^r)-  (f:***g) .+^ (h:***i) = f.+^h *** g.+^i-  (f:&&&g) .+^ (h:&&&i) = f.+^h &&& g.+^i-  -  Const c .+^ Const c' = const (c.+^c')--  Terminal .+^ _ = Terminal-  Const c .+^ Terminal = Const c-  Const c .+^ f = const c&&&f >>> AddTo-  -  Id .+^ Id = Id >>> ScaleWith (linear (^*2))-  Fst .+^ Fst = Fst >>> ScaleWith (linear (^*2))-  Snd .+^ Snd = Snd >>> ScaleWith (linear (^*2))-  Fst .+^ Snd = AddTo-  Swap .+^ Swap = Swap >>> ScaleWith (linear (^*2))-  -  f .+^ Id = let (c,q) = toOffset'Slope f zeroV-             in const c&&&ScaleWith (q^+^id) >>>! AddTo-  f .+^ AttachUnit = let (c,q) = toOffset'Slope f zeroV-                     in postAdd' c $ ScaleWith (q^+^linear(,Origin))-  f .+^ DetachUnit = let (c,q) = toOffset'Slope f zeroV-                     in postAdd' c $ ScaleWith (q^+^linear fst)-  f .+^ Swap = let (c,q) = toOffset'Slope f zeroV-               in postAdd' c $ ScaleWith (q^+^linear swap)-  -  PreSubtract b f .+^ g = let (c, q) = toOffsetSlope f-                              (d, r) = toOffset'Slope g b-                          in preSubtract b . postAdd' (c.+^d) $ ScaleWith (q^+^r)-      -- f x = q·x + c-      -- g x = r·x + w-      -- d = r·b + w-      -- (q+r)·(x−b) = q·x − q⋅b + r⋅x − r⋅b-      -- s x = f (x−b) + g x-      --     = q⋅(x−b) + c + r⋅x + w-      --     = q⋅x − q⋅b + c + r⋅x + w-      --     = (q+r)·(x−b) + c + r⋅b + w-      --     = (q−r)·(x−b) + c + d-  -  f .+^ PreSubtract b g = let (c, q) = toOffset'Slope f b-                              (d, r) = toOffsetSlope g-                          in preSubtract b . postAdd' (c.+^d) $ ScaleWith (q^+^r)-      -- f x = q·x + v-      -- g x = r·x + d-      -- c = q·b + v-      -- (q+r)·(x−b) = q·x − q⋅b + r⋅x − r⋅b-      -- s x = f x + g (x−b)-      --     = q⋅x + v + r⋅(x−b) + d-      --     = q⋅x + v + r⋅x − r⋅b + d-      --     = (q+r)·(x−b) + q⋅b + v + d-      --     = (q+r)·(x−b) + c + d-  -  f .+^ g = f&&&g >>> AddTo+    Affine :: (ChartIndex d :->: (c, LinearMap s (Needle d) (Needle c)))+               -> Affine s d c +instance Category (Affine s) where+  type Object (Affine s) x = ( Manifold x, Interior x ~ x+                             , Atlas x, LinearSpace (Needle x)+                             , Scalar (Needle x) ~ s, HasTrie (ChartIndex x) )+  id = Affine . trie $ chartReferencePoint >>> id &&& const id+  Affine f . Affine g = Affine . trie+      $ \ixa -> case untrie g ixa of+           (b, ða'b) -> case untrie f $ lookupAtlas b of+            (c, ðb'c) -> (c, ðb'c . ða'b) +instance ∀ s . Num' s => Cartesian (Affine s) where+  type UnitObject (Affine s) = ZeroDim s+  swap = Affine . trie $ chartReferencePoint >>> swap &&& const swap+  attachUnit = Affine . trie $ chartReferencePoint >>> \a -> ((a,Origin), attachUnit)+  detachUnit = Affine . trie $ chartReferencePoint+                 >>> \(a,Origin::ZeroDim s) -> (a, detachUnit)+  regroup = Affine . trie $ chartReferencePoint >>> regroup &&& const regroup+  regroup' = Affine . trie $ chartReferencePoint >>> regroup' &&& const regroup' -instance (MetricScalar s, WithField s AffineManifold d, WithField s LinearManifold c)-                  => AdditiveGroup (Affine s d c) where-  zeroV = const zeroV-  -  negateV (Const c) = const $ negateV c-  negateV Terminal = Terminal-  negateV (ScaleWith ϕ) = ScaleWith $ negateV ϕ-  negateV (f:***g) = negateV f *** negateV g-  negateV (f:&&&g) = negateV f &&& negateV g-  negateV (f:>>>AddTo) = negateV f >>> AddTo-  negateV (f:>>>Subtract) = (f>>>swap) >>>! Subtract-  negateV (f:>>>ScaleWith ϕ) = negateV f >>>! ScaleWith ϕ-  negateV (f:>>>g) = f >>>! negateV g-  negateV AttachUnit = ScaleWith $ linear (negateV >>> (,Origin))-  negateV Subtract = Swap >>>! Subtract-  negateV f = f >>>! ScaleWith (linear negateV)-  -  (^+^) = (.+^)-  (^-^) = (.-.)+instance ∀ s . Num' s => Morphism (Affine s) where+  Affine f *** Affine g = Affine . trie+      $ \(ixα,ixβ) -> case (untrie f ixα, untrie g ixβ) of+            ((fα, ðα'f), (gβ,ðβ'g)) -> ((fα,gβ), ðα'f***ðβ'g)   --infixr 1 >>>!, <<<!--- | Affine composition using only the reified skeleton, without trying to be---   clever in any way.-(>>>!) :: ( MetricScalar s, WithField s AffineManifold α-          , WithField s AffineManifold β, WithField s AffineManifold γ )-      => Affine s α β -> Affine s β γ -> Affine s α γ-ReAffine f >>>! ReAffine g = ReAffine $ f >>> g-f >>>! ReAffine g = ReAffine $ ReWellPointed f >>> g-ReAffine f >>>! g = ReAffine $ f >>> ReWellPointed g-f >>>! g = ReAffine $ ReWellPointed f >>> ReWellPointed g--(<<<!) :: ( MetricScalar s, WithField s AffineManifold α-          , WithField s AffineManifold β, WithField s AffineManifold γ )-      => Affine s β γ -> Affine s α β -> Affine s α γ-(<<<!) = flip (>>>!)--instance (MetricScalar s) => Category (Affine s) where-  type Object (Affine s) o = WithField s AffineManifold o+instance ∀ s . Num' s => PreArrow (Affine s) where+  Affine f &&& Affine g = Affine . trie+      $ \ix -> case (untrie f ix, untrie g ix) of+            ((fα, ðα'f), (gβ,ðβ'g)) -> ((fα,gβ), ðα'f&&&ðβ'g)+  terminal = Affine . trie $ \_ -> (Origin, zeroV)+  fst = afst+   where afst :: ∀ x y . ( Atlas x, Atlas y+                         , LinearSpace (Needle x), LinearSpace (Needle y)+                         , Scalar (Needle x) ~ s, Scalar (Needle y) ~ s+                         , HasTrie (ChartIndex x), HasTrie (ChartIndex y) )+                   => Affine s (x,y) x+         afst = Affine . trie $ chartReferencePoint >>> \(x,_::y) -> (x, fst)+  snd = asnd+   where asnd :: ∀ x y . ( Atlas x, Atlas y+                         , LinearSpace (Needle x), LinearSpace (Needle y)+                         , Scalar (Needle x) ~ s, Scalar (Needle y) ~ s+                         , HasTrie (ChartIndex x), HasTrie (ChartIndex y) )+                   => Affine s (x,y) y+         asnd = Affine . trie $ chartReferencePoint >>> \(_::x,y) -> (y, snd)   -  id = ReAffine id+instance ∀ s . Num' s => WellPointed (Affine s) where+  const x = Affine . trie $ const (x, zeroV)+  unit = Tagged Origin   -  ScaleWith ϕ . ScaleWith ψ = ScaleWith $ ϕ . ψ-  g . ScaleWith ψ = let (d, ϕ) = toOffsetSlope g-                    in postAdd' d $ ScaleWith (ϕ . ψ)-  (f:***g) . (h:***i) = f.h *** g.i-  (f:***g) . (h:&&&i) = f.h &&& g.i-  g . (PostAdd' c f) = let (d, ϕ) = toOffset'Slope g c-                      in postAdd' d $ ScaleWith ϕ . f+instance EnhancedCat (->) (Affine s) where+  arr f = fst . evalAffine f   -  f . g = f <<<! g--instance (MetricScalar s) => Cartesian (Affine s) where-  type UnitObject (Affine s) = ZeroDim s-  swap = ReAffine swap-  attachUnit = ReAffine attachUnit-  detachUnit = ReAffine detachUnit-  regroup = ReAffine regroup-  regroup' = ReAffine regroup'--instance (MetricScalar s) => Morphism (Affine s) where-  Const c *** Const c' = const (c,c')-  Terminal *** Terminal = const (mempty, mempty)-  ReAffine f *** ReAffine g = ReAffine $ f *** g-  f *** ReAffine g = ReAffine $ ReWellPointed f *** g-  ReAffine f *** g = ReAffine $ f *** ReWellPointed g-  f *** g = ReAffine $ ReWellPointed f *** ReWellPointed g--instance (MetricScalar s) => PreArrow (Affine s) where-  terminal = ReAffine terminal-  fst = ReAffine fst-  snd = ReAffine snd-  Const c &&& Const c' = const (c,c')-  Terminal &&& Terminal = const (mempty, mempty)-  ReAffine f &&& ReAffine g = ReAffine $ f &&& g-  f &&& ReAffine g = ReAffine $ ReWellPointed f &&& g-  ReAffine f &&& g = ReAffine $ f &&& ReWellPointed g-  f &&& g = ReAffine $ ReWellPointed f &&& ReWellPointed g-        ---   Affine cof aof slf &&& Affine cog aog slg---       = Affine coh (aof.-^lapply slf rco, aog.+^lapply slg rco)---                  (linear $ lapply slf &&& lapply slg)---    where rco = (cog.-.cof)^/2---          coh = cof .+^ rco--instance (MetricScalar s) => WellPointed (Affine s) where-  unit = Tagged Origin-  const = ReAffine . const---linearAffine :: (MetricScalar s, WithField s LinearManifold α, WithField s LinearManifold β)-            => (α+>β) -> Affine s α β-linearAffine = ScaleWith---type AffinFuncValue s = GenericAgent (Affine s)--instance (MetricScalar s) => HasAgent (Affine s) where-  alg = genericAlg-  ($~) = genericAgentMap-instance (MetricScalar s) => CartesianAgent (Affine s) where-  alg1to2 = genericAlg1to2-  alg2to1 = genericAlg2to1-  alg2to2 = genericAlg2to2-instance (MetricScalar s)-      => PointAgent (AffinFuncValue s) (Affine s) a x where-  point = genericPoint----instance (MetricScalar s, WithField s LinearManifold v, WithField s LinearManifold a)-    => AdditiveGroup (AffinFuncValue s a v) where-  zeroV = GenericAgent zeroV-  GenericAgent f ^+^ GenericAgent g = GenericAgent $ f ^+^ g-  negateV (GenericAgent f) = GenericAgent $ negateV f+instance EnhancedCat (Affine s) (LinearMap s) where+  arr = alarr (linearManifoldWitness, linearManifoldWitness)+   where alarr :: ∀ x y . ( LinearSpace x, Atlas x, HasTrie (ChartIndex x)+                          , LinearSpace y+                          , Scalar x ~ s, Scalar y ~ s )+             => (LinearManifoldWitness x, LinearManifoldWitness y)+                  -> LinearMap s x y -> Affine s x y+         alarr (LinearManifoldWitness _, LinearManifoldWitness _) f+             = Affine . trie $ chartReferencePoint+                   >>> \x₀ -> let y₀ = f $ x₀+                              in (negateV y₀, f) +instance ( Atlas x, HasTrie (ChartIndex x), LinearSpace (Needle x), Scalar (Needle x) ~ s+         , Manifold y, Scalar (Needle y) ~ s )+              => Semimanifold (Affine s x y) where+  type Needle (Affine s x y) = Affine s x (Needle y)+  toInterior = pure+  fromInterior = id+  (.+~^) = case ( semimanifoldWitness :: SemimanifoldWitness y+                , boundarylessWitness :: BoundarylessWitness y ) of+    (SemimanifoldWitness _, BoundarylessWitness) -> \(Affine f) (Affine g)+      -> Affine . trie $ \ix -> case (untrie f ix, untrie g ix) of+          ((fx₀,f'), (gx₀,g')) -> (fx₀.+~^gx₀, f'^+^g')+  translateP = Tagged (.+~^)+  semimanifoldWitness = case semimanifoldWitness :: SemimanifoldWitness y of+    SemimanifoldWitness _ -> SemimanifoldWitness BoundarylessWitness+instance ( Atlas x, HasTrie (ChartIndex x), LinearSpace (Needle x), Scalar (Needle x) ~ s+         , Manifold y, Scalar (Needle y) ~ s )+              => PseudoAffine (Affine s x y) where+  (.-~!) = case ( semimanifoldWitness :: SemimanifoldWitness y+                , boundarylessWitness :: BoundarylessWitness y ) of+    (SemimanifoldWitness _, BoundarylessWitness) -> \(Affine f) (Affine g)+      -> Affine . trie $ \ix -> case (untrie f ix, untrie g ix) of+          ((fx₀,f'), (gx₀,g')) -> (fx₀.-~!gx₀, f'^-^g')+  pseudoAffineWitness = case semimanifoldWitness :: SemimanifoldWitness y of+    SemimanifoldWitness _ -> PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness)+instance ( Atlas x, HasTrie (ChartIndex x), LinearSpace (Needle x), Scalar (Needle x) ~ s+         , Manifold y, Scalar (Needle y) ~ s )+              => AffineSpace (Affine s x y) where+  type Diff (Affine s x y) = Affine s x (Needle y)+  (.+^) = (.+~^); (.-.) = (.-~!)+instance ( Atlas x, HasTrie (ChartIndex x), LinearSpace (Needle x), Scalar (Needle x) ~ s+         , LinearSpace y, Scalar y ~ s, Num' s )+            => AdditiveGroup (Affine s x y) where+  zeroV = case linearManifoldWitness :: LinearManifoldWitness y of+       LinearManifoldWitness _ -> Affine . trie $ const (zeroV, zeroV)+  (^+^) = case ( linearManifoldWitness :: LinearManifoldWitness y+               , dualSpaceWitness :: DualSpaceWitness y ) of+      (LinearManifoldWitness BoundarylessWitness, DualSpaceWitness) -> (.+~^)+  negateV = case linearManifoldWitness :: LinearManifoldWitness y of+       LinearManifoldWitness _ -> \(Affine f) -> Affine . trie $+             untrie f >>> negateV***negateV+instance ( Atlas x, HasTrie (ChartIndex x), LinearSpace (Needle x), Scalar (Needle x) ~ s+         , LinearSpace y, Scalar y ~ s, Num' s )+            => VectorSpace (Affine s x y) where+  type Scalar (Affine s x y) = s+  (*^) = case linearManifoldWitness :: LinearManifoldWitness y of+       LinearManifoldWitness _ -> \μ (Affine f) -> Affine . trie $+             untrie f >>> (μ*^)***(μ*^) +evalAffine :: ∀ s x y . ( 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 = ea (boundarylessWitness, boundarylessWitness)+ where ea :: (BoundarylessWitness x, BoundarylessWitness y)+             -> Affine s x y -> x -> (y, LinearMap s (Needle x) (Needle y))+       ea (BoundarylessWitness, BoundarylessWitness)+          (Affine f) x = (fx₀.+~^(ðx'f $ v), ðx'f)+        where Just v = x .-~. chartReferencePoint chIx+              chIx = lookupAtlas x+              (fx₀, ðx'f) = untrie f chIx +fromOffsetSlope :: ∀ s x y . ( LinearSpace x, Atlas x, HasTrie (ChartIndex x)+                             , Manifold y+                             , s ~ Scalar x, s ~ Scalar (Needle y) )+               => y -> LinearMap s x (Needle y) -> Affine s x y+fromOffsetSlope = case ( linearManifoldWitness :: LinearManifoldWitness x+                       , boundarylessWitness :: BoundarylessWitness y ) of+   (LinearManifoldWitness _, BoundarylessWitness)+       -> \y0 ðx'y -> Affine . trie $ chartReferencePoint+                    >>> \x₀ -> let δy = ðx'y $ x₀+                               in (y0.+~^δy, ðx'y)

@@ -22,6 +22,7 @@ {-# LANGUAGE TypeOperators            #-} {-# LANGUAGE UnicodeSyntax            #-} {-# LANGUAGE MultiWayIf               #-}+{-# LANGUAGE LambdaCase               #-} {-# LANGUAGE ScopedTypeVariables      #-} {-# LANGUAGE RecordWildCards          #-} {-# LANGUAGE CPP                      #-}@@ -53,6 +54,7 @@ import Data.Maybe import Data.Semigroup import Data.Embedding+import Data.MemoTrie (HasTrie)  import Data.VectorSpace import Math.LinearMap.Category@@ -63,6 +65,7 @@ import Data.Tagged import Data.Manifold.Types.Primitive import Data.Manifold.PseudoAffine+import Data.Manifold.Atlas  import qualified Prelude import qualified Control.Applicative as Hask@@ -154,8 +157,8 @@                      resoHere = normSq $ δbf xq                      resoStep = dir/sqrt(resoHere 1)               definedHere = case fq₀ of-                              Option (Just _) -> True-                              Option Nothing  -> False+                              Just _  -> True+                              Nothing -> False        glueMid ((l,le):ls) ((re,r):rs) | le==re  = (ls, (l,r):rs)        glueMid l r = (l,r)        huge = exp $ fromIntegral nLim@@ -179,17 +182,17 @@                             = ( map discretise ivsL, map discretise ivsR )  where (ivsL, ivsR) = continuityRanges nLim mx f        discretise rng@(l,r) = discretisePathIn nLim rng (mx,my) fr-        where (_, Option (Just fr)) = ff $ (l+r)/2+        where (_, Just fr) = ff $ (l+r)/2                 analyseLocalBehaviour ::-    RWDiffable ℝ ℝ ℝ- -> ℝ                      -- ^ /x/₀ value.- -> Option ( (ℝ,ℝ)-           , ℝ->Option ℝ ) -- ^ /f/ /x/₀, derivative (i.e. Taylor-1-coefficient),+     RWDiffable ℝ ℝ ℝ+  -> ℝ                      -- ^ /x/₀ value.+  -> Maybe ( (ℝ,ℝ)+           , ℝ->Maybe ℝ ) -- ^ /f/ /x/₀, derivative (i.e. Taylor-1-coefficient),                            --   and reverse propagation of /O/ (/δ/²) bound. analyseLocalBehaviour (RWDiffable f) x₀ = case f x₀ of-       (r, Option (Just (Differentiable fd)))+       (r, Just (Differentiable fd))            | inRegion r x₀ -> return $               let (fx, j, δf) = fd x₀                   epsprop ε@@ -228,7 +231,7 @@                   = (map (id&&&ivimg) domsL, map (id&&&ivimg) domsR)  where (domsL, domsR) = continuityRanges nLim mx f        ivimg (xl,xr) = go xl 1 i₀ ∪ go xr (-1) i₀-        where (_, Option (Just fdd@(Differentiable fddd)))+        where (_, Just fdd@(Differentiable fddd))                     = second (fmap genericiseDifferentiable) $ fd xc               xc = (xl+xr)/2               i₀ = minimum&&&maximum $ [fdd$xl, fdd$xc, fdd$xr]@@ -276,7 +279,7 @@                                     ++ " gives non-positive δ="++show δ++"."                   else mempty dev_ε_δ :: RealDimension a-         => (a -> a) -> Metric a -> Option (Metric a)+         => (a -> a) -> Metric a -> Maybe (Metric a) dev_ε_δ f d = let ε'² = normSq d 1               in if ε'²>0                   then let δ = f . sqrt $ recip ε'²@@ -296,7 +299,7 @@ genericiseDifferentiable :: (LocallyScalable s d, LocallyScalable s c)                     => Differentiable s d c -> Differentiable s d c genericiseDifferentiable (AffinDiffable _ af)-     = Differentiable $ \x -> let (y₀, ϕ) = toOffset'Slope af x+     = Differentiable $ \x -> let (y₀, ϕ) = evalAffine af x                               in (y₀, ϕ, const mempty) genericiseDifferentiable f = f @@ -371,32 +374,52 @@ instance (RealFrac' s) => HasAgent (Differentiable s) where   alg = genericAlg   ($~) = genericAgentMap-instance (RealFrac' s) => CartesianAgent (Differentiable s) where+instance ∀ s . (RealFrac' s) => CartesianAgent (Differentiable s) where   alg1to2 = genericAlg1to2-  alg2to1 = genericAlg2to1-  alg2to2 = genericAlg2to2+  alg2to1 = a2t1+   where a2t1 :: ∀ α β γ . (LocallyScalable s α, LocallyScalable s β)+           => (∀ q . LocallyScalable s q+               => DfblFuncValue s q α -> DfblFuncValue s q β -> DfblFuncValue s q γ )+           -> Differentiable s (α,β) γ+         a2t1 = case ( dualSpaceWitness :: DualSpaceWitness (Needle α)+                     , dualSpaceWitness :: DualSpaceWitness (Needle β) ) of+            (DualSpaceWitness, DualSpaceWitness) -> genericAlg2to1+  alg2to2 = a2t1+   where a2t1 :: ∀ α β γ δ . ( LocallyScalable s α, LocallyScalable s β+                             , LocallyScalable s γ, LocallyScalable s δ )+           => (∀ q . LocallyScalable s q+               => DfblFuncValue s q α -> DfblFuncValue s q β+                     -> (DfblFuncValue s q γ, DfblFuncValue s q δ) )+           -> Differentiable s (α,β) (γ,δ)+         a2t1 = case ( dualSpaceWitness :: DualSpaceWitness (Needle α)+                     , dualSpaceWitness :: DualSpaceWitness (Needle β)+                     , dualSpaceWitness :: DualSpaceWitness (Needle γ)+                     , dualSpaceWitness :: DualSpaceWitness (Needle δ) ) of+            (DualSpaceWitness, DualSpaceWitness, DualSpaceWitness, DualSpaceWitness)+                  -> genericAlg2to2 instance (RealFrac' s)       => PointAgent (DfblFuncValue s) (Differentiable s) a x where   point = genericPoint  --actuallyLinearEndo :: WithField s LinearManifold x+actuallyLinearEndo :: (Object (Affine s) x, Object (LinearMap s) x)             => (x+>x) -> Differentiable s x x-actuallyLinearEndo = AffinDiffable IsDiffableEndo . linearAffine+actuallyLinearEndo = AffinDiffable IsDiffableEndo . arr -actuallyAffineEndo :: WithField s LinearManifold x-            => x -> (x+>x) -> Differentiable s x x-actuallyAffineEndo y₀ f = AffinDiffable IsDiffableEndo $ const y₀ .+^ linearAffine f+actuallyAffineEndo :: (Object (Affine s) x, Object (LinearMap s) x)+            => x -> (x+>Needle x) -> Differentiable s x x+actuallyAffineEndo y₀ f = AffinDiffable IsDiffableEndo $ fromOffsetSlope y₀ f -actuallyLinear :: ( WithField s LinearManifold x, WithField s LinearManifold y )++actuallyLinear :: ( Object (Affine s) x, Object (Affine s) y+                  , Object (LinearMap s) x, Object (LinearMap s) y )             => (x+>y) -> Differentiable s x y-actuallyLinear = AffinDiffable NotDiffableEndo . linearAffine+actuallyLinear = AffinDiffable NotDiffableEndo . arr -actuallyAffine :: ( WithField s LinearManifold x-                  , WithField s AffineManifold y )-            => y -> (x+>Diff y) -> Differentiable s x y-actuallyAffine y₀ f = AffinDiffable NotDiffableEndo $ const y₀ .+^ linearAffine f+actuallyAffine :: ( Object (Affine s) x, Object (Affine s) y+                  , Object (LinearMap s) x, Object (LinearMap s) (Needle y) )+            => y -> (x+>Needle y) -> Differentiable s x y+actuallyAffine y₀ f = AffinDiffable NotDiffableEndo $ fromOffsetSlope y₀ f   -- affinPoint :: (WithField s LinearManifold c, WithField s LinearManifold d)@@ -443,7 +466,7 @@   -instance (WithField s LinearManifold v, LocallyScalable s a, RealFloat' s)+instance (LocallyScalable s v, LinearManifold v, LocallyScalable s a, RealFloat' s)     => AdditiveGroup (DfblFuncValue s a v) where   zeroV = point zeroV   GenericAgent (AffinDiffable ef f) ^+^ GenericAgent (AffinDiffable eg g)@@ -635,15 +658,15 @@   instance (RealDimension s) => Category (RWDiffable s) where-  type Object (RWDiffable s) o = (LocallyScalable s o, SimpleSpace (Needle o))+  type Object (RWDiffable s) o = (LocallyScalable s o, Manifold o, SimpleSpace (Needle o))   id = RWDiffable $ \x -> (GlobalRegion, pure id)   RWDiffable f . RWDiffable g = RWDiffable h where    h x₀ = case g x₀ of-           ( rg, Option (Just gr'@(AffinDiffable IsDiffableEndo gr)) )-            -> let (y₀, ϕg) = toOffset'Slope gr x₀+           ( rg, Just gr'@(AffinDiffable IsDiffableEndo gr) )+            -> let (y₀, ϕg) = evalAffine gr x₀                in case f y₀ of-                   (GlobalRegion, Option (Just (AffinDiffable fe fr)))-                         -> (rg, Option (Just (AffinDiffable fe (fr.gr))))+                   (GlobalRegion, Just (AffinDiffable fe fr))+                         -> (rg, Just (AffinDiffable fe (fr.gr)))                    (GlobalRegion, fhr)                          -> (rg, fmap (. gr') fhr)                    (RealSubray diry yl, fhr)@@ -660,51 +683,51 @@                                  | otherwise -> (rg, hhr)                    (PreRegion ry, fhr)                          -> ( PreRegion $ ry . gr', fmap (. gr') fhr )-           ( rg, Option (Just gr'@(AffinDiffable _ gr)) )-            -> error "( rg, Option (Just gr'@(AffinDiffable gr)) )"-           (GlobalRegion, Option (Just gr@(Differentiable grd)))+           ( rg, Just gr'@(AffinDiffable _ gr) )+            -> error "( rg, Just gr'@(AffinDiffable gr) )"+           (GlobalRegion, Just gr@(Differentiable grd))             -> let (y₀,_,_) = grd x₀                in case f y₀ of-                   (GlobalRegion, Option Nothing)+                   (GlobalRegion, Nothing)                          -> (GlobalRegion, notDefinedHere)-                   (GlobalRegion, Option (Just fr))+                   (GlobalRegion, Just fr)                          -> (GlobalRegion, pure (fr . gr))-                   (r, Option Nothing) | PreRegion ry <- genericisePreRegion r+                   (r, Nothing) | PreRegion ry <- genericisePreRegion r                          -> ( PreRegion $ ry . gr, notDefinedHere )-                   (r, Option (Just fr)) | PreRegion ry <- genericisePreRegion r+                   (r, (Just fr)) | PreRegion ry <- genericisePreRegion r                          -> ( PreRegion $ ry . gr, pure (fr . gr) )-           (rg@(RealSubray _ _), Option (Just gr@(Differentiable grd)))+           (rg@(RealSubray _ _), Just gr@(Differentiable grd))             -> let (y₀,_,_) = grd x₀                in case f y₀ of-                   (GlobalRegion, Option Nothing)+                   (GlobalRegion, Nothing)                          -> (rg, notDefinedHere)-                   (GlobalRegion, Option (Just fr))+                   (GlobalRegion, Just fr)                          -> (rg, pure (fr . gr))-                   (rf, Option Nothing)+                   (rf, Nothing)                      | PreRegion rx <- genericisePreRegion rg                      , PreRegion ry <- genericisePreRegion rf                          -> ( PreRegion $ minDblfuncs (ry . gr) rx                             , notDefinedHere )-                   (rf, Option (Just fr))+                   (rf, Just fr)                      | PreRegion rx <- genericisePreRegion rg                      , PreRegion ry <- genericisePreRegion rf                          -> ( PreRegion $ minDblfuncs (ry . gr) rx                             , pure (fr . gr) )-           (PreRegion rx, Option (Just gr@(Differentiable grd)))+           (PreRegion rx, Just gr@(Differentiable grd))             -> let (y₀,_,_) = grd x₀                in case f y₀ of-                   (GlobalRegion, Option Nothing)+                   (GlobalRegion, Nothing)                          -> (PreRegion rx, notDefinedHere)-                   (GlobalRegion, Option (Just fr))+                   (GlobalRegion, Just fr)                          -> (PreRegion rx, pure (fr . gr))-                   (r, Option Nothing) | PreRegion ry <- genericisePreRegion r+                   (r, Nothing) | PreRegion ry <- genericisePreRegion r                          -> ( PreRegion $ minDblfuncs (ry . gr) rx                             , notDefinedHere )-                   (r, Option (Just fr)) | PreRegion ry <- genericisePreRegion r+                   (r, Just fr) | PreRegion ry <- genericisePreRegion r                           -> ( PreRegion $ minDblfuncs (ry . gr) rx                             , pure (fr . gr) )-           (r, Option Nothing)+           (r, Nothing)             -> (r, notDefinedHere)            @@ -754,7 +777,8 @@  genericiseRWDFV :: ( RealDimension s                    , LocallyScalable s c, SimpleSpace (Needle c)-                   , LocallyScalable s d, SimpleSpace (Needle d) )+                   , LocallyScalable s d, SimpleSpace (Needle d)+                   , Manifold d, Manifold c )                     => RWDfblFuncValue s d c -> RWDfblFuncValue s d c genericiseRWDFV (ConstRWDFV c) = GenericRWDFV $ const c genericiseRWDFV RWDFV_IdVar = GenericRWDFV id@@ -781,6 +805,7 @@ grwDfblFnValsFunc      :: ( RealDimension s         , LocallyScalable s c, LocallyScalable s c', LocallyScalable s d+        , Manifold d, Manifold c, Manifold c'         , v ~ Needle c, v' ~ Needle c'         , SimpleSpace v, SimpleSpace (Needle d)         , ε ~ Norm v, ε ~ Norm v' )@@ -790,6 +815,7 @@ grwDfblFnValsCombine :: forall d c c' c'' v v' v'' ε ε' ε'' s.           ( LocallyScalable s c,  LocallyScalable s c',  LocallyScalable s c''          , LocallyScalable s d, RealDimension s+         , Manifold d, Manifold c', Manifold c''          , v ~ Needle c, v' ~ Needle c', v'' ~ Needle c''          , SimpleSpace v, SimpleSpace (Needle d)          , ε ~ Norm v  , ε' ~ Norm v'  , ε'' ~ Norm v'', ε~ε', ε~ε''  )@@ -802,7 +828,7 @@                    (rc'',gmay) = gpcs d₀                in (unsafePreRegionIntersect rc' rc'',) $                     case (genericiseDifferentiable<$>fmay, genericiseDifferentiable<$>gmay) of-                      (Option(Just(Differentiable f)), Option(Just(Differentiable g))) ->+                      (Just(Differentiable f), Just(Differentiable g)) ->                         pure . Differentiable $ \d                          -> let (c', jf, devf) = f d                                 (c'',jg, devg) = g d@@ -823,11 +849,16 @@             rwDfbl_plus :: ∀ s a v .-        ( WithField s EuclidSpace v, AdditiveGroup v, v ~ Needle (Interior (Needle v))-        , LocallyScalable s a, RealDimension s )+        ( WithField s Manifold a+        , LinearSpace v, Scalar v ~ s+        , RealDimension s )       => RWDiffable s a v -> RWDiffable s a v -> RWDiffable s a v-rwDfbl_plus (RWDiffable f) (RWDiffable g) = RWDiffable h-   where h x₀ = (rh, liftA2 fgplus ff gf)+rwDfbl_plus (RWDiffable f) (RWDiffable g) = RWDiffable+              $ h linearManifoldWitness dualSpaceWitness+   where h :: LinearManifoldWitness v -> DualSpaceWitness v+                -> a -> (PreRegion s a, Maybe (Differentiable s a v))+         h (LinearManifoldWitness _) DualSpaceWitness+           x₀ = (rh, liftA2 fgplus ff gf)           where (rf, ff) = f x₀                 (rg, gf) = g x₀                 rh = unsafePreRegionIntersect rf rg@@ -841,21 +872,25 @@                                  = Differentiable hd                  where hd x = (fx^+^gx, jf^+^ϕg, δf)                         where (fx, jf, δf) = fd x-                              (gx, ϕg) = toOffset'Slope ga x+                              (gx, ϕg) = evalAffine ga x                 fgplus (AffinDiffable _ fa) (Differentiable gd)                                  = Differentiable hd                  where hd x = (fx^+^gx, ϕf^+^jg, δg)                         where (gx, jg, δg) = gd x-                              (fx, ϕf) = toOffset'Slope fa x+                              (fx, ϕf) = evalAffine fa x                 fgplus (AffinDiffable fe fa) (AffinDiffable ge ga)                            = AffinDiffable (fe<>ge) (fa^+^ga)  rwDfbl_negateV :: ∀ s a v .-        ( WithField s EuclidSpace v, AdditiveGroup v, v ~ Needle (Interior (Needle v))-        , LocallyScalable s a, RealDimension s )+        ( WithField s Manifold a+        , LinearSpace v, Scalar v ~ s+        , RealDimension s )       => RWDiffable s a v -> RWDiffable s a v-rwDfbl_negateV (RWDiffable f) = RWDiffable h-   where h x₀ = (rf, fmap fneg ff)+rwDfbl_negateV (RWDiffable f) = RWDiffable $ h linearManifoldWitness dualSpaceWitness+   where h :: LinearManifoldWitness v -> DualSpaceWitness v+                -> a -> (PreRegion s a, Maybe (Differentiable s a v))+         h (LinearManifoldWitness _) DualSpaceWitness+           x₀ = (rf, fmap fneg ff)           where (rf, ff) = f x₀                 fneg :: Differentiable s a v -> Differentiable s a v                 fneg (Differentiable fd) = Differentiable hd@@ -865,47 +900,61 @@  postCompRW :: ( RealDimension s               , LocallyScalable s a, LocallyScalable s b, LocallyScalable s c+              , Manifold a, Manifold b, Manifold c               , SimpleSpace (Needle a), SimpleSpace (Needle b), SimpleSpace (Needle c) )               => RWDiffable s b c -> RWDfblFuncValue s a b -> RWDfblFuncValue s a c postCompRW (RWDiffable f) (ConstRWDFV x) = case f x of-     (_, Option (Just fd)) -> ConstRWDFV $ fd $ x+     (_, Just fd) -> ConstRWDFV $ fd $ x postCompRW f RWDFV_IdVar = GenericRWDFV f postCompRW f (GenericRWDFV g) = GenericRWDFV $ f . g  -instance ( WithField s EuclidSpace v, SimpleSpace v, v ~ Needle (Interior (Needle v))-         , LocallyScalable s a, SimpleSpace (Needle a), RealDimension s)+instance ∀ s a v . ( WithField s Manifold a, SimpleSpace (Needle a)+                   , Atlas v, HasTrie (ChartIndex v), SimpleSpace v, Scalar v ~ s+                   , RealDimension s )     => AdditiveGroup (RWDfblFuncValue s a v) where-  zeroV = point zeroV-  ConstRWDFV c₁ ^+^ ConstRWDFV c₂ = ConstRWDFV (c₁^+^c₂)-  ConstRWDFV c₁ ^+^ RWDFV_IdVar = GenericRWDFV $+  zeroV = case ( linearManifoldWitness :: LinearManifoldWitness v+               , dualSpaceWitness :: DualSpaceWitness v ) of+      (LinearManifoldWitness BoundarylessWitness, DualSpaceWitness) -> point zeroV+  (^+^) = case ( linearManifoldWitness :: LinearManifoldWitness v+               , dualSpaceWitness :: DualSpaceWitness v ) of+      (LinearManifoldWitness BoundarylessWitness, DualSpaceWitness)+         -> curry $ \case+              (ConstRWDFV c₁, ConstRWDFV c₂) -> ConstRWDFV (c₁^+^c₂)+              (ConstRWDFV c₁, RWDFV_IdVar) -> GenericRWDFV $                                globalDiffable' (actuallyAffineEndo c₁ id)-  RWDFV_IdVar ^+^ ConstRWDFV c₂ = GenericRWDFV $+              (RWDFV_IdVar, ConstRWDFV c₂) -> GenericRWDFV $                                globalDiffable' (actuallyAffineEndo c₂ id)-  ConstRWDFV c₁ ^+^ GenericRWDFV g = GenericRWDFV $+              (ConstRWDFV c₁, GenericRWDFV g) -> GenericRWDFV $                                globalDiffable' (actuallyAffineEndo c₁ id) . g-  GenericRWDFV f ^+^ ConstRWDFV c₂ = GenericRWDFV $+              (GenericRWDFV f, ConstRWDFV c₂) -> GenericRWDFV $                                   globalDiffable' (actuallyAffineEndo c₂ id) . f-  fa^+^ga | GenericRWDFV f <- genericiseRWDFV fa-          , GenericRWDFV g <- genericiseRWDFV ga = GenericRWDFV $ rwDfbl_plus f g-  negateV (ConstRWDFV c) = ConstRWDFV (negateV c)-  negateV RWDFV_IdVar = GenericRWDFV $ globalDiffable' (actuallyLinearEndo $ negateV id)-  negateV (GenericRWDFV f) = GenericRWDFV $ rwDfbl_negateV f+              (fa, ga) | GenericRWDFV f <- genericiseRWDFV fa+                       , GenericRWDFV g <- genericiseRWDFV ga+                                -> GenericRWDFV $ rwDfbl_plus f g+  negateV = case ( linearManifoldWitness :: LinearManifoldWitness v+                 , dualSpaceWitness :: DualSpaceWitness v ) of+      (LinearManifoldWitness BoundarylessWitness, DualSpaceWitness) -> \case+        (ConstRWDFV c) -> ConstRWDFV (negateV c)+        RWDFV_IdVar -> GenericRWDFV $ globalDiffable' (actuallyLinearEndo $ negateV id)+        (GenericRWDFV f) -> GenericRWDFV $ rwDfbl_negateV f  dualCoCoProduct :: ∀ v w s .                    ( SimpleSpace v, HilbertSpace v                    , SimpleSpace w, Scalar v ~ s, Scalar w ~ s )            => LinearMap s w v -> LinearMap s w v -> Norm w-dualCoCoProduct s t = Norm $ (tSpread*sSpread) *^ t²Ps²M- where t' = adjoint $ t :: LinearMap s v (DualVector w)-       s' = adjoint $ s :: LinearMap s v (DualVector w)-       tSpread = sum . map recip_t²PLUSs² $ snd (decomposeLinMap t') []-       sSpread = sum . map recip_t²PLUSs² $ snd (decomposeLinMap s') []-       t²PLUSs²@(Norm t²Ps²M)-            = transformNorm t euclideanNorm <> transformNorm s euclideanNorm :: Norm w-       recip_t²PLUSs² = normSq (dualNorm t²PLUSs²) :: DualVector w -> s+dualCoCoProduct = dccp (dualSpaceWitness::DualSpaceWitness w)+ where dccp DualSpaceWitness s t = Norm $ (tSpread*sSpread) *^ t²Ps²M+        where t' = adjoint $ t :: LinearMap s v (DualVector w)+              s' = adjoint $ s :: LinearMap s v (DualVector w)+              tSpread = sum . map recip_t²PLUSs² $ snd (decomposeLinMap t') []+              sSpread = sum . map recip_t²PLUSs² $ snd (decomposeLinMap s') []+              t²PLUSs²@(Norm t²Ps²M)+                = transformNorm t euclideanNorm <> transformNorm s euclideanNorm :: Norm w+              recip_t²PLUSs² = normSq (dualNorm t²PLUSs²) :: DualVector w -> s -instance (RealDimension n, LocallyScalable n a, SimpleSpace (Needle a))+instance ( RealDimension n, WithField n Manifold a+         , LocallyScalable n a, SimpleSpace (Needle a))             => Num (RWDfblFuncValue n a n) where   fromInteger i = point $ fromInteger i   (+) = (^+^)@@ -933,8 +982,8 @@                      in case f'*g' of                           0 -> AffinDiffableEndo $ const (aof*aog)                           f'g' -> -} Differentiable $-                           \d -> let (fd,ϕf) = toOffset'Slope af d-                                     (gd,ϕg) = toOffset'Slope ag d+                           \d -> let (fd,ϕf) = evalAffine af d+                                     (gd,ϕg) = evalAffine ag d                                      jf = ϕf $ 1; jg = ϕg $ 1                                      invf'g' = recip $ jf*jg                                  in ( fd*gd@@ -971,7 +1020,8 @@           | a₀<0       = (negativePreRegion, pure (const $ -1))           | otherwise  = (positivePreRegion, pure (const 1)) -instance (RealDimension n, LocallyScalable n a, SimpleSpace (Needle a))+instance ( RealDimension n, WithField n Manifold a+         , LocallyScalable n a, SimpleSpace (Needle a))             => Fractional (RWDfblFuncValue n a n) where   fromRational i = point $ fromRational i   recip = postCompRW . RWDiffable $ \a₀ -> if a₀<0@@ -999,7 +1049,8 @@   -instance (RealDimension n, LocallyScalable n a, SimpleSpace (Needle a))+instance ( RealDimension n, WithField n Manifold a+         , LocallyScalable n a, SimpleSpace (Needle a) )             => Floating (RWDfblFuncValue n a n) where   pi = point pi   @@ -1176,19 +1227,20 @@ --   _      'Control.Applicative.*>' a = Nothing --   @ (?->) :: ( RealDimension n, LocallyScalable n a, LocallyScalable n b, LocallyScalable n c+         , Manifold b, Manifold c          , SimpleSpace (Needle b), SimpleSpace (Needle c) )       => RWDfblFuncValue n c a -> RWDfblFuncValue n c b -> RWDfblFuncValue n c b ConstRWDFV _ ?-> f = f RWDFV_IdVar ?-> f = f GenericRWDFV (RWDiffable r) ?-> ConstRWDFV c = GenericRWDFV (RWDiffable s)  where s x₀ = case r x₀ of-                (rd, Option (Just q)) -> (rd, return $ const c)-                (rd, Option Nothing) -> (rd, empty)+                (rd, Just q)  -> (rd, return $ const c)+                (rd, Nothing) -> (rd, empty) GenericRWDFV (RWDiffable f) ?-> GenericRWDFV (RWDiffable g) = GenericRWDFV (RWDiffable h)  where h x₀ = case f x₀ of-                (rf, Option (Just _)) | (rg, q) <- g x₀+                (rf, Just _) | (rg, q) <- g x₀                         -> (unsafePreRegionIntersect rf rg, q)-                (rf, Option Nothing) -> (rf, empty)+                (rf, Nothing) -> (rf, empty) c ?-> f = c ?-> genericiseRWDFV f  positiveRegionalId :: RealDimension n => RWDiffable n n n@@ -1202,12 +1254,12 @@ --   allows chaining of comparison operators like in Python.) --   Note that less-than comparison is <http://www.paultaylor.eu/ASD/ equivalent> --   to less-or-equal comparison, because there is no such thing as equality.-(?>) :: (RealDimension n, LocallyScalable n a, SimpleSpace (Needle a))+(?>) :: (RealDimension n, LocallyScalable n a, Manifold a, SimpleSpace (Needle a))            => RWDfblFuncValue n a n -> RWDfblFuncValue n a n -> RWDfblFuncValue n a n a ?> b = (positiveRegionalId $~ a-b) ?-> b  -- | Return the RHS, if it is greater than the LHS.-(?<) :: (RealDimension n, LocallyScalable n a, SimpleSpace (Needle a))+(?<) :: (RealDimension n, LocallyScalable n a, Manifold a, SimpleSpace (Needle a))            => RWDfblFuncValue n a n -> RWDfblFuncValue n a n -> RWDfblFuncValue n a n ConstRWDFV a ?< RWDFV_IdVar = GenericRWDFV . RWDiffable $        \x₀ -> if a < x₀ then ( preRegionToInfFrom a@@ -1231,18 +1283,19 @@ --  --  Basically a weaker and agent-ised version of 'backupRegions'. (?|:) :: ( RealDimension n, LocallyScalable n a, LocallyScalable n b+         , Manifold a, Manifold b          , SimpleSpace (Needle a), SimpleSpace (Needle b) )       => RWDfblFuncValue n a b -> RWDfblFuncValue n a b -> RWDfblFuncValue n a b ConstRWDFV c ?|: _ = ConstRWDFV c RWDFV_IdVar ?|: _ = RWDFV_IdVar GenericRWDFV (RWDiffable f) ?|: ConstRWDFV c = GenericRWDFV (RWDiffable h)  where h x₀ = case f x₀ of-                (rd, Option (Just q)) -> (rd, Option (Just q))-                (rd, Option Nothing) -> (rd, Option . Just $ const c)+                (rd, Just q) -> (rd, Just q)+                (rd, Nothing) -> (rd, Just $ const c) GenericRWDFV (RWDiffable f) ?|: GenericRWDFV (RWDiffable g) = GenericRWDFV (RWDiffable h)  where h x₀ = case f x₀ of-                (rf, Option (Just q)) -> (rf, pure q)-                (rf, Option Nothing) | (rg, q) <- g x₀+                (rf, Just q) -> (rf, pure q)+                (rf, Nothing) | (rg, q) <- g x₀                         -> (unsafePreRegionIntersect rf rg, q) c ?|: f = c ?|: genericiseRWDFV f @@ -1252,8 +1305,8 @@       => RWDiffable n a b -> RWDiffable n a b -> RWDiffable n a b backupRegions (RWDiffable f) (RWDiffable g) = RWDiffable h  where h x₀ = case f x₀ of-                (rf, q@(Option (Just _))) -> (rf, q)-                (rf, Option Nothing) | (rg, q) <- g x₀+                (rf, q@(Just _)) -> (rf, q)+                (rf, Nothing) | (rg, q) <- g x₀                         -> (unsafePreRegionIntersect rf rg, q)  @@ -1262,7 +1315,8 @@  -- | Like 'Data.VectorSpace.lerp', but gives a differentiable function --   instead of a Hask one.-lerp_diffable :: (WithField s LinearManifold m, RealDimension s)+lerp_diffable :: ( WithField s LinearManifold m, Atlas m+                 , HasTrie (ChartIndex m), RealDimension s )       => m -> m -> Differentiable s s m lerp_diffable a b = actuallyAffine a . arr $ flipBilin scale $ b.-.a 

@@ -61,7 +61,7 @@                                                -- some error margin                               ) )                   -> Differentiable s d c-   AffinDiffable :: (AffineManifold d, AffineManifold c)+   AffinDiffable :: (CC.Object (Affine s) d, CC.Object (Affine s) c)                => DiffableEndoProof d c -> Affine s d c -> Differentiable s d c  @@ -129,8 +129,8 @@ -- @ newtype RWDiffable s d c    = RWDiffable {-        tryDfblDomain :: d -> (PreRegion s d, Option (Differentiable s d c)) }+        tryDfblDomain :: d -> (PreRegion s d, Maybe (Differentiable s d c)) } -notDefinedHere :: Option (Differentiable s d c)-notDefinedHere = Option Nothing+notDefinedHere :: Maybe (Differentiable s d c)+notDefinedHere = Nothing 

@@ -0,0 +1,80 @@+-- |+-- Module      : Data.Manifold.Atlas+-- Copyright   : (c) Justus Sagemüller 2015+-- License     : GPL v3+-- +-- Maintainer  : (@) sagemueller $ geo.uni-koeln.de+-- Stability   : experimental+-- Portability : portable+-- ++{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE EmptyDataDecls, EmptyCase #-}+{-# LANGUAGE CPP                       #-}+{-# LANGUAGE ScopedTypeVariables       #-}++module Data.Manifold.Atlas where++import Prelude as Hask++import Data.VectorSpace+import Data.Manifold.PseudoAffine+import Data.Manifold.Types.Primitive++import Data.Void++import Data.VectorSpace.Free++import Control.Arrow++class Semimanifold m => Atlas m where+  type ChartIndex m :: *+  chartReferencePoint :: ChartIndex m -> m+  chartReferencePoint = fromInterior . interiorChartReferencePoint ([]::[m])+  interiorChartReferencePoint :: Hask.Functor p => p m -> ChartIndex m -> Interior m+  lookupAtlas :: m -> ChartIndex m++#define VectorSpaceAtlas(c,v)              \+instance (c) => Atlas (v) where {           \+  type ChartIndex (v) = ();                  \+  interiorChartReferencePoint _ () = zeroV;   \+  chartReferencePoint () = zeroV;              \+  lookupAtlas _ = () }++VectorSpaceAtlas((), ZeroDim s)+VectorSpaceAtlas((), ℝ)+VectorSpaceAtlas(Num s, V0 s)+VectorSpaceAtlas(Num s, V1 s)+VectorSpaceAtlas(Num s, V2 s)+VectorSpaceAtlas(Num s, V3 s)+VectorSpaceAtlas(Num s, V4 s)++instance (Atlas x, Atlas y) => Atlas (x,y) where+  type ChartIndex (x,y) = (ChartIndex x, ChartIndex y)+  chartReferencePoint = chartReferencePoint *** chartReferencePoint+  interiorChartReferencePoint p+         = interiorChartReferencePoint (fst<$>p) *** interiorChartReferencePoint (snd<$>p)+  lookupAtlas = lookupAtlas *** lookupAtlas++instance Atlas S⁰ where+  type ChartIndex S⁰ = S⁰+  chartReferencePoint = id+  interiorChartReferencePoint _ = id+  lookupAtlas = id+instance Atlas S¹ where+  type ChartIndex S¹ = S⁰+  chartReferencePoint NegativeHalfSphere = S¹ $ -pi/2+  chartReferencePoint PositiveHalfSphere = S¹ $ pi/2+  interiorChartReferencePoint _ NegativeHalfSphere = S¹ $ -pi/2+  interiorChartReferencePoint _ PositiveHalfSphere = S¹ $ pi/2+  lookupAtlas (S¹ φ) | φ<0        = NegativeHalfSphere+                     | otherwise  = PositiveHalfSphere+instance Atlas S² where+  type ChartIndex S² = S⁰+  chartReferencePoint PositiveHalfSphere = S² 0 0+  chartReferencePoint NegativeHalfSphere = S² pi 0+  interiorChartReferencePoint _ PositiveHalfSphere = S² 0 0+  interiorChartReferencePoint _ NegativeHalfSphere = S² pi 0+  lookupAtlas (S² ϑ _) | ϑ<pi/2     = PositiveHalfSphere+                       | otherwise  = NegativeHalfSphere

@@ -33,7 +33,6 @@  import qualified Data.Vector.Generic as Arr import Data.Maybe-import Data.Semigroup  import Data.VectorSpace import Data.Tagged@@ -73,9 +72,9 @@   fromCD¹Interior :: ConeVecArr m -> CD¹ m   fromCD¹Interior = embCℝayToCD¹ . fromCℝayInterior   -  toCℝayInterior :: Cℝay m -> Option (ConeVecArr m)+  toCℝayInterior :: Cℝay m -> Maybe (ConeVecArr m)   toCℝayInterior = toCD¹Interior . embCℝayToCD¹-  toCD¹Interior :: CD¹ m -> Option (ConeVecArr m)+  toCD¹Interior :: CD¹ m -> Maybe (ConeVecArr m)   toCD¹Interior = toCℝayInterior . projCD¹ToCℝay    @@ -93,7 +92,7 @@           where Tagged ctp' = translateP                   :: Tagged (ConeVecArr m) (ConeVecArr m -> ConeNeedle m -> ConeVecArr m)   semimanifoldWitness = case semimanifoldWitness :: SemimanifoldWitness (ConeVecArr m) of-                          SemimanifoldWitness -> SemimanifoldWitness+       SemimanifoldWitness BoundarylessWitness -> SemimanifoldWitness BoundarylessWitness    instance (ConeSemimfd m) => Semimanifold (CD¹ m) where   type Needle (CD¹ m) = ConeNeedle m@@ -106,7 +105,7 @@           where Tagged ctp' = translateP                   :: Tagged (ConeVecArr m) (ConeVecArr m -> ConeNeedle m -> ConeVecArr m)   semimanifoldWitness = case semimanifoldWitness :: SemimanifoldWitness (ConeVecArr m) of-                          SemimanifoldWitness -> SemimanifoldWitness+       SemimanifoldWitness BoundarylessWitness -> SemimanifoldWitness BoundarylessWitness   

@@ -34,21 +34,24 @@ module Data.Manifold.DifferentialEquation (             -- * Formulating simple differential eqns.               DifferentialEqn-            , constLinearDEqn+            , constLinearODE+            , constLinearPDE             , filterDEqnSolution_static, iterateFilterDEqn_static             -- * Cost functions for error bounds             , maxDeviationsGoal             , uncertaintyGoal             , uncertaintyGoal'             , euclideanVolGoal+            -- * Solver configuration+            , InconsistencyStrategy(..)             ) where   import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE-import Data.Semigroup  import Data.VectorSpace+import Data.VectorSpace.Free import Math.LinearMap.Category import Data.AffineSpace import Data.Basis@@ -76,16 +79,39 @@ import Data.Traversable.Constrained (Traversable, traverse)  -constLinearDEqn :: ( WithField ℝ LinearManifold x, SimpleSpace x-                   , WithField ℝ LinearManifold y, SimpleSpace y )-              => (DualVector y +> (y +> x)) -> DifferentialEqn x y-constLinearDEqn bwt = factoriseShade-    >>> \(_x, Shade y δy) -> let j = bwt'inv y-                                 δj = bwt' `transformNorm` dualNorm δy-                             in Shade' j δj- where bwt' = adjoint $ bwt-       bwt'inv = (bwt'\$) +constLinearODE :: ∀ x y . ( WithField ℝ LinearManifold x, SimpleSpace x+                          , WithField ℝ LinearManifold y, SimpleSpace y )+              => ((x +> y) +> y) -> DifferentialEqn x y+constLinearODE = case ( dualSpaceWitness :: DualNeedleWitness x+                      , dualSpaceWitness :: DualNeedleWitness y ) of+   (DualSpaceWitness, DualSpaceWitness) -> \bwt' ->+    let bwt'inv = (bwt'\$)+    in \(Shade (_x,y) δxy) -> LocalDifferentialEqn+            (let j = bwt'inv y+                 δj = (bwt'>>>zeroV&&&id) `transformNorm` dualNorm δxy+             in return $ Shade' j δj )+            (\_ -> pure )++constLinearPDE :: ∀ x y y' .+                  ( WithField ℝ LinearManifold x, SimpleSpace x+                  , WithField ℝ LinearManifold y, SimpleSpace y, FiniteFreeSpace y+                  , WithField ℝ LinearManifold y', SimpleSpace y' )+              => ((x +> (y,y')) +> (y, y')) -> DifferentialEqn x (y,y')+constLinearPDE = undefined{-case ( dualSpaceWitness :: DualNeedleWitness x+                      , dualSpaceWitness :: DualNeedleWitness y+                      , dualSpaceWitness :: DualSpaceWitness y' ) of+   (DualSpaceWitness, DualSpaceWitness, DualSpaceWitness) -> \bwt' ->+    let bwt'inv = (bwt'\$)+    in  \(Shade (_x,(y,y')) δxy) (Shade' jApriori σjApriori)+                            -> let j = bwt'inv $ (zeroV,y')+                                   δj = (bwt'>>>zeroV&&&id)+                                         `transformNorm` dualNorm δxy+                                   (_,y'Apriori) = bwt' $ jApriori+                                   Norm δy' = (arr $ LinearFunction bwt'inv . (zeroV&&&id))+                                         `transformNorm` σjApriori+                             in (Shade' (y,y'Apriori) . Norm $ zeroV *** δy' , )+                              <$> mixShade's (Shade' jApriori σjApriori :| [Shade' j δj])-}  -- | A function that variates, relatively speaking, most strongly --   for arguments around 1. In the zero-limit it approaches a constant

@@ -110,8 +110,10 @@                 | n < 0      = floor $ lg (-n)  -instance ( SimpleSpace (Needle m), SimpleSpace (Needle n), SimpleSpace (Needle a)-         , Griddable m a, Griddable n a ) => Griddable (m,n) a where+instance ∀ m n a+    . ( SimpleSpace (Needle m), SimpleSpace (Needle n), SimpleSpace (Needle a)+      , Griddable m a, Griddable n a, m ~ Interior m, n ~ Interior n )+             => Griddable (m,n) a where   data GriddingParameters (m,n) a = PairGriddingParameters {                fstGriddingParams :: GriddingParameters m a              , sndGriddingParams :: GriddingParameters n a }@@ -124,7 +126,9 @@               <$> g₂s )    where g₁s = mkGridding p₁ n $ fullShade c₁ e₁          g₂s = mkGridding p₂ n $ fullShade c₂ e₂-         (e₁,e₂) = summandSpaceNorms e₁e₂ +         (e₁,e₂) = case ( dualSpaceWitness :: DualNeedleWitness m+                        , dualSpaceWitness :: DualNeedleWitness n ) of+                (DualSpaceWitness, DualSpaceWitness) -> summandSpaceNorms e₁e₂   prettyFloatShow :: Int -> Double -> String prettyFloatShow _ 0 = "0"

@@ -34,6 +34,7 @@ {-# LANGUAGE LiberalTypeSynonyms      #-} {-# LANGUAGE DataKinds                #-} {-# LANGUAGE GADTs                    #-}+{-# LANGUAGE StandaloneDeriving       #-} {-# LANGUAGE RankNTypes               #-} {-# LANGUAGE TupleSections            #-} {-# LANGUAGE ConstraintKinds          #-}@@ -53,11 +54,17 @@             , Semimanifold(..), Needle'             , PseudoAffine(..)             -- * Type definitions+            -- ** Needles+            , Local(..)             -- ** Metrics             , Metric, Metric', euclideanMetric             , RieMetric, RieMetric'             -- ** Constraints             , SemimanifoldWitness(..)+            , PseudoAffineWitness(..)+            , BoundarylessWitness(..)+            , boundarylessWitness+            , DualNeedleWitness              , RealDimension, AffineManifold             , LinearManifold             , WithField@@ -72,9 +79,9 @@             ) where      +import Math.Manifold.Core.PseudoAffine  import Data.Maybe-import Data.Semigroup import Data.Fixed  import Data.VectorSpace@@ -104,146 +111,15 @@ import GHC.Exts (Constraint)  ---- | This is the reified form of the property that the interior of a semimanifold---   is a manifold.-data SemimanifoldWitness x where-  SemimanifoldWitness ::-      ( Semimanifold (Interior x), Semimanifold (Needle x)-      , Interior (Interior x) ~ Interior x, Needle (Interior x) ~ Needle x-      , Interior (Needle x) ~ Needle x )-     => SemimanifoldWitness x---infix 6 .-~.-infixl 6 .+~^, .-~^--class AdditiveGroup (Needle x) => Semimanifold x where-  {-# MINIMAL ((.+~^) | fromInterior), toInterior, translateP #-}-  -- | The space of &#x201c;natural&#x201d; ways starting from some reference point-  --   and going to some particular target point. Hence,-  --   the name: like a compass needle, but also with an actual length.-  --   For affine spaces, 'Needle' is simply the space of-  --   line segments (aka vectors) between two points, i.e. the same as 'Diff'.-  --   The 'AffineManifold' constraint makes that requirement explicit.-  -- -  --   This space should be isomorphic to the tangent space (and is in fact-  --   used somewhat synonymously).-  type Needle x :: *   -  -- | Manifolds with boundary are a bit tricky. We support such manifolds,-  --   but carry out most calculations only in “the fleshy part” – the-  --   interior, which is an “infinite space”, so you can arbitrarily scale paths.-  -- -  --   The default implementation is @'Interior' x = x@, which corresponds-  --   to a manifold that has no boundary to begin with.-  type Interior x :: *-  type Interior x = x   -  -- | Generalised translation operation. Note that the result will always also-  --   be in the interior; scaling up the needle can only get you ever /closer/-  --   to a boundary.-  (.+~^) :: Interior x -> Needle x -> x-  (.+~^) = addvp-   where addvp :: ∀ x . Semimanifold x => Interior x -> Needle x -> x-         addvp p = fromInterior . tp p-          where (Tagged tp) = translateP :: Tagged x (Interior x -> Needle x -> Interior x)-    -  -- | 'id' sans boundary.-  fromInterior :: Interior x -> x-  fromInterior p = p .+~^ zeroV -  -  toInterior :: x -> Option (Interior x)-  -  -- | The signature of '.+~^' should really be @'Interior' x -> 'Needle' x -> 'Interior' x@,-  --   only, this is not possible because it only consists of non-injective type families.-  --   The solution is this tagged signature, which is of course rather unwieldy. That's-  --   why '.+~^' has the stronger, but easier usable signature. Without boundary, these-  --   functions should be equivalent, i.e. @translateP = Tagged (.+~^)@.-  translateP :: Tagged x (Interior x -> Needle x -> Interior x)-  -  -- | Shorthand for @\\p v -> p .+~^ 'negateV' v@, which should obey the /asymptotic/ law-  --   -  -- @-  -- p .-~^ v .+~^ v &#x2245; p-  -- @-  --   -  --   Meaning: if @v@ is scaled down with sufficiently small factors /&#x3b7;/, then-  --   the difference @(p.-~^v.+~^v) .-~. p@ should scale down even faster:-  --   as /O/ (/&#x3b7;/&#xb2;). For large vectors, it will however behave differently,-  --   except in flat spaces (where all this should be equivalent to the 'AffineSpace'-  --   instance).-  (.-~^) :: Interior x -> Needle x -> x-  p .-~^ v = p .+~^ negateV v-  -  semimanifoldWitness :: SemimanifoldWitness x-  default semimanifoldWitness ::-      ( Semimanifold (Interior x), Semimanifold (Needle x)-      , Interior (Interior x) ~ Interior x, Needle (Interior x) ~ Needle x-      , Interior (Needle x) ~ Needle x )-     => SemimanifoldWitness x-  semimanifoldWitness = SemimanifoldWitness -  --- | This is the class underlying manifolds. ('Manifold' only precludes boundaries---   and adds an extra constraint that would be circular if it was in a single---   class. You can always just use 'Manifold' as a constraint in your signatures,---   but you must /define/ only 'PseudoAffine' for manifold types &#x2013;---   the 'Manifold' instance follows universally from this, if @'Interior x ~ x@.)---   ---   The interface is (boundaries aside) almost identical to the better-known---   'AffineSpace' class, but we don't require associativity of '.+~^' with '^+^'---   &#x2013; except in an /asymptotic sense/ for small vectors.---   ---   That innocent-looking change makes the class applicable to vastly more general types:---   while an affine space is basically nothing but a vector space without particularly---   designated origin, a pseudo-affine space can have nontrivial topology on the global---   scale, and yet be used in practically the same way as an affine space. At least the---   usual spheres and tori make good instances, perhaps the class is in fact equivalent to---   manifolds in their usual maths definition (with an atlas of charts: a family of---   overlapping regions of the topological space, each homeomorphic to the 'Needle'---   vector space or some simply-connected subset thereof).-class ( Semimanifold x, Semimanifold (Interior x)-      , Needle (Interior x) ~ Needle x, Interior (Interior x) ~ Interior x)-        => PseudoAffine x where-  {-# MINIMAL (.-~.) | (.-~!) #-}-  -- | The path reaching from one point to another.-  --   Should only yield 'Nothing' if-  -- -  --   * The points are on disjoint segments of a non&#x2013;path-connected space.-  -- -  --   * Either of the points is on the boundary. Use '|-~.' to deal with this.-  -- -  --   On manifolds, the identity-  --   -  -- @-  -- p .+~^ (q.-~.p) &#x2261; q-  -- @-  --   -  --   should hold, at least save for floating-point precision limits etc..-  -- -  --   '.-~.' and '.+~^' only really work in manifolds without boundary. If you consider-  --   the path between two points, one of which lies on the boundary, it can't really-  --   be possible to scale this path any longer – it would have to reach “out of the-  --   manifold”. To adress this problem, these functions basically consider only the-  --   /interior/ of the space.-  (.-~.) :: x -> Interior x -> Option (Needle x)-  p.-~.q = return $ p.-~!q-  -  -- | Unsafe version of '.-~.'. If the two points lie in disjoint regions,-  --   the behaviour is undefined.-  (.-~!) :: x -> Interior x -> Needle x-  p.-~!q = case p.-~.q of-      Option (Just v) -> v-  --  -  -  - -- | See 'Semimanifold' and 'PseudoAffine' for the methods.-class (PseudoAffine m, LinearManifold (Needle m), Interior m ~ m) => Manifold m-instance (PseudoAffine m, LinearManifold (Needle m), Interior m ~ m) => Manifold m+class (PseudoAffine m, LSpace (Needle m)) => Manifold m where+  boundarylessWitness :: BoundarylessWitness m+  default boundarylessWitness :: (m ~ Interior m) => BoundarylessWitness m+  boundarylessWitness = BoundarylessWitness+instance (PseudoAffine m, LSpace (Needle m), Interior m ~ m) => Manifold m   @@ -293,11 +169,15 @@ data CanonicalDiffeomorphism a b where   CanonicalDiffeomorphism :: LocallyCoercible a b => CanonicalDiffeomorphism a b +-- | A point on a manifold, as seen from a nearby reference point.+newtype Local x = Local { getLocalOffset :: Needle x }+deriving instance (Show (Needle x)) => Show (Local x)  type LocallyScalable s x = ( PseudoAffine x                            , LSpace (Needle x)                            , s ~ Scalar (Needle x)-                           , Num''' s )+                           , s ~ Scalar (Needle' x)+                           , Num' s )  type LocalLinear x y = LinearMap (Scalar (Needle x)) (Needle x) (Needle y) type LocalAffine x y = (Needle y, LocalLinear x y)@@ -316,7 +196,7 @@ --   general need the @-XLiberalTypeSynonyms@ extension (except if the constraint --   is an actual type class (like 'Manifold'): only those can always be partially --   applied, for @type@ constraints this is by default not allowed).-type WithField s c x = ( c x, s ~ Scalar (Needle x) )+type WithField s c x = ( c x, s ~ Scalar (Needle x), s ~ Scalar (Needle' x) )  -- | The 'RealFloat' class plus manifold constraints. type RealDimension r = ( PseudoAffine r, Interior r ~ r, Needle r ~ r, r ~ ℝ)@@ -339,7 +219,7 @@ type EuclidSpace x = ( AffineManifold x, InnerSpace (Diff x)                      , DualVector (Diff x) ~ Diff x, Floating (Scalar (Diff x)) ) -type NumberManifold n = ( Num''' n, Manifold n, Interior n ~ n, Needle n ~ n+type NumberManifold n = ( Num' n, Manifold n, Interior n ~ n, Needle n ~ n                         , LSpace n, DualVector n ~ n, Scalar n ~ n )  euclideanMetric :: EuclidSpace x => proxy x -> Metric x@@ -372,49 +252,28 @@  coerceMetric :: ∀ x ξ . (LocallyCoercible x ξ, LSpace (Needle ξ))                              => RieMetric ξ -> RieMetric x-coerceMetric m x = case m $ locallyTrivialDiffeomorphism x of+coerceMetric = case ( dualSpaceWitness :: DualNeedleWitness x+                    , dualSpaceWitness :: DualNeedleWitness ξ ) of+   (DualSpaceWitness, DualSpaceWitness)+       -> \m x -> case m $ locallyTrivialDiffeomorphism x of               Norm sc -> Norm $ bw . sc . fw  where fw = coerceNeedle ([]::[(x,ξ)])        bw = case oppositeLocalCoercion :: CanonicalDiffeomorphism ξ x of               CanonicalDiffeomorphism -> coerceNeedle' ([]::[(ξ,x)]) coerceMetric' :: ∀ x ξ . (LocallyCoercible x ξ, LSpace (Needle ξ))                              => RieMetric' ξ -> RieMetric' x-coerceMetric' m x = case m $ locallyTrivialDiffeomorphism x of+coerceMetric' = case ( dualSpaceWitness :: DualNeedleWitness x+                     , dualSpaceWitness :: DualNeedleWitness ξ ) of+   (DualSpaceWitness, DualSpaceWitness)+       -> \m x -> case m $ locallyTrivialDiffeomorphism x of               Norm sc -> Norm $ bw . sc . fw  where fw = coerceNeedle' ([]::[(x,ξ)])        bw = case oppositeLocalCoercion :: CanonicalDiffeomorphism ξ x of               CanonicalDiffeomorphism -> coerceNeedle ([]::[(ξ,x)])  --- | Interpolate between points, approximately linearly. For---   points that aren't close neighbours (i.e. lie in an almost---   flat region), the pathway is basically undefined – save for---   its end points.--- ---   A proper, really well-defined (on global scales) interpolation---   only makes sense on a Riemannian manifold, as 'Data.Manifold.Riemannian.Geodesic'.-palerp :: ∀ x. Manifold x-    => Interior x -> Interior x -> Option (Scalar (Needle x) -> x)-palerp p1 p2 = case (fromInterior p2 :: x) .-~. p1 of-  Option (Just v) -> return $ \t -> p1 .+~^ t *^ v-  _ -> empty --- | Like 'palerp', but actually restricted to the interval between the points,---   with a signature like 'Data.Manifold.Riemannian.geodesicBetween'---   rather than 'Data.AffineSpace.alerp'.-palerpB :: ∀ x. WithField ℝ Manifold x => Interior x -> Interior x -> Option (D¹ -> x)-palerpB p1 p2 = case (fromInterior p2 :: x) .-~. p1 of-  Option (Just v) -> return $ \(D¹ t) -> p1 .+~^ ((t+1)/2) *^ v-  _ -> empty --- | Like 'alerp', but actually restricted to the interval between the points.-alerpB :: ∀ x. (AffineSpace x, VectorSpace (Diff x), Scalar (Diff x) ~ ℝ)-                   => x -> x -> D¹ -> x-alerpB p1 p2 = case p2 .-. p1 of-  v -> \(D¹ t) -> p1 .+^ ((t+1)/2) *^ v--- hugeℝVal :: ℝ hugeℝVal = 1e+100 @@ -428,12 +287,7 @@ instance (c) => PseudoAffine (t) where {       \   a.-~.b = pure (a.-.b);      } -deriveAffine((),Double)-deriveAffine((),Rational)-deriveAffine(NumberManifold s, V1 s)-deriveAffine(NumberManifold s, V2 s)-deriveAffine(NumberManifold s, V3 s)-deriveAffine(NumberManifold s, V4 s)+deriveAffine(KnownNat n, FreeVect n ℝ)  instance (NumberManifold s) => LocallyCoercible (ZeroDim s) (V0 s) where   locallyTrivialDiffeomorphism Origin = V0@@ -484,43 +338,12 @@   coerceNeedle _ = LinearFunction $ \(V4 x y z w) -> ((x,y),(z,w))   coerceNeedle' _ = LinearFunction $ \(V4 x y z w) -> ((x,y),(z,w)) -instance Semimanifold (ZeroDim k) where-  type Needle (ZeroDim k) = ZeroDim k-  fromInterior = id-  toInterior = pure-  Origin .+~^ Origin = Origin-  Origin .-~^ Origin = Origin-  translateP = Tagged (.+~^)-instance PseudoAffine (ZeroDim k) where-  Origin .-~. Origin = pure Origin-instance Num k => Semimanifold (V0 k) where-  type Needle (V0 k) = V0 k-  fromInterior = id-  toInterior = pure-  V0 .+~^ V0 = V0-  V0 .-~^ V0 = V0-  translateP = Tagged (.+~^)-instance Num k => PseudoAffine (V0 k) where-  V0 .-~. V0 = pure V0 -instance ∀ a b . (Semimanifold a, Semimanifold b) => Semimanifold (a,b) where-  type Needle (a,b) = (Needle a, Needle b)-  type Interior (a,b) = (Interior a, Interior b)-  (a,b).+~^(v,w) = (a.+~^v, b.+~^w)-  (a,b).-~^(v,w) = (a.-~^v, b.-~^w)-  fromInterior (i,j) = (fromInterior i, fromInterior j)-  toInterior (a,b) = fzip (toInterior a, toInterior b)-  translateP = Tagged $ \(a,b) (v,w) -> (ta a v, tb b w)-   where Tagged ta = translateP :: Tagged a (Interior a -> Needle a -> Interior a)-         Tagged tb = translateP :: Tagged b (Interior b -> Needle b -> Interior b)-  semimanifoldWitness = case ( semimanifoldWitness :: SemimanifoldWitness a-                             , semimanifoldWitness :: SemimanifoldWitness b ) of-             (SemimanifoldWitness, SemimanifoldWitness) -> SemimanifoldWitness-instance (PseudoAffine a, PseudoAffine b) => PseudoAffine (a,b) where-  (a,b).-~.(c,d) = liftA2 (,) (a.-~.c) (b.-~.d) instance ( Semimanifold a, Semimanifold b, Semimanifold c          , LSpace (Needle a), LSpace (Needle b), LSpace (Needle c)-         , Scalar (Needle a) ~ Scalar (Needle b), Scalar (Needle b) ~ Scalar (Needle c) )+         , Scalar (Needle a) ~ Scalar (Needle b), Scalar (Needle b) ~ Scalar (Needle c)+         , Scalar (Needle' a) ~ Scalar (Needle a), Scalar (Needle' b) ~ Scalar (Needle b)+         , Scalar (Needle' c) ~ Scalar (Needle c) )      => LocallyCoercible (a,(b,c)) ((a,b),c) where   locallyTrivialDiffeomorphism = regroup   coerceNeedle _ = regroup@@ -529,12 +352,16 @@   interiorLocalCoercion _ = case ( semimanifoldWitness :: SemimanifoldWitness a                                  , semimanifoldWitness :: SemimanifoldWitness b                                  , semimanifoldWitness :: SemimanifoldWitness c ) of-       (SemimanifoldWitness, SemimanifoldWitness, SemimanifoldWitness)+       ( SemimanifoldWitness BoundarylessWitness+        ,SemimanifoldWitness BoundarylessWitness+        ,SemimanifoldWitness BoundarylessWitness )               -> CanonicalDiffeomorphism instance ∀ a b c .          ( Semimanifold a, Semimanifold b, Semimanifold c          , LSpace (Needle a), LSpace (Needle b), LSpace (Needle c)-         , Scalar (Needle a) ~ Scalar (Needle b), Scalar (Needle b) ~ Scalar (Needle c) )+         , Scalar (Needle a) ~ Scalar (Needle b), Scalar (Needle b) ~ Scalar (Needle c)+         , Scalar (Needle' a) ~ Scalar (Needle a), Scalar (Needle' b) ~ Scalar (Needle b)+         , Scalar (Needle' c) ~ Scalar (Needle c)  )      => LocallyCoercible ((a,b),c) (a,(b,c)) where   locallyTrivialDiffeomorphism = regroup'   coerceNeedle _ = regroup'@@ -543,30 +370,12 @@   interiorLocalCoercion _ = case ( semimanifoldWitness :: SemimanifoldWitness a                                  , semimanifoldWitness :: SemimanifoldWitness b                                  , semimanifoldWitness :: SemimanifoldWitness c ) of-       (SemimanifoldWitness, SemimanifoldWitness, SemimanifoldWitness)+       ( SemimanifoldWitness BoundarylessWitness+        ,SemimanifoldWitness BoundarylessWitness+        ,SemimanifoldWitness BoundarylessWitness )             -> CanonicalDiffeomorphism -instance ∀ a b c . (Semimanifold a, Semimanifold b, Semimanifold c)-                          => Semimanifold (a,b,c) where-  type Needle (a,b,c) = (Needle a, Needle b, Needle c)-  type Interior (a,b,c) = (Interior a, Interior b, Interior c)-  (a,b,c).+~^(v,w,x) = (a.+~^v, b.+~^w, c.+~^x)-  (a,b,c).-~^(v,w,x) = (a.-~^v, b.-~^w, c.-~^x)-  fromInterior (i,j,k) = (fromInterior i, fromInterior j, fromInterior k)-  toInterior (a,b,c) = liftA3 (,,) (toInterior a) (toInterior b) (toInterior c)-  translateP = Tagged $ \(a,b,c) (v,w,x) -> (ta a v, tb b w, tc c x)-   where Tagged ta = translateP :: Tagged a (Interior a -> Needle a -> Interior a)-         Tagged tb = translateP :: Tagged b (Interior b -> Needle b -> Interior b)-         Tagged tc = translateP :: Tagged c (Interior c -> Needle c -> Interior c)-  semimanifoldWitness = case ( semimanifoldWitness :: SemimanifoldWitness a-                             , semimanifoldWitness :: SemimanifoldWitness b-                             , semimanifoldWitness :: SemimanifoldWitness c ) of-             (SemimanifoldWitness, SemimanifoldWitness, SemimanifoldWitness)-                   -> SemimanifoldWitness-instance (PseudoAffine a, PseudoAffine b, PseudoAffine c) => PseudoAffine (a,b,c) where-  (a,b,c).-~.(d,e,f) = liftA3 (,,) (a.-~.d) (b.-~.e) (c.-~.f) - instance LinearManifold (a n) => Semimanifold (LinAff.Point a n) where   type Needle (LinAff.Point a n) = a n   fromInterior = id@@ -577,70 +386,8 @@   LinAff.P v .-~. LinAff.P w = return $ v ^-^ w  -instance (LSpace a, LSpace b, s~Scalar a, s~Scalar b)-              => Semimanifold (Tensor s a b) where-  type Needle (Tensor s a b) = Tensor s a b-  fromInterior = id-  toInterior = pure-  translateP = Tagged (.+~^)-  (.+~^) = (^+^)-instance (LSpace a, LSpace b, s~Scalar a, s~Scalar b)-              => PseudoAffine (Tensor s a b) where-  a.-~.b = pure (a^-^b) -instance (LSpace a, LSpace b, Scalar a~s, Scalar b~s)-                          => Semimanifold (LinearMap s a b) where-  type Needle (LinearMap s a b) = LinearMap s a b-  fromInterior = id-  toInterior = pure-  translateP = Tagged (.+^)-  (.+~^) = (^+^)-instance (LSpace a, LSpace b, Scalar a~s, Scalar b~s)-                          => PseudoAffine (LinearMap s a b) where-  a.-~.b = pure (a^-^b) -instance Semimanifold S⁰ where-  type Needle S⁰ = ZeroDim ℝ-  fromInterior = id-  toInterior = pure-  translateP = Tagged (.+~^)-  p .+~^ Origin = p-  p .-~^ Origin = p-instance PseudoAffine S⁰ where-  PositiveHalfSphere .-~. PositiveHalfSphere = pure Origin-  NegativeHalfSphere .-~. NegativeHalfSphere = pure Origin-  _ .-~. _ = Option Nothing--instance Semimanifold S¹ where-  type Needle S¹ = ℝ-  fromInterior = id-  toInterior = pure-  translateP = Tagged (.+~^)-  S¹ φ₀ .+~^ δφ-     | φ' < 0     = S¹ $ φ' + tau-     | otherwise  = S¹ $ φ'-   where φ' = toS¹range $ φ₀ + δφ-instance PseudoAffine S¹ where-  S¹ φ₁ .-~. S¹ φ₀-     | δφ > pi     = pure (δφ - 2*pi)-     | δφ < (-pi)  = pure (δφ + 2*pi)-     | otherwise   = pure δφ-   where δφ = φ₁ - φ₀--instance Semimanifold D¹ where-  type Needle D¹ = ℝ-  type Interior D¹ = ℝ-  fromInterior = D¹ . tanh-  toInterior (D¹ x) | abs x < 1  = return $ atanh x-                    | otherwise  = empty-  translateP = Tagged (+)-instance PseudoAffine D¹ where-  D¹ 1 .-~. _ = empty-  D¹ (-1) .-~. _ = empty-  D¹ x .-~. y-    | abs x < 1  = return $ atanh x - y-    | otherwise  = empty- instance Semimanifold S² where   type Needle S² = ℝ²   fromInterior = id@@ -701,15 +448,9 @@                                  -tau :: ℝ-tau = 2 * pi -toS¹range :: ℝ -> ℝ-toS¹range φ = (φ+pi)`mod'`tau - pi  -- class ImpliesMetric s where   type MetricRequirement s x :: Constraint   type MetricRequirement s x = Semimanifold x@@ -723,4 +464,7 @@   inferMetric = id   inferMetric' = dualNorm +++type DualNeedleWitness x = DualSpaceWitness (Needle x) 

@@ -48,12 +48,12 @@  import Data.Maybe import qualified Data.Vector as Arr-import Data.Semigroup  import Data.VectorSpace import Data.VectorSpace.Free import Data.AffineSpace import Math.LinearMap.Category+import Linear (V0(..), V1(..), V2(..), V3(..), V4(..))  import Data.Manifold.Types import Data.Manifold.Types.Primitive ((^), empty, embed, coEmbed)@@ -83,10 +83,10 @@        -> x -- ^ End point, for +1.             --              --   If the two points are actually connected by a path...-       -> Option (D¹ -> x) -- ^ ...then this is the interpolation function. Attention: -                           --   the type will change to 'Differentiable' in the future.+       -> Maybe (D¹ -> x) -- ^ ...then this is the interpolation function. Attention: +                          --   the type will change to 'Differentiable' in the future. -interpolate :: (Geodesic x, IntervalLike i) => x -> x -> Option (i -> x)+interpolate :: (Geodesic x, IntervalLike i) => x -> x -> Maybe (i -> x) interpolate a b = (. toClosedInterval) <$> geodesicBetween a b  @@ -157,7 +157,7 @@ -- instance Geodesic (Cℝay S¹) where --   geodesicBetween p q = (>>> fromP) <$> geodesicBetween (toP p) (toP q) --    where fromP = fromInterior---          toP w = case toInterior w of {Option (Just i) -> i}+--          toP w = case toInterior w of {Just i -> i} --  -- instance Geodesic (CD¹ S¹) where --   geodesicBetween p q = (>>> fromI) <$> geodesicBetween (toI p) (toI q)@@ -167,7 +167,7 @@ -- instance Geodesic (Cℝay S²) where --   geodesicBetween p q = (>>> fromP) <$> geodesicBetween (toP p) (toP q) --    where fromP = fromInterior---          toP w = case toInterior w of {Option (Just i) -> i}+--          toP w = case toInterior w of {Just i -> i} --  -- instance Geodesic (CD¹ S²) where --   geodesicBetween p q = (>>> fromI) <$> geodesicBetween (toI p) (toI q :: ℝ³)@@ -192,6 +192,11 @@ --             , Geodesic (a,b)), (a,b)) -- geoVSpCone (KnownNat n, FreeVect n ℝ) +deriveAffineGD ((V0 ℝ))+deriveAffineGD (ℝ¹)+deriveAffineGD (ℝ²)+deriveAffineGD (ℝ³)+deriveAffineGD (ℝ⁴)   @@ -223,3 +228,9 @@  instance Riemannian ℝ where   rieMetric = const euclideanNorm+++++middleBetween :: Geodesic m => m -> m -> Maybe m+middleBetween p₀ p₁ = ($ D¹ 0) <$> geodesicBetween p₀ p₁

@@ -30,1585 +30,1859 @@ {-# LANGUAGE ViewPatterns               #-} {-# LANGUAGE LambdaCase                 #-} {-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE LiberalTypeSynonyms        #-}-{-# LANGUAGE RecordWildCards            #-}-{-# LANGUAGE DataKinds                  #-}---module Data.Manifold.TreeCover (-       -- * Shades -         Shade(..), pattern(:±), Shade'(..), (|±|), IsShade-       -- ** Lenses-       , shadeCtr, shadeExpanse, shadeNarrowness-       -- ** Construction-       , fullShade, fullShade', pointsShades, pointsShade's, pointsCovers, pointsCover's-       -- ** Evaluation-       , occlusion-       -- ** Misc-       , factoriseShade, intersectShade's-       , Refinable, subShade', refineShade', convolveShade', coerceShade-       -- * Shade trees-       , ShadeTree(..), fromLeafPoints, onlyLeaves, indexShadeTree, positionIndex-       -- * View helpers-       , onlyNodes-       -- ** Auxiliary types-       , SimpleTree, Trees, NonEmptyTree, GenericTree(..)-       -- * Misc-       , sShSaw, chainsaw, HasFlatView(..), shadesMerge, smoothInterpolate-       , twigsWithEnvirons, Twig, TwigEnviron-       , completeTopShading, flexTwigsShading-       , WithAny(..), Shaded, fmapShaded, stiAsIntervalMapping, spanShading-       , constShaded, stripShadedUntopological-       , DifferentialEqn, propagateDEqnSolution_loc-       -- ** Triangulation-builders-       , TriangBuild, doTriangBuild-       , AutoTriang, breakdownAutoTriang-    ) where---import Data.List hiding (filter, all, elem, sum, foldr1)-import Data.Maybe-import qualified Data.Map as Map-import qualified Data.Vector as Arr-import Data.List.NonEmpty (NonEmpty(..))-import Data.List.FastNub-import qualified Data.List.NonEmpty as NE-import Data.Semigroup-import Data.Ord (comparing)-import Control.DeepSeq--import Data.VectorSpace-import Data.AffineSpace-import Math.LinearMap.Category-import Data.Tagged--import Data.SimplicialComplex-import Data.Manifold.Types-import Data.Manifold.Types.Primitive ((^), empty)-import Data.Manifold.PseudoAffine-import Data.Manifold.Riemannian-    -import Data.Embedding-import Data.CoNat--import Lens.Micro (Lens')--import qualified Prelude as Hask hiding(foldl, sum, sequence)-import qualified Control.Applicative as Hask-import qualified Control.Monad       as Hask hiding(forM_, sequence)-import Data.Functor.Identity-import Control.Monad.Trans.State-import Control.Monad.Trans.Writer-import Control.Monad.Trans.OuterMaybe-import Control.Monad.Trans.Class-import qualified Data.Foldable       as Hask-import Data.Foldable (all, elem, toList, sum, foldr1)-import qualified Data.Traversable as Hask-import Data.Traversable (forM)--import Control.Category.Constrained.Prelude hiding-     ((^), all, elem, sum, forM, Foldable(..), foldr1, Traversable, traverse)-import Control.Arrow.Constrained-import Control.Monad.Constrained hiding (forM)-import Data.Foldable.Constrained-import Data.Traversable.Constrained (traverse)--import GHC.Generics (Generic)-import Data.Type.Coercion----- | Possibly / Partially / asymPtotically singular metric.-data PSM x = PSM {-       psmExpanse :: !(Metric' x)-     , relevantEigenspan :: ![Needle' x]-     }-       ---- | 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 = Shade { _shadeCtr :: !(Interior x)-                     , _shadeExpanse :: !(Metric' x) }-deriving instance (Show x, Show (Metric' x), WithField ℝ Manifold 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'Ctr :: !(Interior x)-                       , _shade'Narrowness :: !(Metric x) }-deriving instance (Show x, Show (Metric x), WithField ℝ Manifold x) => Show (Shade' x)--class IsShade shade where---  type (*) shade :: *->*-  -- | Access the center of a 'Shade' or a 'Shade''.-  shadeCtr :: Lens' (shade x) (Interior 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 :: ( Manifold x, SimpleSpace (Needle x)-               , s ~ (Scalar (Needle x)), RealDimension s )-                => shade x -> x -> s-  factoriseShade :: ( Manifold x, SimpleSpace (Needle x)-                    , Manifold 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) => shade x -> shade y--instance IsShade Shade where-  shadeCtr f (Shade c e) = fmap (`Shade`e) $ f c-  occlusion (Shade p₀ δ) = occ-   where occ p = case p .-~. p₀ of-           Option(Just vd) | mSq <- normSq δinv vd-                           , mSq == mSq  -- avoid NaN-                           -> exp (negate mSq)-           _               -> zeroV-         δinv = dualNorm δ-  factoriseShade (Shade (x₀,y₀) δxy) = (Shade x₀ δx, Shade y₀ δy)-   where (δx,δy) = summandSpaceNorms δxy-  coerceShade = cS-   where cS :: ∀ x y . (LocallyCoercible x y) => Shade x -> Shade y-         cS = \(Shade x δxym) -> Shade (internCoerce x) (tN δxym)-          where tN = case oppositeLocalCoercion :: CanonicalDiffeomorphism y x of-                      CanonicalDiffeomorphism ->-                       transformNorm . arr $ coerceNeedle' ([]::[(y,x)])-                internCoerce = case interiorLocalCoercion ([]::[(x,y)]) of-                      CanonicalDiffeomorphism -> locallyTrivialDiffeomorphism--instance ImpliesMetric Shade where-  type MetricRequirement Shade x = (Manifold x, SimpleSpace (Needle x))-  inferMetric' (Shade _ e) = e-  inferMetric (Shade _ e) = dualNorm e--instance ImpliesMetric Shade' where-  type MetricRequirement Shade' x = (Manifold x, SimpleSpace (Needle x))-  inferMetric (Shade' _ e) = e-  inferMetric' (Shade' _ e) = dualNorm e--shadeExpanse :: Lens' (Shade x) (Metric' x)-shadeExpanse f (Shade c e) = fmap (Shade c) $ f e--instance IsShade Shade' where-  shadeCtr f (Shade' c e) = fmap (`Shade'`e) $ f c-  occlusion (Shade' p₀ δinv) = occ-   where occ p = case p .-~. p₀ of-           Option(Just vd) | mSq <- normSq δinv vd-                           , mSq == mSq  -- avoid NaN-                           -> exp (negate mSq)-           _               -> zeroV-  factoriseShade (Shade' (x₀,y₀) δxy) = (Shade' x₀ δx, Shade' y₀ δy)-   where (δx,δy) = summandSpaceNorms δxy-  coerceShade = cS-   where cS :: ∀ x y . (LocallyCoercible x y) => Shade' x -> Shade' y-         cS = \(Shade' x δxym) -> Shade' (internCoerce x) (tN δxym)-          where tN = case oppositeLocalCoercion :: CanonicalDiffeomorphism y x of-                      CanonicalDiffeomorphism ->-                       transformNorm . arr $ coerceNeedle ([]::[(y,x)])-                internCoerce = case interiorLocalCoercion ([]::[(x,y)]) of-                      CanonicalDiffeomorphism -> locallyTrivialDiffeomorphism--shadeNarrowness :: Lens' (Shade' x) (Metric x)-shadeNarrowness f (Shade' c e) = fmap (Shade' c) $ f e--instance (AffineManifold x) => Semimanifold (Shade x) where-  type Needle (Shade x) = Diff x-  fromInterior = id-  toInterior = pure-  translateP = Tagged (.+~^)-  Shade c e .+~^ v = Shade (c.+^v) e-  Shade c e .-~^ v = Shade (c.-^v) e--instance (WithField ℝ AffineManifold x, Geodesic x, SimpleSpace (Needle x))-             => Geodesic (Shade x) where-  geodesicBetween (Shade c e) (Shade ζ η) = pure interp-   where sharedSpan = sharedNormSpanningSystem e η-         interp t = Shade (pinterp t)-                          (spanNorm [ v ^* (alerpB 1 qη t)-                                    | (v,qη) <- sharedSpan ])-         Option (Just pinterp) = geodesicBetween c ζ--instance (AffineManifold x) => Semimanifold (Shade' x) where-  type Needle (Shade' x) = Diff x-  fromInterior = id-  toInterior = pure-  translateP = Tagged (.+~^)-  Shade' c e .+~^ v = Shade' (c.+^v) e-  Shade' c e .-~^ v = Shade' (c.-^v) e--instance (WithField ℝ AffineManifold x, Geodesic x, SimpleSpace (Needle x))-            => Geodesic (Shade' x) where-  geodesicBetween (Shade' c e) (Shade' ζ η) = pure interp-   where sharedSpan = sharedNormSpanningSystem e η-         interp t = Shade' (pinterp t)-                           (spanNorm [ v ^/ (alerpB 1 (recip qη) t)-                                     | (v,qη) <- sharedSpan ])-         Option (Just pinterp) = geodesicBetween c ζ--fullShade :: WithField ℝ Manifold x => x -> Metric' x -> Shade x-fullShade ctr expa = Shade ctr expa--fullShade' :: WithField ℝ Manifold x => x -> Metric x -> Shade' x-fullShade' ctr expa = Shade' ctr expa----- | Span a 'Shade' from a center point and multiple deviation-vectors.-pattern (:±) :: () => (WithField ℝ Manifold x, SimpleSpace (Needle x))-                         => x -> [Needle x] -> Shade x-pattern x :± shs <- Shade x (normSpanningSystem -> shs)- where x :± shs = fullShade x $ spanVariance 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''.-(|±|) :: WithField ℝ EuclidSpace x => x -> [Needle x] -> Shade' x-x |±| shs = Shade' x $ spanNorm [v^/(v<.>v) | v<-shs]----subshadeId' :: WithField ℝ Manifold x-                   => x -> NonEmpty (Needle' x) -> x -> (Int, HourglassBulb)-subshadeId' c expvs x = case x .-~. c of-    Option (Just v) -> let (iu,vl) = maximumBy (comparing $ abs . snd)-                                      $ zip [0..] (map (v <.>^) $ NE.toList expvs)-                       in (iu, if vl>0 then UpperBulb else LowerBulb)-    _ -> (-1, error "Trying to obtain the subshadeId of a point not actually included in the shade.")--subshadeId :: (WithField ℝ Manifold x, FiniteDimensional (Needle' x))-                    => Shade x -> x -> (Int, HourglassBulb)-subshadeId (Shade c expa) = subshadeId' c . NE.fromList $ normSpanningSystem' expa-                 ----- | 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 ℝ Manifold x, SimpleSpace (Needle x))-                                 => [x] -> [Shade x]-pointsShades = map snd . pointsShades' mempty---- | 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 ℝ Manifold x, SimpleSpace (Needle x))-                          => [x] -> [Shade x]-pointsCovers = map guaranteeIn . pointsShades' mempty- where guaranteeIn (ps, Shade x₀ ex) -          = case ps >>= \p -> let Option (Just v) = p.-~.x₀-                              in guard ((ex'|$|v) > 1) >> [(p, spanVariance [v])]-             of []   -> Shade x₀ ex-                outs -> guaranteeIn ( fst<$>outs-                                    , Shade x₀-                                         $ ex <> scaleNorm-                                                   (sqrt . recip . fromIntegral-                                                               $ 2 * length outs)-                                                   (mconcat $ snd<$>outs)-                                    )-        where ex' = dualNorm ex--pointsShade's :: (WithField ℝ Manifold x, SimpleSpace (Needle x)) => [x] -> [Shade' x]-pointsShade's = map (\(Shade c e) -> Shade' c $ dualNorm e) . pointsShades--pointsCover's :: (WithField ℝ Manifold x, SimpleSpace (Needle x)) => [x] -> [Shade' x]-pointsCover's = map (\(Shade c e) -> Shade' c $ dualNorm e) . pointsCovers--pseudoECM :: (WithField ℝ Manifold x, SimpleSpace (Needle x))-                   => NonEmpty x -> (x, ([x],[x]))-pseudoECM (p₀ NE.:| psr) = foldl' ( \(acc, (rb,nr)) (i,p)-                                  -> case p.-~.acc of -                                      Option (Just δ) -> (acc .+~^ δ^/i, (p:rb, nr))-                                      _ -> (acc, (rb, p:nr)) )-                             (p₀, mempty)-                             ( zip [1..] $ p₀:psr )--pointsShades' :: (WithField ℝ Manifold x, SimpleSpace (Needle x))-                                => Metric' x -> [x] -> [([x], Shade x)]-pointsShades' _ [] = []-pointsShades' minExt ps = case expa of -                           Option (Just e) -> (ps, fullShade ctr e)-                                              : pointsShades' minExt unreachable-                           _ -> pointsShades' minExt inc'd-                                  ++ pointsShades' minExt unreachable- where (ctr,(inc'd,unreachable)) = pseudoECM $ NE.fromList ps-       expa = ( (<>minExt) . spanVariance . map (^/ fromIntegral (length ps)) )-              <$> mapM (.-~.ctr) 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 :: (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 fuzz (sh₁@(Shade c₁ e₁) : shs) = case extractJust tryMerge shs of-          (Just mg₁, shs') -> shadesMerge fuzz-                                $ shs'++[mg₁] -- Append to end to prevent undue weighting-                                              -- of first shade and its mergers.-          (_, shs') -> sh₁ : shadesMerge fuzz shs' - where tryMerge (Shade c₂ e₂)-           | Option (Just v) <- c₁.-~.c₂-           , Option (Just v') <- c₂.-~.c₁-           , [e₁',e₂'] <- dualNorm<$>[e₁, e₂] -           , b₁ <- e₂'|$|v-           , b₂ <- e₁'|$|v-           , fuzz*b₁*b₂ <= b₁ + b₂-                  = Just $ let cc = c₂ .+~^ v ^/ 2-                               Option (Just cv₁) = c₁.-~.cc-                               Option (Just cv₂) = c₂.-~.cc-                           in Shade cc $ e₁ <> e₂ <> spanVariance [cv₁, cv₂]-           | otherwise  = Nothing-shadesMerge _ shs = shs---- | 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' :: ( Manifold x, s ~ (Scalar (Needle x)), RealDimension s )-              => Shade' x -> x -> s-minusLogOcclusion' (Shade' p₀ δinv) = occ- where occ p = case p .-~. p₀ of-         Option(Just vd) | mSq <- normSq δinv vd-                         , mSq == mSq  -- avoid NaN-                         -> mSq-         _               -> 1/0-minusLogOcclusion :: ( Manifold x, SimpleSpace (Needle x)-                     , s ~ (Scalar (Needle x)), RealDimension s )-              => Shade x -> x -> s-minusLogOcclusion (Shade p₀ δ) = occ- where occ p = case p .-~. p₀ of-         Option(Just vd) | mSq <- normSq δinv vd-                         , mSq == mSq  -- avoid NaN-                         -> mSq-         _               -> 1/0-       δinv = dualNorm δ-  ------ | Hourglass as the geometric shape (two opposing ~conical volumes, sharing---   only a single point in the middle); has nothing to do with time.-data Hourglass s = Hourglass { upperBulb, lowerBulb :: !s }-            deriving (Generic, Hask.Functor, Hask.Foldable)-instance (NFData s) => NFData (Hourglass s)-instance (Semigroup s) => Semigroup (Hourglass s) where-  Hourglass u l <> Hourglass u' l' = Hourglass (u<>u') (l<>l')-  sconcat hgs = let (us,ls) = NE.unzip $ (upperBulb&&&lowerBulb) <$> hgs-                in Hourglass (sconcat us) (sconcat ls)-instance (Monoid s, Semigroup s) => Monoid (Hourglass s) where-  mempty = Hourglass mempty mempty; mappend = (<>)-  mconcat hgs = let (us,ls) = unzip $ (upperBulb&&&lowerBulb) <$> hgs-                in Hourglass (mconcat us) (mconcat ls)-instance Hask.Applicative Hourglass where-  pure x = Hourglass x x-  Hourglass f g <*> Hourglass x y = Hourglass (f x) (g y)-instance Foldable Hourglass (->) (->) where-  ffoldl f (x, Hourglass a b) = f (f(x,a), b)-  foldMap f (Hourglass a b) = f a `mappend` f b--flipHour :: Hourglass s -> Hourglass s-flipHour (Hourglass u l) = Hourglass l u--data HourglassBulb = UpperBulb | LowerBulb-oneBulb :: HourglassBulb -> (a->a) -> Hourglass a->Hourglass a-oneBulb UpperBulb f (Hourglass u l) = Hourglass (f u) l-oneBulb LowerBulb f (Hourglass u l) = Hourglass u (f l)----data ShadeTree x = PlainLeaves [x]-                 | DisjointBranches !Int (NonEmpty (ShadeTree x))-                 | OverlappingBranches !Int !(Shade x) (NonEmpty (DBranch x))-  deriving (Generic)-           -data DBranch' x c = DBranch { boughDirection :: !(Needle' x)-                            , boughContents :: !(Hourglass c) }-  deriving (Generic, Hask.Functor, Hask.Foldable)-type DBranch x = DBranch' x (ShadeTree x)--newtype DBranches' x c = DBranches (NonEmpty (DBranch' x c))-  deriving (Generic, Hask.Functor, Hask.Foldable)---- ^ /Unsafe/: this assumes the direction information of both containers to be equivalent.-instance (Semigroup c) => Semigroup (DBranches' x c) where-  DBranches b1 <> DBranches b2 = DBranches $ NE.zipWith (\(DBranch d1 c1) (DBranch _ c2)-                                                              -> DBranch d1 $ c1<>c2 ) b1 b2-  -directionChoices :: WithField ℝ Manifold x-               => [DBranch x]-                 -> [ ( (Needle' x, ShadeTree x)-                      ,[(Needle' x, ShadeTree x)] ) ]-directionChoices [] = []-directionChoices (DBranch ѧ (Hourglass t b) : hs)-       =  ( (ѧ,t), (v,b) : map fst uds)-          : ((v,b), (ѧ,t) : map fst uds)-          : map (second $ ((ѧ,t):) . ((v,b):)) uds- where v = negateV ѧ-       uds = directionChoices hs--traverseDirectionChoices :: (WithField ℝ Manifold x, Hask.Applicative f)-               => (    (Int, (Needle' x, ShadeTree x))-                    -> [(Int, (Needle' x, ShadeTree x))]-                    -> f (ShadeTree x) )-                 -> [DBranch x]-                 -> f [DBranch x]-traverseDirectionChoices f dbs-           = td [] . scanLeafNums 0-               $ dbs >>= \(DBranch ѧ (Hourglass τ β))-                              -> [(ѧ,τ), (negateV ѧ,β)]- where td pds (ѧt@(_,(ѧ,_)):vb:vds)-         = liftA3 (\t' b' -> (DBranch ѧ (Hourglass t' b') :))-             (f ѧt $ vb:uds)-             (f vb $ ѧt:uds)-             $ td (ѧt:vb:pds) vds-        where uds = pds ++ vds-       td _ _ = pure []-       scanLeafNums _ [] = []-       scanLeafNums i₀ ((v,t):vts) = (i₀, (v,t)) : scanLeafNums (i₀ + nLeaves t) vts---indexDBranches :: NonEmpty (DBranch x) -> NonEmpty (DBranch' x (Int, ShadeTree x))-indexDBranches (DBranch d (Hourglass t b) :| l) -- this could more concisely be written as a traversal-              = DBranch d (Hourglass (0,t) (nt,b)) :| ixDBs (nt + nb) l- where nt = nLeaves t; nb = nLeaves b-       ixDBs _ [] = []-       ixDBs i₀ (DBranch δ (Hourglass τ β) : l)-               = DBranch δ (Hourglass (i₀,τ) (i₀+nτ,β)) : ixDBs (i₀ + nτ + nβ) l-        where nτ = nLeaves τ; nβ = nLeaves β--instance (NFData x, NFData (Needle' x)) => NFData (ShadeTree x) where-  rnf (PlainLeaves xs) = rnf xs-  rnf (DisjointBranches n bs) = n `seq` rnf (NE.toList bs)-  rnf (OverlappingBranches n sh bs) = n `seq` sh `seq` rnf (NE.toList bs)-instance (NFData x, NFData (Needle' x)) => NFData (DBranch x)-  --- | Experimental. There might be a more powerful instance possible.-instance (AffineManifold x) => Semimanifold (ShadeTree x) where-  type Needle (ShadeTree x) = Diff x-  fromInterior = id-  toInterior = pure-  translateP = Tagged (.+~^)-  PlainLeaves xs .+~^ v = PlainLeaves $ (.+^v)<$>xs -  OverlappingBranches n sh br .+~^ v-        = OverlappingBranches n (sh.+~^v)-                $ fmap (\(DBranch d c) -> DBranch d $ (.+~^v)<$>c) br-  DisjointBranches n br .+~^ v = DisjointBranches n $ (.+~^v)<$>br---- | WRT union.-instance (WithField ℝ Manifold x, SimpleSpace (Needle x)) => Semigroup (ShadeTree x) where-  PlainLeaves [] <> t = t-  t <> PlainLeaves [] = t-  t <> s = fromLeafPoints $ onlyLeaves t ++ onlyLeaves s-           -- Could probably be done more efficiently-  sconcat = mconcat . NE.toList-instance (WithField ℝ Manifold x, SimpleSpace (Needle x)) => Monoid (ShadeTree x) where-  mempty = PlainLeaves []-  mappend = (<>)-  mconcat l = case filter ne l of-               [] -> mempty-               [t] -> t-               l' -> fromLeafPoints $ onlyLeaves =<< l'-   where ne (PlainLeaves []) = False; ne _ = True----- | Build a quite nicely balanced tree from a cloud of points, on any real manifold.--- ---   Example: https://nbviewer.jupyter.org/github/leftaroundabout/manifolds/blob/master/test/Trees-and-Webs.ipynb#pseudorandomCloudTree--- --- <<images/examples/simple-2d-ShadeTree.png>>-fromLeafPoints :: ∀ x. (WithField ℝ Manifold x, SimpleSpace (Needle x))-                         => [x] -> ShadeTree x-fromLeafPoints = fromLeafPoints' sShIdPartition----- | The leaves of a shade tree are numbered. For a given index, this function---   attempts to find the leaf with that ID, within its immediate environment.-indexShadeTree :: ∀ x . WithField ℝ Manifold x-       => ShadeTree x -> Int -> Either Int ([ShadeTree x], x)-indexShadeTree _ i-    | i<0        = Left i-indexShadeTree sh@(PlainLeaves lvs) i = case length lvs of-  n | i<n       -> Right ([sh], lvs!!i)-    | otherwise -> Left $ i-n-indexShadeTree (DisjointBranches n brs) i-    | i<n        = foldl (\case -                             Left i' -> (`indexShadeTree`i')-                             result  -> return result-                         ) (Left i) brs-    | otherwise  = Left $ i-n-indexShadeTree sh@(OverlappingBranches n _ brs) i-    | i<n        = first (sh:) <$> foldl (\case -                             Left i' -> (`indexShadeTree`i')-                             result  -> return result-                         ) (Left i) (toList brs>>=toList)-    | otherwise  = Left $ i-n----- | “Inverse indexing” of a tree. This is roughly a nearest-neighbour search,---   but not guaranteed to give the correct result unless evaluated at the---   precise position of a tree leaf.-positionIndex :: ∀ x . (WithField ℝ Manifold x, SimpleSpace (Needle x))-       => Option (Metric x)  -- ^ For deciding (at the lowest level) what “close” means;-                             --   this is optional for any tree of depth >1.-        -> ShadeTree x       -- ^ The tree to index into-        -> x                 -- ^ Position to look up-        -> Option (Int, ([ShadeTree x], x))-                   -- ^ Index of the leaf near to the query point, the “path” of-                   --   environment trees leading down to its position (in decreasing-                   --   order of size), and actual position of the found node.-positionIndex (Option (Just m)) sh@(PlainLeaves lvs) x-        = case catMaybes [ ((i,p),) . normSq m <$> getOption (p.-~.x)-                            | (i,p) <- zip [0..] lvs] of-           [] -> empty-           l | ((i,p),_) <- minimumBy (comparing snd) l-              -> pure (i, ([sh], p))-positionIndex m (DisjointBranches _ brs) x-        = fst . foldl' (\case-                          (q@(Option (Just _)), i₀) -> const (q, i₀)-                          (_, i₀) -> \t' -> ( first (+i₀) <$> positionIndex m t' x-                                            , i₀+nLeaves t' ) )-                       (empty, 0)-              $        brs-positionIndex _ sh@(OverlappingBranches n (Shade c ce) brs) x-   | Option (Just vx) <- x.-~.c-        = let (_,(i₀,t')) = maximumBy (comparing fst)-                       [ (σ*ω, t')-                       | DBranch d (Hourglass t'u t'd) <- NE.toList $ indexDBranches brs-                       , let ω = d<.>^vx-                       , (t',σ) <- [(t'u, 1), (t'd, -1)] ]-          in ((+i₀) *** first (sh:))-                 <$> positionIndex (return $ dualNorm ce) t' x-positionIndex _ _ _ = empty----fromFnGraphPoints :: ∀ x y . ( WithField ℝ Manifold x, WithField ℝ Manifold y-                             , SimpleSpace (Needle x), SimpleSpace (Needle y) )-                     => [(x,y)] -> ShadeTree (x,y)-fromFnGraphPoints = fromLeafPoints' fg_sShIdPart- where fg_sShIdPart :: Shade (x,y) -> [(x,y)] -> NonEmpty (DBranch' (x,y) [(x,y)])-       fg_sShIdPart (Shade c expa) xs-        | b:bs <- [DBranch (v, zeroV) mempty-                    | v <- normSpanningSystem'-                           (transformNorm (id&&&zeroV) expa :: Metric' x) ]-                      = sShIdPartition' c xs $ b:|bs--fromLeafPoints' :: ∀ x. (WithField ℝ Manifold x, SimpleSpace (Needle x)) =>-    (Shade x -> [x] -> NonEmpty (DBranch' x [x])) -> [x] -> ShadeTree x-fromLeafPoints' sShIdPart = go mempty- where go :: Metric' x -> [x] -> ShadeTree x-       go preShExpa = \xs -> case pointsShades' (scaleNorm (1/3) preShExpa) xs of-                     [] -> mempty-                     [(_,rShade)] -> let trials = sShIdPart rShade xs-                                     in case reduce rShade trials of-                                         Just redBrchs-                                           -> OverlappingBranches-                                                  (length xs) rShade-                                                  (branchProc (_shadeExpanse rShade) redBrchs)-                                         _ -> PlainLeaves xs-                     partitions -> DisjointBranches (length xs)-                                   . NE.fromList-                                    $ map (\(xs',pShade) -> go mempty xs') partitions-        where -              branchProc redSh = fmap (fmap $ go redSh)-                                 -              reduce :: Shade x -> NonEmpty (DBranch' x [x])-                                      -> Maybe (NonEmpty (DBranch' x [x]))-              reduce sh@(Shade c _) brCandidates-                        = case findIndex deficient cards of-                            Just i | (DBranch _ reBr, o:ok)-                                             <- amputateId i (NE.toList brCandidates)-                                           -> reduce sh-                                                $ sShIdPartition' c (fold reBr) (o:|ok)-                                   | otherwise -> Nothing-                            _ -> Just brCandidates-               where (cards, maxCard) = (NE.toList &&& maximum')-                                $ fmap (fmap length . boughContents) brCandidates-                     deficient (Hourglass u l) = any (\c -> c^2 <= maxCard + 1) [u,l]-                     maximum' = maximum . NE.toList . fmap (\(Hourglass u l) -> max u l)---sShIdPartition' :: WithField ℝ Manifold x-        => x -> [x] -> NonEmpty (DBranch' x [x])->NonEmpty (DBranch' x [x])-sShIdPartition' c xs st-           = foldr (\p -> let (i,h) = ssi p-                          in asList $ update_nth (\(DBranch d c)-                                                    -> DBranch d (oneBulb h (p:) c))-                                      i )-                   st xs- where ssi = subshadeId' c (boughDirection<$>st)-sShIdPartition :: (WithField ℝ Manifold x, SimpleSpace (Needle x))-                    => Shade x -> [x] -> NonEmpty (DBranch' x [x])-sShIdPartition (Shade c expa) xs- | b:bs <- [DBranch v mempty | v <- normSpanningSystem' expa]-    = sShIdPartition' c xs $ b:|bs-                                           --asList :: ([a]->[b]) -> NonEmpty a->NonEmpty b-asList f = NE.fromList . f . NE.toList--update_nth :: (a->a) -> Int -> [a] -> [a]-update_nth _ n l | n<0 = l-update_nth f 0 (c:r) = f c : r-update_nth f n [] = []-update_nth f n (l:r) = l : update_nth f (n-1) r---amputateId :: Int -> [a] -> (a,[a])-amputateId i l = let ([a],bs) = amputateIds [i] l in (a, bs)--deleteIds :: [Int] -> [a] -> [a]-deleteIds kids = snd . amputateIds kids--amputateIds :: [Int]     -- ^ Sorted list of non-negative indices to extract-            -> [a]       -- ^ Input list-            -> ([a],[a]) -- ^ (Extracted elements, remaining elements)-amputateIds = go 0- where go _ _ [] = ([],[])-       go _ [] l = ([],l)-       go i (k:ks) (x:xs)-         | i==k       = first  (x:) $ go (i+1)    ks  xs-         | otherwise  = second (x:) $ go (i+1) (k:ks) xs-----sortByKey :: Ord a => [(a,b)] -> [b]-sortByKey = map snd . sortBy (comparing fst)---trunks :: ∀ x. (WithField ℝ Manifold x, SimpleSpace (Needle x))-                  => ShadeTree x -> [Shade x]-trunks (PlainLeaves lvs) = pointsCovers lvs-trunks (DisjointBranches _ brs) = Hask.foldMap trunks brs-trunks (OverlappingBranches _ sh _) = [sh]---nLeaves :: ShadeTree x -> Int-nLeaves (PlainLeaves lvs) = length lvs-nLeaves (DisjointBranches n _) = n-nLeaves (OverlappingBranches n _ _) = n---instance ImpliesMetric ShadeTree where-  type MetricRequirement ShadeTree x = (WithField ℝ Manifold x, SimpleSpace (Needle x))-  inferMetric (OverlappingBranches _ (Shade _ e) _) = dualNorm e-  inferMetric (PlainLeaves lvs) = case pointsShades lvs of-        (Shade _ sh:_) -> dualNorm sh-        _ -> mempty-  inferMetric (DisjointBranches _ (br:|_)) = inferMetric br-  inferMetric' (OverlappingBranches _ (Shade _ e) _) = e-  inferMetric' (PlainLeaves lvs) = case pointsShades lvs of-        (Shade _ sh:_) -> sh-        _ -> mempty-  inferMetric' (DisjointBranches _ (br:|_)) = inferMetric' br----overlappingBranches :: Shade x -> NonEmpty (DBranch x) -> ShadeTree x-overlappingBranches shx brs = OverlappingBranches n shx brs- where n = sum $ fmap (sum . fmap nLeaves) brs--unsafeFmapLeaves :: (x -> x) -> ShadeTree x -> ShadeTree x-unsafeFmapLeaves f (PlainLeaves lvs) = PlainLeaves $ fmap f lvs-unsafeFmapLeaves f (DisjointBranches n brs)-                  = DisjointBranches n $ unsafeFmapLeaves f <$> brs-unsafeFmapLeaves f (OverlappingBranches n sh brs)-                  = OverlappingBranches n sh $ fmap (unsafeFmapLeaves f) <$> brs--unsafeFmapTree :: (NonEmpty x -> NonEmpty y)-               -> (Needle' x -> Needle' y)-               -> (Shade x -> Shade y)-               -> ShadeTree x -> ShadeTree y-unsafeFmapTree _ _ _ (PlainLeaves []) = PlainLeaves []-unsafeFmapTree f _ _ (PlainLeaves lvs) = PlainLeaves . toList . f $ NE.fromList lvs-unsafeFmapTree f fn fs (DisjointBranches n brs)-    = let brs' = unsafeFmapTree f fn fs <$> brs-      in DisjointBranches (sum $ nLeaves<$>brs') brs'-unsafeFmapTree f fn fs (OverlappingBranches n sh brs)-    = let brs' = fmap (\(DBranch dir br)-                      -> DBranch (fn dir) (unsafeFmapTree f fn fs<$>br)-                      ) brs-      in overlappingBranches (fs sh) brs'----- | 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 ℝ Manifold y, SimpleSpace (Needle y)) => Refinable y where-  -- | @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' ac ae) tsh = all ((<1) . minusLogOcclusion' tsh)-                                  [ ac.+~^σ*^v | σ<-[-1,1], v<-normSpanningSystem' ae ]-  -  refineShade' :: Shade' y -> Shade' y -> Option (Shade' y)-  refineShade' (Shade' c₀ (Norm e₁)) -               (Shade' c₀₂ (Norm e₂))-           | Option (Just c₂) <- c₀₂.-~.c₀-           , e₁c₂ <- e₁ $ c₂-           , e₂c₂ <- e₂ $ c₂-           , cc <- σe \$ e₂c₂-           , cc₂ <- cc ^-^ c₂-           , e₁cc <- e₁ $ cc-           , e₂cc <- e₂ $ cc-           , α <- 2 + cc₂<.>^e₂c₂-           , α > 0-           , ee <- σe ^/ α-           , c₂e₁c₂ <- c₂<.>^e₁c₂-           , c₂e₂c₂ <- c₂<.>^e₂c₂-           , c₂eec₂ <- (c₂e₁c₂ + c₂e₂c₂) / α-           , [γ₁,γ₂] <- middle . sort-                $ quadraticEqnSol c₂e₁c₂-                                  (2 * (c₂<.>^e₁cc))-                                  (cc<.>^e₁cc - 1)-               ++ quadraticEqnSol c₂e₂c₂-                                  (2 * (c₂<.>^e₂cc - c₂e₂c₂))-                                  (cc<.>^e₂cc - 2 * (cc<.>^e₂c₂) + c₂e₂c₂ - 1)-           , cc' <- cc ^+^ ((γ₁+γ₂)/2)*^c₂-           , rγ <- abs (γ₁ - γ₂) / 2-           , η <- if rγ * c₂eec₂ /= 0 && 1 - rγ^2 * c₂eec₂ > 0-                   then sqrt (1 - rγ^2 * c₂eec₂) / (rγ * c₂eec₂)-                   else 0-                  = return $-                 Shade' (c₀.+~^cc')-                        (Norm (arr ee) <> spanNorm [ee $ c₂^*η])-           | otherwise          = empty-   where σe = arr $ e₁^+^e₂-         quadraticEqnSol a b c-             | a /= 0 && disc > 0  = [ (σ * sqrt disc - b) / (2*a)-                                     | σ <- [-1, 1] ]-             | otherwise           = [0]-          where disc = b^2 - 4*a*c-         middle (_:x:y:_) = [x,y]-         middle l = 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>>-  convolveShade' :: Shade' y -> Shade' (Needle y) -> Shade' y-  convolveShade' (Shade' y₀ ey) (Shade' δ₀ eδ)-          = Shade' (y₀.+~^δ₀)-                   ( spanNorm [ f ^* ζ crl-                              | (f,_) <- eδsp-                              | crl <- corelap ] )-   where eδsp = sharedNormSpanningSystem ey eδ-         corelap = map snd eδsp-         ζ = case filter (>0) corelap of-            [] -> const 0-            nzrelap-               -> let cre₁ = 1/minimum nzrelap-                      cre₂ =  maximum nzrelap-                      edgeFactor = sqrt ( (1 + cre₁)^2 + (1 + cre₂)^2 )-                                / (sqrt (1 + cre₁^2) + sqrt (1 + cre₂^2))-                  in \case-                        0  -> 0-                        sq -> edgeFactor / (recip sq + 1)-  --instance Refinable ℝ where-  refineShade' (Shade' cl el) (Shade' cr er)-         = case (normSq el 1, normSq er 1) of-             (0, _) -> return $ Shade' cr er-             (_, 0) -> return $ Shade' cl el-             (ql,qr) | ql>0, qr>0-                    -> let [rl,rr] = sqrt . recip <$> [ql,qr]-                           b = maximum $ zipWith (-) [cl,cr] [rl,rr]-                           t = minimum $ zipWith (+) [cl,cr] [rl,rr]-                       in guard (b<t) >>-                           let cm = (b+t)/2-                               rm = (t-b)/2-                           in return $ Shade' cm (spanNorm [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 (Refinable a, Refinable b) => Refinable (a,b)-  -instance Refinable ℝ⁰-instance Refinable ℝ¹-instance Refinable ℝ²-instance Refinable ℝ³-instance Refinable ℝ⁴-                            --intersectShade's :: ∀ y . Refinable y => NonEmpty (Shade' y) -> Option (Shade' y)-intersectShade's (sh:|shs) = Hask.foldrM refineShade' sh shs-----type DifferentialEqn x y = Shade (x,y) -> Shade' (LocalLinear x y)---propagateDEqnSolution_loc :: ∀ x y . ( WithField ℝ Manifold x, Refinable y-                                     , SimpleSpace (Needle x) )-           => DifferentialEqn x y -> ((x, Shade' y), NonEmpty (Needle x, Shade' y))-                   -> NonEmpty (Shade' y)-propagateDEqnSolution_loc f ((x, shy@(Shade' y _)), neighbours) = ycs- where jShade@(Shade' j₀ jExpa) = f shxy-       [shxy] = pointsCovers [ (xs, ys')-                             | (xs, Shade' ys yse)-                                 <- (x,shy):(first (x.+~^)<$>NE.toList neighbours)-                             , δy <- normSpanningSystem' yse-                             , ys' <- [ys.+~^δy, ys.-~^δy] ]-       [Shade' _ expax] = pointsCover's $ x : ((x.+~^).fst<$>NE.toList neighbours)-       marginδs :: NonEmpty (Needle x, (Needle y, Metric y))-       marginδs = [ (δxm, (δym, expany))-                  | (δxm, Shade' yn expany) <- neighbours-                  , let (Option (Just δym)) = yn.-~.y-                  ]-       back2Centre :: (Needle x, (Needle y, Metric y)) -> Shade' y-       back2Centre (δx, (δym, expany))-            = convolveShade'-                (Shade' y expany)-                (Shade' δyb $ applyLinMapNorm jExpa (δx'^/(δx'<.>^δx)))-        where δyb = δym ^-^ (j₀ $ δx)-              δx' = expax<$|δx-       ycs :: NonEmpty (Shade' y)-       ycs = back2Centre <$> marginδs-       xSpan = normSpanningSystem expax--applyLinMapNorm :: (LSpace x, LSpace y, Scalar x ~ Scalar y)-           => Norm (x+>y) -> DualVector x -> Norm y-applyLinMapNorm n dx-   = transformNorm (fmap (arr Coercion . transposeTensor) . blockVectSpan' $ dx) n---type Twig x = (Int, ShadeTree x)-type TwigEnviron x = [Twig x]---- Formerly, 'twigsWithEnvirons' what has now become 'traverseTwigsWithEnvirons'.--- The simple list-yielding version (see rev. b4a427d59ec82889bab2fde39225b14a57b694df)--- may well be more efficient than the current traversal-derived version.---- | Example: https://nbviewer.jupyter.org/github/leftaroundabout/manifolds/blob/master/test/Trees-and-Webs.ipynb#pseudorandomCloudTree--- ---   <<images/examples/TreesAndWebs/2D-scatter_twig-environs.png>>-twigsWithEnvirons :: ∀ x. (WithField ℝ Manifold x, SimpleSpace (Needle x))-    => ShadeTree x -> [(Twig x, TwigEnviron x)]-twigsWithEnvirons = execWriter . traverseTwigsWithEnvirons (writer . (snd.fst&&&pure))--traverseTwigsWithEnvirons :: ∀ x f .-            (WithField ℝ Manifold x, SimpleSpace (Needle x), Hask.Applicative f)-    => ( (Twig x, TwigEnviron x) -> f (ShadeTree x) ) -> ShadeTree x -> f (ShadeTree x)-traverseTwigsWithEnvirons f = fst . go [] . (0,)- where go :: TwigEnviron x -> Twig x -> (f (ShadeTree x), Bool)-       go _ (i₀, DisjointBranches nlvs djbs) = ( fmap (DisjointBranches nlvs)-                                                   . Hask.traverse (fst . go [])-                                                   $ NE.zip ioffs djbs-                                               , False )-        where ioffs = NE.scanl (\i -> (+i) . nLeaves) i₀ djbs-       go envi ct@(i₀, (OverlappingBranches nlvs rob@(Shade robc _) brs))-                = ( case descentResult of-                     OuterNothing -> f-                         $ purgeRemotes-                            (ct, Hask.foldMap (\(io,te)-                                            -> first (+io) <$> twigProximæ robc te) envi)-                     OuterJust dR -> fmap (OverlappingBranches nlvs rob . NE.fromList) dR-                  , False )-        where descentResult = traverseDirectionChoices tdc $ NE.toList brs-              tdc (io, (vy, ty)) alts = case go envi'' (i₀+io, ty) of-                                   (_, True) -> OuterNothing-                                   (down, _) -> OuterJust down-               where envi'' = filter (snd >>> trunks >>> \(Shade ce _:_)-                                         -> let Option (Just δyenv) = ce.-~.robc-                                                qq = vy<.>^δyenv-                                            in qq > -1-                                       ) envi'-                              ++ map ((+i₀)***snd) alts-              envi' = approach =<< envi-              approach (i₀e, apt@(OverlappingBranches _ (Shade envc _) _))-                  = first (+i₀e) <$> twigsaveTrim hither apt-               where Option (Just δxenv) = robc .-~. envc-                     hither (DBranch bdir (Hourglass bdc₁ bdc₂))-                       =  [(0           , bdc₁) | overlap > -1]-                       ++ [(nLeaves bdc₁, bdc₂) | overlap < 1]-                      where overlap = bdir<.>^δxenv-              approach q = [q]-       go envi plvs@(i₀, (PlainLeaves _))-                         = (f $ purgeRemotes (plvs, envi), True)-       -       twigProximæ :: x -> ShadeTree x -> TwigEnviron x-       twigProximæ x₀ (DisjointBranches _ djbs)-               = Hask.foldMap (\(i₀,st) -> first (+i₀) <$> twigProximæ x₀ st)-                    $ NE.zip ioffs djbs-        where ioffs = NE.scanl (\i -> (+i) . nLeaves) 0 djbs-       twigProximæ x₀ ct@(OverlappingBranches _ (Shade xb qb) brs)-                   = twigsaveTrim hither ct-        where Option (Just δxb) = x₀ .-~. xb-              hither (DBranch bdir (Hourglass bdc₁ bdc₂))-                =  ((guard (overlap > -1)) >> twigProximæ x₀ bdc₁)-                ++ ((guard (overlap < 1)) >> first (+nLeaves bdc₁)<$>twigProximæ x₀ bdc₂)-               where overlap = bdir<.>^δxb-       twigProximæ _ plainLeaves = [(0, plainLeaves)]-       -       twigsaveTrim :: (DBranch x -> TwigEnviron x) -> ShadeTree x -> TwigEnviron x-       twigsaveTrim f ct@(OverlappingBranches _ _ dbs)-                 = case Hask.mapM (\(i₀,dbr) -> noLeaf $ first(+i₀)<$>f dbr)-                                 $ NE.zip ioffs dbs of-                      Just pqe -> Hask.fold pqe-                      _        -> [(0,ct)]-        where noLeaf [(_,PlainLeaves _)] = empty-              noLeaf bqs = pure bqs-              ioffs = NE.scanl (\i -> (+i) . sum . fmap nLeaves . toList) 0 dbs-       -       purgeRemotes :: (Twig x, TwigEnviron x) -> (Twig x, TwigEnviron x)-       purgeRemotes = id -- See 7d1f3a4 for the implementation; this didn't work reliable. -    -completeTopShading :: ( WithField ℝ Manifold x, WithField ℝ Manifold y-                      , SimpleSpace (Needle x), SimpleSpace (Needle y) )-                   => x`Shaded`y -> [Shade' (x,y)]-completeTopShading (PlainLeaves plvs)-                     = pointsShade's $ (_topological &&& _untopological) <$> plvs-completeTopShading (DisjointBranches _ bqs)-                     = take 1 . completeTopShading =<< NE.toList bqs-completeTopShading t = pointsCover's . map (_topological &&& _untopological) $ onlyLeaves t---transferAsNormsDo :: LSpace v => Norm v -> Variance v -> v-+>v-transferAsNormsDo (Norm m) (Norm n) = n . m--flexTopShading :: ∀ x y f . ( WithField ℝ Manifold x, WithField ℝ Manifold y-                            , SimpleSpace (Needle x), SimpleSpace (Needle y)-                            , Applicative f (->) (->) )-                  => (Shade' (x,y) -> f (x, (Shade' y, LocalLinear x y)))-                      -> x`Shaded`y -> f (x`Shaded`y)-flexTopShading f tr = seq (assert_onlyToplevDisjoint tr)-                    $ recst (completeTopShading tr) tr- where recst qsh@(_:_) (DisjointBranches n bqs)-          = undefined -- DisjointBranches n $ NE.zipWith (recst . (:[])) (NE.fromList qsh) bqs-       recst [sha@(Shade' (_,yc₀) expa₀)] t = fmap fts $ f sha-        where expa'₀ = dualNorm expa₀-              j₀ :: LocalLinear x y-              j₀ = dependence expa'₀-              (_,expay₀) = summandSpaceNorms expa₀-              fts (xc, (Shade' yc expay, jtg)) = unsafeFmapLeaves applδj t-               where Option (Just δyc) = yc.-~.yc₀-                     tfm = transferAsNormsDo expay₀ (dualNorm expay)-                     applδj (WithAny y x)-                           = WithAny (yc₀ .+~^ ((tfm$δy) ^+^ (jtg$δx) ^+^ δyc)) x-                      where Option (Just δx) = x.-~.xc-                            Option (Just δy) = y.-~.(yc₀.+~^(j₀$δx))-       -       assert_onlyToplevDisjoint, assert_connected :: x`Shaded`y -> ()-       assert_onlyToplevDisjoint (DisjointBranches _ dp) = rnf (assert_connected<$>dp)-       assert_onlyToplevDisjoint t = assert_connected t-       assert_connected (OverlappingBranches _ _ dp)-           = rnf (Hask.foldMap assert_connected<$>dp)-       assert_connected (PlainLeaves _) = ()--flexTwigsShading :: ∀ x y f . ( WithField ℝ Manifold x, WithField ℝ Manifold y-                              , SimpleSpace (Needle x), SimpleSpace (Needle y)-                              , Hask.Applicative f )-                  => (Shade' (x,y) -> f (x, (Shade' y, LocalLinear x y)))-                      -> x`Shaded`y -> f (x`Shaded`y)-flexTwigsShading f = traverseTwigsWithEnvirons locFlex- where locFlex :: ∀ μ . ((Int, x`Shaded`y), μ) -> f (x`Shaded`y)-       locFlex ((_,lsh), _) = flexTopShading f lsh-                ---------- simplexFaces :: forall n x . Simplex (S n) x -> Triangulation n x--- simplexFaces (Simplex p (ZeroSimplex q))    = TriangVertices $ Arr.fromList [p, q]--- simplexFaces splx = carpent splx $ TriangVertices ps---  where ps = Arr.fromList $ p : splxVertices qs---        where carpent (ZeroSimplex (Simplex p qs@(Simplex _ _))---      | Triangulation es <- simplexFaces qs  = TriangSkeleton $ Simplex p <$> es-----newtype BaryCoords n = BaryCoords { getBaryCoordsTail :: FreeVect n ℝ }--instance (KnownNat n) => AffineSpace (BaryCoords n) where-  type Diff (BaryCoords n) = FreeVect n ℝ-  BaryCoords v .-. BaryCoords w = v ^-^ w-  BaryCoords v .+^ w = BaryCoords $ v ^+^ w-instance (KnownNat n) => Semimanifold (BaryCoords n) where-  type Needle (BaryCoords n) = FreeVect n ℝ-  fromInterior = id-  toInterior = pure-  translateP = Tagged (.+~^)-  (.+~^) = (.+^)-  semimanifoldWitness = undefined-instance (KnownNat n) => PseudoAffine (BaryCoords n) where-  (.-~.) = pure .: (.-.)--getBaryCoords :: BaryCoords n -> ℝ ^ S n-getBaryCoords (BaryCoords (FreeVect bcs)) = FreeVect $ (1 - Arr.sum bcs) `Arr.cons` bcs-  -getBaryCoords' :: BaryCoords n -> [ℝ]-getBaryCoords' (BaryCoords (FreeVect bcs)) = 1 - Arr.sum bcs : Arr.toList bcs--getBaryCoord :: BaryCoords n -> Int -> ℝ-getBaryCoord (BaryCoords (FreeVect bcs)) 0 = 1 - Arr.sum bcs-getBaryCoord (BaryCoords (FreeVect bcs)) i = case bcs Arr.!? i of-    Just a -> a-    _      -> 0--mkBaryCoords :: KnownNat n => ℝ ^ S n -> BaryCoords n-mkBaryCoords (FreeVect bcs) = BaryCoords $ FreeVect (Arr.tail bcs) ^/ Arr.sum bcs--mkBaryCoords' :: KnownNat n => [ℝ] -> Option (BaryCoords n)-mkBaryCoords' bcs = fmap (BaryCoords . (^/sum bcs)) . freeVector . Arr.fromList $ tail bcs--newtype ISimplex n x = ISimplex { iSimplexBCCordEmbed :: Embedding (->) (BaryCoords n) x }-----data TriangBuilder n x where-  TriangVerticesSt :: [x] -> TriangBuilder Z x-  TriangBuilder :: Triangulation (S n) x-                    -> [x]-                    -> [(Simplex n x, [x] -> Option x)]-                            -> TriangBuilder (S n) x----              -bottomExtendSuitability :: (KnownNat n, WithField ℝ Manifold x)-                => ISimplex (S n) x -> x -> ℝ-bottomExtendSuitability (ISimplex emb) x = case getBaryCoord (emb >-$ x) 0 of-     0 -> 0-     r -> - recip r--optimalBottomExtension :: (KnownNat n, WithField ℝ Manifold x)-                => ISimplex (S n) x -> [x] -> Option Int-optimalBottomExtension s xs-      = case filter ((>0).snd)-               $ zipWith ((. bottomExtendSuitability s) . (,)) [0..] xs of-             [] -> empty-             qs -> pure . fst . maximumBy (comparing snd) $ qs----leavesBarycenter :: WithField ℝ Manifold x => NonEmpty x -> x-leavesBarycenter (x :| xs) = x .+~^ sumV [x'–x | x'<-xs] ^/ (n+1)- where n = fromIntegral $ length xs-       x' – x = case x'.-~.x of {Option(Just v)->v}---- simplexShade :: forall x n . (KnownNat n, WithField ℝ Manifold x)-simplexBarycenter :: forall x n . (KnownNat n, WithField ℝ Manifold x) => Simplex n x -> x-simplexBarycenter = bc - where bc (ZS x) = x-       bc (x :<| xs') = x .+~^ sumV [x'–x | x'<-splxVertices xs'] ^/ (n+1)-       -       Tagged n = theNatN :: Tagged n ℝ-       x' – x = case x'.-~.x of {Option(Just v)->v}---fromISimplex :: forall x n . (KnownNat n, WithField ℝ Manifold x)-                   => ISimplex n x -> Simplex n x-fromISimplex (ISimplex emb) = s- where (Option (Just s))-          = makeSimplex' [ emb $-> jOnly-                         | j <- [0..n]-                         , let (Option (Just jOnly)) = mkBaryCoords' [ if k==j then 1 else 0-                                                                     | k<-[0..n] ]-                         ]-       (Tagged n) = theNatN :: Tagged n Int--iSimplexSideViews :: ∀ n x . KnownNat n => ISimplex n x -> [ISimplex n x]-iSimplexSideViews = \(ISimplex is)-              -> take (n+1) $ [ISimplex $ rot j is | j<-[0..] ]- where rot j (Embedding emb proj)-            = Embedding ( emb . mkBaryCoords . freeRotate j     . getBaryCoords        )-                        (       mkBaryCoords . freeRotate (n-j) . getBaryCoords . proj )-       (Tagged n) = theNatN :: Tagged n Int---type FullTriang t n x = TriangT t n x-          (State (Map.Map (SimplexIT t n x) (ISimplex n x)))--type TriangBuild t n x = TriangT t (S n) x-          ( State (Map.Map (SimplexIT t n x) (Metric x, ISimplex (S n) x) ))--doTriangBuild :: KnownNat n => (∀ t . TriangBuild t n x ()) -> [Simplex (S n) x]-doTriangBuild t = runIdentity (fst <$>-  doTriangT (unliftInTriangT (`evalStateT`mempty) t >> simplexITList >>= mapM lookSimplex))----hypotheticalSimplexScore :: ∀ t n n' x . (KnownNat n', WithField ℝ Manifold x, n~S n')-          => SimplexIT t Z x-           -> SimplexIT t n x-           -> TriangBuild t n x ( Option Double )-hypotheticalSimplexScore p b = do-   altViews :: [(SimplexIT t Z x, SimplexIT t n x)] <- do-      pSups <- lookSupersimplicesIT p-      nOpts <- forM pSups $ \psup -> fmap (fmap $ \((bq,_p), _b') -> (bq,psup))-                      $ distinctSimplices b psup-      return $ catOptions nOpts-   scores <- forM ((p,b) :| altViews) $ \(p',b') -> do-      x <- lookVertexIT p'-      q <- lift $ Map.lookup b' <$> get-      return $ case q of-         Just(_,is) | s<-bottomExtendSuitability is x, s>0-                 -> pure s-         _       -> empty-   return . fmap sum $ Hask.sequence scores------data AutoTriang n x where-  AutoTriang :: { getAutoTriang :: ∀ t . TriangBuild t n x () } -> AutoTriang (S n) x----breakdownAutoTriang :: ∀ n n' x . (KnownNat n', n ~ S n') => AutoTriang n x -> [Simplex n x]-breakdownAutoTriang (AutoTriang t) = doTriangBuild t-         -                    ---  where tr :: Triangulation n x---        outfc :: Map.Map (SimplexIT t n' x) (Metric x, ISimplex n x)---        (((), tr), outfc) = runState (doTriangT tb') mempty---        tb' :: ∀ t' . TriangT t' n x ---                         ( State ( Map.Map (SimplexIT t' n' x)---                              (Metric x, ISimplex n x) ) ) ()---        tb' = tb-   -   -   -       ---- primitiveTriangulation :: forall x n . (KnownNat n,WithField ℝ Manifold x)---                              => [x] -> Triangulation n x--- primitiveTriangulation xs = head $ build <$> buildOpts---  where build :: ([x], [x]) -> Triangulation n x---        build (mainVerts, sideVerts) = Triangulation [mainSplx]---         where (Option (Just mainSplx)) = makeSimplex mainVerts--- --              mainFaces = Map.fromAscList . zip [0..] . getTriangulation--- --                                 $ simplexFaces mainSplx---        buildOpts = partitionsOfFstLength n xs---        (Tagged n) = theNatN :: Tagged n Int- -partitionsOfFstLength :: Int -> [a] -> [([a],[a])]-partitionsOfFstLength 0 l = [([],l)]-partitionsOfFstLength n [] = []-partitionsOfFstLength n (x:xs) = ( first (x:) <$> partitionsOfFstLength (n-1) xs )-                              ++ ( second (x:) <$> partitionsOfFstLength n xs )--splxVertices :: Simplex n x -> [x]-splxVertices (ZS x) = [x]-splxVertices (x :<| s') = x : splxVertices s'---------- |--- @--- 'SimpleTree' x &#x2245; Maybe (x, 'Trees' x)--- @-type SimpleTree = GenericTree Maybe []--- |--- @--- 'Trees' x &#x2245; [(x, 'Trees' x)]--- @-type Trees = GenericTree [] []--- |--- @--- 'NonEmptyTree' x &#x2245; (x, 'Trees' x)--- @-type NonEmptyTree = GenericTree NonEmpty []-    -newtype GenericTree c b x = GenericTree { treeBranches :: c (x,GenericTree b b x) }- deriving (Generic, Hask.Functor, Hask.Foldable, Hask.Traversable)-instance (NFData x, Hask.Foldable c, Hask.Foldable b) => NFData (GenericTree c b x) where-  rnf (GenericTree t) = rnf $ toList t-instance (Hask.MonadPlus c) => Semigroup (GenericTree c b x) where-  GenericTree b1 <> GenericTree b2 = GenericTree $ Hask.mplus b1 b2-instance (Hask.MonadPlus c) => Monoid (GenericTree c b x) where-  mempty = GenericTree Hask.mzero-  mappend = (<>)-deriving instance Show (c (x, GenericTree b b x)) => Show (GenericTree c b x)---- | Imitate the specialised 'ShadeTree' structure with a simpler, generic tree.-onlyNodes :: (WithField ℝ Manifold x, SimpleSpace (Needle x)) => ShadeTree x -> Trees x-onlyNodes (PlainLeaves []) = GenericTree []-onlyNodes (PlainLeaves ps) = let (ctr,_) = pseudoECM $ NE.fromList ps-                             in GenericTree [ (ctr, GenericTree $ (,mempty) <$> ps) ]-onlyNodes (DisjointBranches _ brs) = Hask.foldMap onlyNodes brs-onlyNodes (OverlappingBranches _ (Shade ctr _) brs)-              = GenericTree [ (ctr, Hask.foldMap (Hask.foldMap onlyNodes) brs) ]----- | Left (and, typically, also right) inverse of 'fromLeafNodes'.-onlyLeaves :: WithField ℝ Manifold x => ShadeTree x -> [x]-onlyLeaves tree = dismantle tree []- where dismantle (PlainLeaves xs) = (xs++)-       dismantle (OverlappingBranches _ _ brs)-              = foldr ((.) . dismantle) id $ Hask.foldMap (Hask.toList) brs-       dismantle (DisjointBranches _ brs) = foldr ((.) . dismantle) id $ NE.toList brs---------data Sawbones x = Sawbones { sawnTrunk1, sawnTrunk2 :: [x]->[x]-                           , sawdust1,   sawdust2   :: [x]      }-instance Semigroup (Sawbones x) where-  Sawbones st11 st12 sd11 sd12 <> Sawbones st21 st22 sd21 sd22-     = Sawbones (st11.st21) (st12.st22) (sd11<>sd21) (sd12<>sd22)-instance Monoid (Sawbones x) where-  mempty = Sawbones id id [] []-  mappend = (<>)---chainsaw :: (WithField ℝ Manifold x, SimpleSpace (Needle x))-               => Cutplane x -> ShadeTree x -> Sawbones x-chainsaw cpln (PlainLeaves xs) = Sawbones (sd1++) (sd2++) sd2 sd1- where (sd1,sd2) = partition (\x -> sideOfCut cpln x == Option(Just PositiveHalfSphere)) xs-chainsaw cpln (DisjointBranches _ brs) = Hask.foldMap (chainsaw cpln) brs-chainsaw cpln (OverlappingBranches _ (Shade _ bexpa) brs) = Sawbones t1 t2 d1 d2- where (Sawbones t1 t2 subD1 subD2)-             = Hask.foldMap (Hask.foldMap (chainsaw cpln) . boughContents) brs-       [d1,d2] = map (foldl' go [] . foci) [subD1, subD2]-        where go d' (dp,dqs) = case fathomCD dp of-                 Option (Just dpCD) | not $ any (shelter dpCD) dqs-                    -> dp:d' -- dp is close enough to cut plane to make dust.-                 _  -> d'    -- some dq is actually closer than the cut plane => discard dp.-               where shelter dpCutDist dq = case ptsDist dp dq of-                        Option (Just d) -> d < abs dpCutDist-                        _               -> False-                     ptsDist = fmap (dualNorm bexpa|$|) .: (.-~.)-       fathomCD = fathomCutDistance cpln bexpa-       --type DList x = [x]->[x]-    -data DustyEdges x = DustyEdges { sawChunk :: DList x, chunkDust :: DBranches' x [x] }-instance Semigroup (DustyEdges x) where-  DustyEdges c1 d1 <> DustyEdges c2 d2 = DustyEdges (c1.c2) (d1<>d2)--data Sawboneses x = SingleCut (Sawbones x)-                  | Sawboneses (DBranches' x (DustyEdges x))-    deriving (Generic)-instance Semigroup (Sawboneses x) where-  SingleCut c <> SingleCut d = SingleCut $ c<>d-  Sawboneses c <> Sawboneses d = Sawboneses $ c<>d------ | Saw a tree into the domains covered by the respective branches of another tree.-sShSaw :: (WithField ℝ Manifold x, SimpleSpace (Needle x))-          => ShadeTree x   -- ^ &#x201c;Reference tree&#x201d;, defines the cut regions.-                           --   Must be at least one level of 'OverlappingBranches' deep.-          -> ShadeTree x   -- ^ Tree to take the actual contents from.-          -> Sawboneses x  -- ^ All points within each region, plus those from the-                           --   boundaries of each neighbouring region.-sShSaw (OverlappingBranches _ (Shade sh _) (DBranch dir _ :| [])) src-          = SingleCut $ chainsaw (Cutplane sh $ stiefel1Project dir) src-sShSaw (OverlappingBranches _ (Shade cctr _) cbrs) (PlainLeaves xs)-          = Sawboneses . DBranches $ NE.fromList ngbsAdded- where brsEmpty = fmap (\(DBranch dir _)-> DBranch dir mempty) cbrs-       srcDistrib = sShIdPartition' cctr xs brsEmpty-       ngbsAdded = fmap (\(DBranch dir (Hourglass u l), othrs)-                             -> let [allOthr,allOthr']-                                        = map (DBranches . NE.fromList)-                                            [othrs, fmap (\(DBranch d' o)-                                                          ->DBranch(negateV d') o) othrs]-                                in DBranch dir $ Hourglass (DustyEdges (u++) allOthr)-                                                           (DustyEdges (l++) allOthr')-                        ) $ foci (NE.toList srcDistrib)-sShSaw cuts@(OverlappingBranches _ (Shade sh _) cbrs)-        (OverlappingBranches _ (Shade _ bexpa) brs)-          = Sawboneses . DBranches $ ftr'd- where Option (Just (Sawboneses (DBranches recursed)))-             = Hask.foldMap (Hask.foldMap (pure . sShSaw cuts) . boughContents) brs-       ftr'd = fmap (\(DBranch dir1 ds) -> DBranch dir1 $ fmap (-                         \(DustyEdges bk (DBranches dds))-                                -> DustyEdges bk . DBranches $ fmap (obsFilter dir1) dds-                                                               ) ds ) recursed-       obsFilter dir1 (DBranch dir2 (Hourglass pd2 md2))-                         = DBranch dir2 $ Hourglass pd2' md2'-        where cpln cpSgn = Cutplane sh . stiefel1Project $ dir1 ^+^ cpSgn*^dir2-              [pd2', md2'] = zipWith (occl . cpln) [-1, 1] [pd2, md2] -              occl cpl = foldl' go [] . foci-               where go d' (dp,dqs) = case fathomCD dp of-                           Option (Just dpCD) | not $ any (shelter dpCD) dqs-                                     -> dp:d'-                           _         -> d'-                      where shelter dpCutDist dq = case ptsDist dp dq of-                             Option (Just d) -> d < abs dpCutDist-                             _               -> False-                            ptsDist = fmap (dualNorm bexpa|$|) .: (.-~.)-                     fathomCD = fathomCutDistance cpl bexpa-sShSaw _ _ = error "`sShSaw` is not supposed to cut anything else but `OverlappingBranches`"------ | 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 { _untopological :: y-                , _topological :: !x  }- deriving (Hask.Functor, Show, 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-  type Interior (WithAny x y) = Interior x `WithAny` y-  WithAny y x .+~^ δx = WithAny y $ x.+~^δx-  fromInterior (WithAny y x) = WithAny y $ fromInterior x-  toInterior (WithAny y x) = fmap (WithAny y) $ toInterior x-  translateP = tpWD-   where tpWD :: ∀ x y . Semimanifold x => Tagged (WithAny x y)-                            (Interior x`WithAny`y -> Needle x -> Interior x`WithAny`y)-         tpWD = Tagged `id` \(WithAny y x) δx -> WithAny y $ tpx x δx-          where Tagged tpx = translateP :: Tagged x (Interior x -> Needle x -> Interior x)-  semimanifoldWitness = case semimanifoldWitness :: SemimanifoldWitness x of-                          SemimanifoldWitness -> SemimanifoldWitness-            -instance (PseudoAffine x) => PseudoAffine (x`WithAny`y) where-  WithAny _ x .-~. WithAny _ ξ = x.-~.ξ--instance (AffineSpace x) => AffineSpace (x`WithAny`y) where-  type Diff (WithAny x y) = Diff x-  WithAny _ x .-. WithAny _ ξ = x.-.ξ-  WithAny y x .+^ δx = WithAny y $ x.+^δx --instance (VectorSpace x, Monoid y) => VectorSpace (x`WithAny`y) where-  type Scalar (WithAny x y) = Scalar x-  μ *^ WithAny y x = WithAny y $ μ*^x --instance (AdditiveGroup x, Monoid y) => AdditiveGroup (x`WithAny`y) where-  zeroV = WithAny mempty zeroV-  negateV (WithAny y x) = WithAny y $ negateV x-  WithAny y x ^+^ WithAny υ ξ = WithAny (mappend y υ) (x^+^ξ)--instance (AdditiveGroup x) => Hask.Applicative (WithAny x) where-  pure x = WithAny x zeroV-  WithAny f x <*> WithAny t ξ = WithAny (f t) (x^+^ξ)-  -instance (AdditiveGroup x) => Hask.Monad (WithAny x) where-  return x = WithAny x zeroV-  WithAny y x >>= f = WithAny r $ x^+^q-   where WithAny r q = f y--shadeWithAny :: y -> Shade x -> Shade (x`WithAny`y)-shadeWithAny y (Shade x xe) = Shade (WithAny y x) xe--shadeWithoutAnything :: Shade (x`WithAny`y) -> Shade x-shadeWithoutAnything (Shade (WithAny _ b) e) = Shade b e--constShaded :: y -> ShadeTree x -> x`Shaded`y-constShaded y = unsafeFmapTree (WithAny y<$>) id (shadeWithAny y)--stripShadedUntopological :: x`Shaded`y -> ShadeTree x-stripShadedUntopological = unsafeFmapTree (fmap _topological) id shadeWithoutAnything--fmapShaded :: (y -> υ) -> (x`Shaded`y) -> (x`Shaded`υ)-fmapShaded f = unsafeFmapTree (fmap $ \(WithAny y x) -> WithAny (f y) x)-                              id-                              (\(Shade yx shx) -> Shade (fmap f yx) shx)---- | This is to 'ShadeTree' as 'Data.Map.Map' is to 'Data.Set.Set'.-type x`Shaded`y = ShadeTree (x`WithAny`y)--stiWithDensity :: ( WithField ℝ Manifold x, WithField ℝ LinearManifold y-                  , SimpleSpace (Needle x) )-         => x`Shaded`y -> x -> Cℝay y-stiWithDensity (PlainLeaves lvs)-  | [locShape@(Shade baryc expa)] <- pointsShades $ _topological <$> lvs-       = let nlvs = fromIntegral $ length lvs :: ℝ-             indiShapes = [(Shade p expa, y) | WithAny y p <- lvs]-         in \x -> let lcCoeffs = [ occlusion psh x | (psh, _) <- indiShapes ]-                      dens = sum lcCoeffs-                  in mkCone dens . linearCombo . zip (snd<$>indiShapes)-                       $ (/dens)<$>lcCoeffs-stiWithDensity (DisjointBranches _ lvs)-           = \x -> foldr1 qGather $ (`stiWithDensity`x)<$>lvs- where qGather (Cℝay 0 _) o = o-       qGather o _ = o-stiWithDensity (OverlappingBranches n (Shade (WithAny _ bc) extend) brs) = ovbSWD- where ovbSWD x = case x .-~. bc of-           Option (Just v)-             | dist² <- normSq ε v-             , dist² < 9-             , att <- exp(1/(dist²-9)+1/9)-               -> qGather att $ fmap ($x) downPrepared-           _ -> coneTip-       ε = dualNorm extend-       downPrepared = dp =<< brs-        where dp (DBranch _ (Hourglass up dn))-                 = fmap stiWithDensity $ up:|[dn]-       qGather att contribs = mkCone (att*dens)-                 $ linearCombo [(v, d/dens) | Cℝay d v <- NE.toList contribs]-        where dens = sum (hParamCℝay <$> contribs)--stiAsIntervalMapping :: (x ~ ℝ, y ~ ℝ)-            => x`Shaded`y -> [(x, ((y, Diff y), LinearMap ℝ x y))]-stiAsIntervalMapping = twigsWithEnvirons >=> pure.snd.fst >=> completeTopShading >=> pure.-             \(Shade' (xloc, yloc) shd)-                 -> ( xloc, ( (yloc, recip $ shd|$|(0,1))-                            , dependence (dualNorm shd) ) )--smoothInterpolate :: ( WithField ℝ Manifold x, WithField ℝ LinearManifold y-                     , SimpleSpace (Needle x) )-             => NonEmpty (x,y) -> x -> y-smoothInterpolate l = \x ->-             case ltr x of-               Cℝay 0 _ -> defy-               Cℝay _ y -> y- where defy = linearCombo [(y, 1/n) | WithAny y _ <- l']-       n = fromIntegral $ length l'-       l' = (uncurry WithAny . swap) <$> NE.toList l-       ltr = stiWithDensity $ fromLeafPoints l'---spanShading :: ∀ x y . ( WithField ℝ Manifold x, WithField ℝ Manifold y-                       , SimpleSpace (Needle x), SimpleSpace (Needle y) )-          => (Shade x -> Shade y) -> ShadeTree x -> x`Shaded`y-spanShading f = unsafeFmapTree addYs id addYSh- where addYs :: NonEmpty x -> NonEmpty (x`WithAny`y)-       addYs l = foldr (NE.<|) (fmap ( WithAny ymid) l     )-                               (fmap (`WithAny`xmid) yexamp)-          where [xsh@(Shade xmid _)] = pointsCovers $ toList l-                Shade ymid yexpa = f xsh-                yexamp = [ ymid .+~^ σ*^δy-                         | δy <- normSpanningSystem yexpa, σ <- [-1,1] ]-       addYSh :: Shade x -> Shade (x`WithAny`y)-       addYSh xsh = shadeWithAny (_shadeCtr $ f xsh) xsh-                      ---coneTip :: (AdditiveGroup v) => Cℝay v-coneTip = Cℝay 0 zeroV--mkCone :: AdditiveGroup v => ℝ -> v -> Cℝay v-mkCone 0 _ = coneTip-mkCone h v = Cℝay h v---foci :: [a] -> [(a,[a])]-foci [] = []-foci (x:xs) = (x,xs) : fmap (second (x:)) (foci xs)-       -fociNE :: NonEmpty a -> NonEmpty (a,[a])-fociNE (x:|xs) = (x,xs) :| fmap (second (x:)) (foci xs)-       --(.:) :: (c->d) -> (a->b->c) -> a->b->d -(.:) = (.) . (.)---catOptions :: [Option a] -> [a]-catOptions = catMaybes . map getOption+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE LiberalTypeSynonyms        #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE TemplateHaskell            #-}+++module Data.Manifold.TreeCover (+       -- * Shades +         Shade(..), pattern(:±), Shade'(..), (|±|), IsShade+       -- ** Lenses+       , shadeCtr, shadeExpanse, shadeNarrowness+       -- ** Construction+       , fullShade, fullShade', pointsShades, pointsShade's+       , pointsCovers, pointsCover's, coverAllAround+       -- ** Evaluation+       , occlusion+       -- ** Misc+       , factoriseShade, intersectShade's, linIsoTransformShade+       , Refinable, subShade', refineShade', convolveShade', coerceShade+       , mixShade's+       -- * Shade trees+       , ShadeTree(..), fromLeafPoints, onlyLeaves, indexShadeTree, positionIndex+       -- * View helpers+       , onlyNodes+       -- ** Auxiliary types+       , SimpleTree, Trees, NonEmptyTree, GenericTree(..)+       -- * Misc+       , HasFlatView(..), shadesMerge, smoothInterpolate+       , allTwigs, twigsWithEnvirons, Twig, TwigEnviron, seekPotentialNeighbours+       , completeTopShading, flexTwigsShading, coerceShadeTree+       , WithAny(..), Shaded, fmapShaded, joinShaded+       , constShaded, zipTreeWithList, stripShadedUntopological+       , stiAsIntervalMapping, spanShading+       , estimateLocalJacobian+       , DifferentialEqn, LocalDifferentialEqn(..)+       , propagateDEqnSolution_loc, LocalDataPropPlan(..)+       , rangeOnGeodesic+       -- ** Triangulation-builders+       , TriangBuild, doTriangBuild+       , AutoTriang, breakdownAutoTriang+    ) where+++import Data.List hiding (filter, all, elem, sum, foldr1)+import Data.Maybe+import qualified Data.Map as Map+import qualified Data.Vector as Arr+import Data.List.NonEmpty (NonEmpty(..))+import Data.List.FastNub+import qualified Data.List.NonEmpty as NE+import Data.Semigroup+import Data.Ord (comparing)+import Control.DeepSeq++import Data.VectorSpace+import Data.AffineSpace+import Math.LinearMap.Category+import Data.Tagged++import Data.SimplicialComplex+import Data.Manifold.Types+import Data.Manifold.Types.Primitive ((^), empty)+import Data.Manifold.PseudoAffine+import Data.Manifold.Riemannian+    +import Data.Embedding+import Data.CoNat++import Control.Lens (Lens', (^.), (.~), (%~), (&), _2, swapped)+import Control.Lens.TH++import qualified Prelude as Hask hiding(foldl, sum, sequence)+import qualified Control.Applicative as Hask+import qualified Control.Monad       as Hask hiding(forM_, sequence)+import Data.Functor.Identity+import Control.Monad.Trans.State+import Control.Monad.Trans.Writer+import Control.Monad.Trans.OuterMaybe+import Control.Monad.Trans.Class+import qualified Data.Foldable       as Hask+import Data.Foldable (all, elem, toList, sum, foldr1)+import qualified Data.Traversable as Hask+import Data.Traversable (forM)++import Control.Category.Constrained.Prelude hiding+     ((^), all, elem, sum, forM, Foldable(..), foldr1, Traversable, traverse)+import Control.Arrow.Constrained+import Control.Monad.Constrained hiding (forM)+import Data.Foldable.Constrained+import Data.Traversable.Constrained (traverse)++import GHC.Generics (Generic)+import Data.Type.Coercion+++-- | Possibly / Partially / asymPtotically singular metric.+data PSM x = PSM {+       psmExpanse :: !(Metric' x)+     , relevantEigenspan :: ![Needle' x]+     }+       ++-- | 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 = Shade { _shadeCtr :: !(Interior x)+                     , _shadeExpanse :: !(Metric' x) }+deriving instance (Show (Interior 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'Ctr :: !(Interior x)+                       , _shade'Narrowness :: !(Metric x) }+deriving instance (Show (Interior x), Show (Metric x), WithField ℝ PseudoAffine x)+                => Show (Shade' x)++data LocalDifferentialEqn x y = LocalDifferentialEqn {+      _predictDerivatives :: Maybe (Shade' (LocalLinear x y))+    , _rescanDerivatives :: Shade' (LocalLinear x y) -> Shade' y -> Maybe (Shade' y)+    }+makeLenses ''LocalDifferentialEqn++type DifferentialEqn x y = Shade (x,y) -> LocalDifferentialEqn x y++data LocalDataPropPlan x y = LocalDataPropPlan+       { _sourcePosition :: !(Interior x)+       , _targetPosOffset :: !(Needle x)+       , _sourceData, _targetAPrioriData :: !y+       , _relatedData :: [(Needle x, y)]+       }+deriving instance (Show (Interior x), Show y, Show (Needle x)) => Show (LocalDataPropPlan x y)++makeLenses ''LocalDataPropPlan++type Depth = Int+data Wall x = Wall { _wallID :: (Depth,(Int,Int))+                   , _wallAnchor :: Interior x+                   , _wallNormal :: Needle' x+                   , _wallDistance :: Scalar (Needle x)+                   }+makeLenses ''Wall+++class IsShade shade where+--  type (*) shade :: *->*+  -- | Access the center of a 'Shade' or a 'Shade''.+  shadeCtr :: Lens' (shade x) (Interior 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)), RealDimension s )+                => shade x -> x -> s+  factoriseShade :: ( Manifold x, SimpleSpace (Needle x)+                    , Manifold 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) => shade x -> shade y+  linIsoTransformShade :: ( LinearManifold x, LinearManifold y+                          , SimpleSpace x, SimpleSpace y, Scalar x ~ Scalar y )+                          => (x+>y) -> shade x -> shade y++instance IsShade Shade where+  shadeCtr f (Shade c e) = fmap (`Shade`e) $ f c+  occlusion = occ pseudoAffineWitness dualSpaceWitness+   where occ :: ∀ x s . ( PseudoAffine x, SimpleSpace (Needle x)+                        , Scalar (Needle x) ~ s, RealDimension s )+                    => PseudoAffineWitness x -> DualNeedleWitness x -> Shade x -> x -> s+         occ (PseudoAffineWitness (SemimanifoldWitness _)) DualSpaceWitness (Shade p₀ δ)+                 = \p -> case toInterior p >>= (.-~.p₀) of+           (Just vd) | mSq <- normSq δinv vd+                     , mSq == mSq  -- avoid NaN+                     -> exp (negate mSq)+           _         -> zeroV+          where δinv = dualNorm δ+  factoriseShade = fs dualSpaceWitness dualSpaceWitness+   where fs :: ∀ x y . ( Manifold x, SimpleSpace (Needle x)+                       , Manifold y, SimpleSpace (Needle y)+                       , Scalar (Needle x) ~ Scalar (Needle y) )+               => DualNeedleWitness x -> DualNeedleWitness y+                       -> Shade (x,y) -> (Shade x, Shade y)+         fs DualSpaceWitness DualSpaceWitness (Shade (x₀,y₀) δxy)+                   = (Shade x₀ δx, Shade y₀ δy)+          where (δx,δy) = summandSpaceNorms δxy+  coerceShade = cS dualSpaceWitness dualSpaceWitness+   where cS :: ∀ x y . (LocallyCoercible x y)+                => DualNeedleWitness x -> DualNeedleWitness y -> Shade x -> Shade y+         cS DualSpaceWitness DualSpaceWitness+                    = \(Shade x δxym) -> Shade (internCoerce x) (tN δxym)+          where tN = case oppositeLocalCoercion :: CanonicalDiffeomorphism y x of+                      CanonicalDiffeomorphism ->+                       transformNorm . arr $ coerceNeedle' ([]::[(y,x)])+                internCoerce = case interiorLocalCoercion ([]::[(x,y)]) of+                      CanonicalDiffeomorphism -> locallyTrivialDiffeomorphism+  linIsoTransformShade = lits dualSpaceWitness dualSpaceWitness+   where lits :: ∀ x y . ( LinearManifold x, LinearManifold y+                         , Scalar (Needle x) ~ Scalar (Needle y) )+               => DualSpaceWitness x -> DualSpaceWitness y+                       -> (x+>y) -> Shade x -> Shade y+         lits DualSpaceWitness DualSpaceWitness f (Shade x δx)+                  = Shade (f $ x) (transformNorm (adjoint $ f) δx)++instance ImpliesMetric Shade where+  type MetricRequirement Shade x = (Manifold x, SimpleSpace (Needle x))+  inferMetric' (Shade _ e) = e+  inferMetric = im dualSpaceWitness+   where im :: (Manifold x, SimpleSpace (Needle x))+                   => DualNeedleWitness x -> Shade x -> Metric x+         im DualSpaceWitness (Shade _ e) = dualNorm e++instance ImpliesMetric Shade' where+  type MetricRequirement Shade' x = (Manifold x, SimpleSpace (Needle x))+  inferMetric (Shade' _ e) = e+  inferMetric' (Shade' _ e) = dualNorm e++shadeExpanse :: Lens' (Shade x) (Metric' x)+shadeExpanse f (Shade c e) = fmap (Shade c) $ f e++instance IsShade Shade' where+  shadeCtr f (Shade' c e) = fmap (`Shade'`e) $ f c+  occlusion = occ pseudoAffineWitness+   where occ :: ∀ x s . ( PseudoAffine x, SimpleSpace (Needle x)+                        , Scalar (Needle x) ~ s, RealDimension s )+                    => PseudoAffineWitness x -> Shade' x -> x -> s+         occ (PseudoAffineWitness (SemimanifoldWitness _)) (Shade' p₀ δinv) p+               = case toInterior p >>= (.-~.p₀) of+           (Just vd) | mSq <- normSq δinv vd+                     , mSq == mSq  -- avoid NaN+                     -> exp (negate mSq)+           _         -> zeroV+  factoriseShade (Shade' (x₀,y₀) δxy) = (Shade' x₀ δx, Shade' y₀ δy)+   where (δx,δy) = summandSpaceNorms δxy+  coerceShade = cS+   where cS :: ∀ x y . (LocallyCoercible x y) => Shade' x -> Shade' y+         cS = \(Shade' x δxym) -> Shade' (internCoerce x) (tN δxym)+          where tN = case oppositeLocalCoercion :: CanonicalDiffeomorphism y x of+                      CanonicalDiffeomorphism ->+                       transformNorm . arr $ coerceNeedle ([]::[(y,x)])+                internCoerce = case interiorLocalCoercion ([]::[(x,y)]) of+                      CanonicalDiffeomorphism -> locallyTrivialDiffeomorphism+  linIsoTransformShade f (Shade' x δx)+          = Shade' (f $ x) (transformNorm (pseudoInverse f) δx)++shadeNarrowness :: Lens' (Shade' x) (Metric x)+shadeNarrowness f (Shade' c e) = fmap (Shade' c) $ f e++instance ∀ x . (PseudoAffine x) => Semimanifold (Shade x) where+  type Needle (Shade x) = Needle x+  fromInterior = id+  toInterior = pure+  translateP = Tagged (.+~^)+  (.+~^) = case semimanifoldWitness :: SemimanifoldWitness x of+             SemimanifoldWitness BoundarylessWitness+                   -> \(Shade c e) v -> Shade (c.+~^v) e+  (.-~^) = case semimanifoldWitness :: SemimanifoldWitness x of+             SemimanifoldWitness BoundarylessWitness+                   -> \(Shade c e) v -> Shade (c.-~^v) e+  semimanifoldWitness = case semimanifoldWitness :: SemimanifoldWitness x of+                         (SemimanifoldWitness BoundarylessWitness)+                          -> SemimanifoldWitness BoundarylessWitness++instance (WithField ℝ PseudoAffine x, Geodesic (Interior x), SimpleSpace (Needle x))+             => Geodesic (Shade x) where+  geodesicBetween = gb dualSpaceWitness+   where gb :: DualNeedleWitness x -> Shade x -> Shade x -> Maybe (D¹ -> Shade x)+         gb DualSpaceWitness (Shade c (Norm e)) (Shade ζ (Norm η)) = pure interp+          where interp t@(D¹ q) = Shade (pinterp t)+                                 (Norm . arr . lerp ed ηd $ (q+1)/2)+                ed@(LinearMap _) = arr e+                ηd@(LinearMap _) = arr η+                Just pinterp = geodesicBetween c ζ++instance (AffineManifold x) => Semimanifold (Shade' x) where+  type Needle (Shade' x) = Diff x+  fromInterior = id+  toInterior = pure+  translateP = Tagged (.+~^)+  Shade' c e .+~^ v = Shade' (c.+^v) e+  Shade' c e .-~^ v = Shade' (c.-^v) e++instance (WithField ℝ AffineManifold x, Geodesic x, SimpleSpace (Needle x))+            => Geodesic (Shade' x) where+  geodesicBetween (Shade' c e) (Shade' ζ η) = pure interp+   where sharedSpan = sharedNormSpanningSystem e η+         interp t = Shade' (pinterp t)+                           (spanNorm [ v ^/ (alerpB 1 (recip qη) t)+                                     | (v,qη) <- sharedSpan ])+         Just pinterp = geodesicBetween c ζ++fullShade :: WithField ℝ PseudoAffine x => Interior x -> Metric' x -> Shade x+fullShade ctr expa = Shade ctr expa++fullShade' :: WithField ℝ PseudoAffine x => Interior x -> Metric x -> Shade' x+fullShade' ctr expa = Shade' ctr expa+++-- | Span a 'Shade' from a center point and multiple deviation-vectors.+#if GLASGOW_HASKELL < 800+pattern (:±) :: ()+#else+pattern (:±) :: (WithField ℝ Manifold x, SimpleSpace (Needle x))+#endif+             => (WithField ℝ Manifold x, SimpleSpace (Needle x))+                         => Interior x -> [Needle x] -> Shade x+pattern x :± shs <- Shade x (varianceSpanningSystem -> shs)+ where x :± shs = fullShade x $ spanVariance 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''.+(|±|) :: WithField ℝ EuclidSpace x => x -> [Needle x] -> Shade' x+x |±| shs = Shade' x $ spanNorm [v^/(v<.>v) | v<-shs]++++subshadeId' :: ∀ x . (WithField ℝ PseudoAffine x, LinearSpace (Needle x))+                   => x -> NonEmpty (Needle' x) -> x -> (Int, HourglassBulb)+subshadeId' c expvs x = case ( dualSpaceWitness :: DualNeedleWitness x+                             , x .-~. c ) of+    (DualSpaceWitness, Just v)+                    -> let (iu,vl) = maximumBy (comparing $ abs . snd)+                                      $ zip [0..] (map (v <.>^) $ NE.toList expvs)+                       in (iu, if vl>0 then UpperBulb else LowerBulb)+    _ -> (-1, error "Trying to obtain the subshadeId of a point not actually included in the shade.")++subshadeId :: ( WithField ℝ PseudoAffine x, LinearSpace (Needle x)+              , FiniteDimensional (Needle' x) )+                    => Shade x -> x -> (Int, HourglassBulb)+subshadeId (Shade c expa) = subshadeId' (fromInterior c)+                              . NE.fromList $ normSpanningSystem' expa+                 +++-- | 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))+                                 => [Interior x] -> [Shade x]+pointsShades = map snd . pointsShades' mempty . map fromInterior++coverAllAround :: ∀ x . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x))+                  => Interior x -> [Needle x] -> Shade x+coverAllAround x₀ offs = Shade x₀+         $ guaranteeIn dualSpaceWitness offs+               (scaleNorm (1/fromIntegral (length offs)) $ spanVariance offs)+ where guaranteeIn :: DualNeedleWitness x -> [Needle x] -> Metric' x -> Metric' x+       guaranteeIn w@DualSpaceWitness offs ex+          = case offs >>= \v -> guard ((ex'|$|v) > 1) >> [(v, spanVariance [v])] of+             []   -> ex+             outs -> guaranteeIn w (fst<$>outs)+                                 ( densifyNorm $+                                    ex <> scaleNorm+                                                (sqrt . recip . fromIntegral+                                                            $ 2 * length outs)+                                                (mconcat $ snd<$>outs)+                                 )+        where ex' = dualNorm 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))+                          => [Interior x] -> [Shade x]+pointsCovers = case pseudoAffineWitness :: PseudoAffineWitness x of+                 (PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness)) ->+                  \ps -> map (\(ps', Shade x₀ _)+                                -> coverAllAround x₀ [v | p<-ps'+                                                        , let Just v+                                                                 = p.-~.fromInterior x₀])+                             (pointsShades' mempty (fromInterior<$>ps) :: [([x], Shade x)])++pointsShade's :: ∀ x . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x))+                     => [Interior x] -> [Shade' x]+pointsShade's = case dualSpaceWitness :: DualNeedleWitness x of+ DualSpaceWitness -> map (\(Shade c e :: Shade x) -> Shade' c $ dualNorm e) . pointsShades++pointsCover's :: ∀ x . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x))+                     => [Interior x] -> [Shade' x]+pointsCover's = case dualSpaceWitness :: DualNeedleWitness x of+ DualSpaceWitness -> map (\(Shade c e :: Shade x) -> Shade' c $ dualNorm e) . pointsCovers++pseudoECM :: ∀ x p . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x), Hask.Functor p)+                => p x -> NonEmpty x -> (x, ([x],[x]))+pseudoECM = case semimanifoldWitness :: SemimanifoldWitness x of+ SemimanifoldWitness _ ->+   \_ (p₀ NE.:| psr) -> foldl' ( \(acc, (rb,nr)) (i,p)+                                -> case (p.-~.acc, toInterior acc) of +                                      (Just δ, Just acci)+                                        -> (acci .+~^ δ^/i, (p:rb, nr))+                                      _ -> (acc, (rb, p:nr)) )+                             (p₀, mempty)+                             ( zip [1..] $ p₀:psr )++pointsShades' :: ∀ x . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x))+                                => Metric' x -> [x] -> [([x], Shade x)]+pointsShades' _ [] = []+pointsShades' minExt ps = case (expa, toInterior ctr) of +                           (Just e, Just c)+                             -> (ps, fullShade c e) : pointsShades' minExt unreachable+                           _ -> pointsShades' minExt inc'd+                                  ++ pointsShades' minExt unreachable+ where (ctr,(inc'd,unreachable)) = pseudoECM ([]::[x]) $ NE.fromList ps+       expa = ( (<>minExt) . spanVariance . map (^/ fromIntegral (length ps)) )+              <$> mapM (.-~.ctr) 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 fuzz (sh₁@(Shade c₁ e₁) : shs)+    = case extractJust (tryMerge pseudoAffineWitness dualSpaceWitness)+                 shs of+          (Just mg₁, shs') -> shadesMerge fuzz+                                $ shs'++[mg₁] -- Append to end to prevent undue weighting+                                              -- of first shade and its mergers.+          (_, shs') -> sh₁ : shadesMerge fuzz shs' + where tryMerge :: PseudoAffineWitness x -> DualNeedleWitness x+                         -> Shade x -> Maybe (Shade x)+       tryMerge (PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness)) DualSpaceWitness+                    (Shade c₂ e₂)+           | Just v <- c₁.-~.c₂+           , [e₁',e₂'] <- dualNorm<$>[e₁, e₂] +           , b₁ <- e₂'|$|v+           , b₂ <- e₁'|$|v+           , fuzz*b₁*b₂ <= b₁ + b₂+                  = Just $ let cc = c₂ .+~^ v ^/ 2+                               Just cv₁ = c₁.-~.cc+                               Just cv₂ = c₂.-~.cc+                           in Shade cc $ e₁ <> e₂ <> spanVariance [cv₁, cv₂]+           | otherwise  = Nothing+shadesMerge _ shs = 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 = ms pseudoAffineWitness dualSpaceWitness+ where ms :: PseudoAffineWitness y -> DualNeedleWitness y+                  -> NonEmpty (Shade' y) -> Maybe (Shade' y)+       ms (PseudoAffineWitness (SemimanifoldWitness _)) DualSpaceWitness+                 (Shade' c₀ (Norm e₁):|shs) = sequenceA ciso >> pure mixed+        where ciso = [ci.-~.c₀ | Shade' ci shi <- shs]+              cis = [v | Just v <- ciso]+              σe = arr . sumV $ e₁ : (applyNorm . _shade'Narrowness<$>shs)+              cc = σe \$ sumV [ei $ ci | ci <- cis+                                       | Shade' _ (Norm ei) <- shs]+              mixed = Shade' (c₀+^cc) $ densifyNorm ( mconcat+                             [ Norm $ ei ^/ (1+(normSq ni $ ci^-^cc))+                             | ni@(Norm ei) <- Norm e₁ : (_shade'Narrowness<$>shs)+                             | ci <- zeroV : cis+                             ] )+              Tagged (+^) = translateP :: Tagged y (Interior y->Needle y->Interior y)+  -- 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)), RealDimension s )+              => Shade' x -> x -> s+minusLogOcclusion' (Shade' p₀ δinv)+        = occ (pseudoAffineWitness :: PseudoAffineWitness x)+              (dualSpaceWitness :: DualNeedleWitness x)+ where occ (PseudoAffineWitness (SemimanifoldWitness _)) DualSpaceWitness+           p = case toInterior p >>= (.-~.p₀) of+         (Just vd) | mSq <- normSq δinv vd+                   , mSq == mSq  -- avoid NaN+                   -> mSq+         _         -> 1/0+minusLogOcclusion :: ∀ x s . ( PseudoAffine x, SimpleSpace (Needle x)+                             , s ~ (Scalar (Needle x)), RealDimension s )+              => Shade x -> x -> s+minusLogOcclusion (Shade p₀ δ)+        = occ (pseudoAffineWitness :: PseudoAffineWitness x)+              (dualSpaceWitness :: DualNeedleWitness x)+ where occ (PseudoAffineWitness (SemimanifoldWitness _)) DualSpaceWitness+            = \p -> case toInterior p >>= (.-~.p₀) of+         (Just vd) | mSq <- normSq δinv vd+                   , mSq == mSq  -- avoid NaN+                   -> mSq+         _         -> 1/0+        where δinv = dualNorm δ+++++rangeOnGeodesic :: ∀ i m . +      ( WithField ℝ PseudoAffine m, Geodesic m, SimpleSpace (Needle m)+      , WithField ℝ IntervalLike i, SimpleSpace (Needle i) )+                     => m -> m -> Maybe (Shade i -> Shade m)+rangeOnGeodesic = case ( semimanifoldWitness :: SemimanifoldWitness i+                       , dualSpaceWitness :: DualNeedleWitness i+                       , dualSpaceWitness :: DualNeedleWitness m ) of+ (SemimanifoldWitness _, DualSpaceWitness, DualSpaceWitness) ->+  \p₀ p₁ -> (`fmap`(geodesicBetween p₀ p₁))+    $ \interp -> \(Shade t₀ et)+                -> case pointsShades+                         . mapMaybe (toInterior+                               . interp . (toClosedInterval :: i -> D¹))+                         $ fromInterior <$> t₀ : [ t₀+^v+                                                 | v<-normSpanningSystem et ] of+             [sh] -> sh+             _ -> case pointsShades $ mapMaybe (toInterior . interp . D¹)+                        [-0.999, 0.999] of+                [sh] -> sh+ where Tagged (+^) = translateP :: Tagged i (Interior i->Needle i->Interior i)+++++-- | Hourglass as the geometric shape (two opposing ~conical volumes, sharing+--   only a single point in the middle); has nothing to do with time.+data Hourglass s = Hourglass { upperBulb, lowerBulb :: !s }+            deriving (Generic, Hask.Functor, Hask.Foldable, Show)+instance (NFData s) => NFData (Hourglass s)+instance (Semigroup s) => Semigroup (Hourglass s) where+  Hourglass u l <> Hourglass u' l' = Hourglass (u<>u') (l<>l')+  sconcat hgs = let (us,ls) = NE.unzip $ (upperBulb&&&lowerBulb) <$> hgs+                in Hourglass (sconcat us) (sconcat ls)+instance (Monoid s, Semigroup s) => Monoid (Hourglass s) where+  mempty = Hourglass mempty mempty; mappend = (<>)+  mconcat hgs = let (us,ls) = unzip $ (upperBulb&&&lowerBulb) <$> hgs+                in Hourglass (mconcat us) (mconcat ls)+instance Hask.Applicative Hourglass where+  pure x = Hourglass x x+  Hourglass f g <*> Hourglass x y = Hourglass (f x) (g y)+instance Foldable Hourglass (->) (->) where+  ffoldl f (x, Hourglass a b) = f (f(x,a), b)+  foldMap f (Hourglass a b) = f a `mappend` f b++flipHour :: Hourglass s -> Hourglass s+flipHour (Hourglass u l) = Hourglass l u++data HourglassBulb = UpperBulb | LowerBulb+oneBulb :: HourglassBulb -> (a->a) -> Hourglass a->Hourglass a+oneBulb UpperBulb f (Hourglass u l) = Hourglass (f u) l+oneBulb LowerBulb f (Hourglass u l) = Hourglass u (f l)++++data ShadeTree x = PlainLeaves [x]+                 | DisjointBranches !Int (NonEmpty (ShadeTree x))+                 | OverlappingBranches !Int !(Shade x) (NonEmpty (DBranch x))+  deriving (Generic)+deriving instance ( WithField ℝ PseudoAffine x, Show x+                  , Show (Interior x), Show (Needle' x), Show (Metric' x) )+             => Show (ShadeTree x)+           +data DBranch' x c = DBranch { boughDirection :: !(Needle' x)+                            , boughContents :: !(Hourglass c) }+  deriving (Generic, Hask.Functor, Hask.Foldable)+type DBranch x = DBranch' x (ShadeTree x)+deriving instance ( WithField ℝ PseudoAffine x, Show (Needle' x), Show c )+             => Show (DBranch' x c)++newtype DBranches' x c = DBranches (NonEmpty (DBranch' x c))+  deriving (Generic, Hask.Functor, Hask.Foldable)+deriving instance ( WithField ℝ PseudoAffine x, Show (Needle' x), Show c )+             => Show (DBranches' x c)++-- ^ /Unsafe/: this assumes the direction information of both containers to be equivalent.+instance (Semigroup c) => Semigroup (DBranches' x c) where+  DBranches b1 <> DBranches b2 = DBranches $ NE.zipWith (\(DBranch d1 c1) (DBranch _ c2)+                                                              -> DBranch d1 $ c1<>c2 ) b1 b2++  +directionChoices :: WithField ℝ Manifold x+               => [DBranch x]+                 -> [ ( (Needle' x, ShadeTree x)+                      ,[(Needle' x, ShadeTree x)] ) ]+directionChoices = map (snd *** map snd) . directionIChoices 0++directionIChoices :: (WithField ℝ PseudoAffine x, AdditiveGroup (Needle' x))+               => Int -> [DBranch x]+                 -> [ ( (Int, (Needle' x, ShadeTree x))+                      ,[(Int, (Needle' x, ShadeTree x))] ) ]+directionIChoices _ [] = []+directionIChoices i₀ (DBranch ѧ (Hourglass t b) : hs)+         =  ( top, bot : map fst uds )+          : ( bot, top : map fst uds )+          : map (second $ (top:) . (bot:)) uds+ where top = (i₀,(ѧ,t))+       bot = (i₀+1,(negateV ѧ,b))+       uds = directionIChoices (i₀+2) hs++traverseDirectionChoices :: ( WithField ℝ PseudoAffine x, LSpace (Needle x)+                            , Hask.Applicative f )+               => (    (Int, (Needle' x, ShadeTree x))+                    -> [(Int, (Needle' x, ShadeTree x))]+                    -> f (ShadeTree x) )+                 -> [DBranch x]+                 -> f [DBranch x]+traverseDirectionChoices f dbs+           = td [] . scanLeafNums 0+               $ dbs >>= \(DBranch ѧ (Hourglass τ β))+                              -> [(ѧ,τ), (negateV ѧ,β)]+ where td pds (ѧt@(_,(ѧ,_)):vb:vds)+         = liftA3 (\t' b' -> (DBranch ѧ (Hourglass t' b') :))+             (f ѧt $ vb:uds)+             (f vb $ ѧt:uds)+             $ td (ѧt:vb:pds) vds+        where uds = pds ++ vds+       td _ _ = pure []+       scanLeafNums _ [] = []+       scanLeafNums i₀ ((v,t):vts) = (i₀, (v,t)) : scanLeafNums (i₀ + nLeaves t) vts+++indexDBranches :: NonEmpty (DBranch x) -> NonEmpty (DBranch' x (Int, ShadeTree x))+indexDBranches (DBranch d (Hourglass t b) :| l) -- this could more concisely be written as a traversal+              = DBranch d (Hourglass (0,t) (nt,b)) :| ixDBs (nt + nb) l+ where nt = nLeaves t; nb = nLeaves b+       ixDBs _ [] = []+       ixDBs i₀ (DBranch δ (Hourglass τ β) : l)+               = DBranch δ (Hourglass (i₀,τ) (i₀+nτ,β)) : ixDBs (i₀ + nτ + nβ) l+        where nτ = nLeaves τ; nβ = nLeaves β++instance (NFData x, NFData (Needle' x)) => NFData (ShadeTree x) where+  rnf (PlainLeaves xs) = rnf xs+  rnf (DisjointBranches n bs) = n `seq` rnf (NE.toList bs)+  rnf (OverlappingBranches n sh bs) = n `seq` sh `seq` rnf (NE.toList bs)+instance (NFData x, NFData (Needle' x)) => NFData (DBranch x)+  +-- | Experimental. There might be a more powerful instance possible.+instance (AffineManifold x) => Semimanifold (ShadeTree x) where+  type Needle (ShadeTree x) = Diff x+  fromInterior = id+  toInterior = pure+  translateP = Tagged (.+~^)+  PlainLeaves xs .+~^ v = PlainLeaves $ (.+^v)<$>xs +  OverlappingBranches n sh br .+~^ v+        = OverlappingBranches n (sh.+~^v)+                $ fmap (\(DBranch d c) -> DBranch d $ (.+~^v)<$>c) br+  DisjointBranches n br .+~^ v = DisjointBranches n $ (.+~^v)<$>br++-- | WRT union.+instance (WithField ℝ Manifold x, SimpleSpace (Needle x)) => Semigroup (ShadeTree x) where+  PlainLeaves [] <> t = t+  t <> PlainLeaves [] = t+  t <> s = fromLeafPoints $ onlyLeaves t ++ onlyLeaves s+           -- Could probably be done more efficiently+  sconcat = mconcat . NE.toList+instance (WithField ℝ Manifold x, SimpleSpace (Needle x)) => Monoid (ShadeTree x) where+  mempty = PlainLeaves []+  mappend = (<>)+  mconcat l = case filter ne l of+               [] -> mempty+               [t] -> t+               l' -> fromLeafPoints $ onlyLeaves =<< l'+   where ne (PlainLeaves []) = False; ne _ = True+++-- | Build a quite nicely balanced tree from a cloud of points, on any real manifold.+-- +--   Example: https://nbviewer.jupyter.org/github/leftaroundabout/manifolds/blob/master/test/Trees-and-Webs.ipynb#pseudorandomCloudTree+-- +-- <<images/examples/simple-2d-ShadeTree.png>>+fromLeafPoints :: ∀ x. (WithField ℝ Manifold x, SimpleSpace (Needle x))+                         => [x] -> ShadeTree x+fromLeafPoints = fromLeafPoints' sShIdPartition+++-- | The leaves of a shade tree are numbered. For a given index, this function+--   attempts to find the leaf with that ID, within its immediate environment.+indexShadeTree :: ∀ x . WithField ℝ Manifold x+       => ShadeTree x -> Int -> Either Int ([ShadeTree x], x)+indexShadeTree _ i+    | i<0        = Left i+indexShadeTree sh@(PlainLeaves lvs) i = case length lvs of+  n | i<n       -> Right ([sh], lvs!!i)+    | otherwise -> Left $ i-n+indexShadeTree (DisjointBranches n brs) i+    | i<n        = foldl (\case +                             Left i' -> (`indexShadeTree`i')+                             result  -> return result+                         ) (Left i) brs+    | otherwise  = Left $ i-n+indexShadeTree sh@(OverlappingBranches n _ brs) i+    | i<n        = first (sh:) <$> foldl (\case +                             Left i' -> (`indexShadeTree`i')+                             result  -> return result+                         ) (Left i) (toList brs>>=toList)+    | otherwise  = Left $ i-n+++-- | “Inverse indexing” of a tree. This is roughly a nearest-neighbour search,+--   but not guaranteed to give the correct result unless evaluated at the+--   precise position of a tree leaf.+positionIndex :: ∀ x . (WithField ℝ Manifold x, SimpleSpace (Needle x))+       => Maybe (Metric x)   -- ^ For deciding (at the lowest level) what “close” means;+                             --   this is optional for any tree of depth >1.+        -> ShadeTree x       -- ^ The tree to index into+        -> x                 -- ^ Position to look up+        -> Maybe (Int, ([ShadeTree x], x))+                   -- ^ Index of the leaf near to the query point, the “path” of+                   --   environment trees leading down to its position (in decreasing+                   --   order of size), and actual position of the found node.+positionIndex (Just m) sh@(PlainLeaves lvs) x+        = case catMaybes [ ((i,p),) . normSq m <$> p.-~.x+                            | (i,p) <- zip [0..] lvs] of+           [] -> empty+           l | ((i,p),_) <- minimumBy (comparing snd) l+              -> pure (i, ([sh], p))+positionIndex m (DisjointBranches _ brs) x+        = fst . foldl' (\case+                          (q@(Just _), i₀) -> const (q, i₀)+                          (_, i₀) -> \t' -> ( first (+i₀) <$> positionIndex m t' x+                                            , i₀+nLeaves t' ) )+                       (empty, 0)+              $        brs+positionIndex _ sh@(OverlappingBranches n (Shade c ce) brs) x+   | PseudoAffineWitness (SemimanifoldWitness _)+               <- pseudoAffineWitness :: PseudoAffineWitness x+   , Just vx <- toInterior x>>=(.-~.c)+        = let (_,(i₀,t')) = maximumBy (comparing fst)+                       [ (σ*ω, t')+                       | DBranch d (Hourglass t'u t'd) <- NE.toList $ indexDBranches brs+                       , let ω = d<.>^vx+                       , (t',σ) <- [(t'u, 1), (t'd, -1)] ]+          in ((+i₀) *** first (sh:))+                 <$> positionIndex (return $ dualNorm' ce) t' x+positionIndex _ _ _ = empty++++fromFnGraphPoints :: ∀ x y . ( WithField ℝ Manifold x, WithField ℝ Manifold y+                             , SimpleSpace (Needle x), SimpleSpace (Needle y) )+                     => [(x,y)] -> ShadeTree (x,y)+fromFnGraphPoints = case ( dualSpaceWitness :: DualNeedleWitness x+                         , boundarylessWitness :: BoundarylessWitness x+                         , dualSpaceWitness :: DualNeedleWitness y+                         , boundarylessWitness :: BoundarylessWitness y ) of+    (DualSpaceWitness,BoundarylessWitness,DualSpaceWitness,BoundarylessWitness)+        -> fromLeafPoints' $+     \(Shade c expa) xs -> case+            [ DBranch (v, zeroV) mempty+            | v <- normSpanningSystem' (transformNorm (id&&&zeroV) expa :: Metric' x) ] of+         (b:bs) -> sShIdPartition' c xs $ b:|bs++fromLeafPoints' :: ∀ x. (WithField ℝ Manifold x, SimpleSpace (Needle x)) =>+    (Shade x -> [x] -> NonEmpty (DBranch' x [x])) -> [x] -> ShadeTree x+fromLeafPoints' sShIdPart = go boundarylessWitness mempty+ where go :: BoundarylessWitness x -> Metric' x -> [x] -> ShadeTree x+       go bw@BoundarylessWitness preShExpa+            = \xs -> case pointsShades' (scaleNorm (1/3) preShExpa) xs of+                     [] -> mempty+                     [(_,rShade)] -> let trials = sShIdPart rShade xs+                                     in case reduce rShade trials of+                                         Just redBrchs+                                           -> OverlappingBranches+                                                  (length xs) rShade+                                                  (branchProc (_shadeExpanse rShade) redBrchs)+                                         _ -> PlainLeaves xs+                     partitions -> DisjointBranches (length xs)+                                   . NE.fromList+                                    $ map (\(xs',pShade) -> go bw mempty xs') partitions+        where +              branchProc redSh = fmap (fmap $ go bw redSh)+                                 +              reduce :: Shade x -> NonEmpty (DBranch' x [x])+                                      -> Maybe (NonEmpty (DBranch' x [x]))+              reduce sh@(Shade c _) brCandidates+                        = case findIndex deficient cards of+                            Just i | (DBranch _ reBr, o:ok)+                                             <- amputateId i (NE.toList brCandidates)+                                           -> reduce sh+                                                $ sShIdPartition' c (fold reBr) (o:|ok)+                                   | otherwise -> Nothing+                            _ -> Just brCandidates+               where (cards, maxCard) = (NE.toList &&& maximum')+                                $ fmap (fmap length . boughContents) brCandidates+                     deficient (Hourglass u l) = any (\c -> c^2 <= maxCard + 1) [u,l]+                     maximum' = maximum . NE.toList . fmap (\(Hourglass u l) -> max u l)+++sShIdPartition' :: (WithField ℝ PseudoAffine x, SimpleSpace (Needle x))+        => Interior x -> [x] -> NonEmpty (DBranch' x [x])->NonEmpty (DBranch' x [x])+sShIdPartition' c xs st+           = foldr (\p -> let (i,h) = ssi p+                          in asList $ update_nth (\(DBranch d c)+                                                    -> DBranch d (oneBulb h (p:) c))+                                      i )+                   st xs+ where ssi = subshadeId' (fromInterior c) (boughDirection<$>st)+sShIdPartition :: (WithField ℝ PseudoAffine x, SimpleSpace (Needle x))+                    => Shade x -> [x] -> NonEmpty (DBranch' x [x])+sShIdPartition (Shade c expa) xs+ | b:bs <- [DBranch v mempty | v <- normSpanningSystem' expa]+    = sShIdPartition' c xs $ b:|bs+                                           ++asList :: ([a]->[b]) -> NonEmpty a->NonEmpty b+asList f = NE.fromList . f . NE.toList++update_nth :: (a->a) -> Int -> [a] -> [a]+update_nth _ n l | n<0 = l+update_nth f 0 (c:r) = f c : r+update_nth f n [] = []+update_nth f n (l:r) = l : update_nth f (n-1) r+++amputateId :: Int -> [a] -> (a,[a])+amputateId i l = let ([a],bs) = amputateIds [i] l in (a, bs)++deleteIds :: [Int] -> [a] -> [a]+deleteIds kids = snd . amputateIds kids++amputateIds :: [Int]     -- ^ Sorted list of non-negative indices to extract+            -> [a]       -- ^ Input list+            -> ([a],[a]) -- ^ (Extracted elements, remaining elements)+amputateIds = go 0+ where go _ _ [] = ([],[])+       go _ [] l = ([],l)+       go i (k:ks) (x:xs)+         | i==k       = first  (x:) $ go (i+1)    ks  xs+         | otherwise  = second (x:) $ go (i+1) (k:ks) xs+++++sortByKey :: Ord a => [(a,b)] -> [b]+sortByKey = map snd . sortBy (comparing fst)+++trunks :: ∀ x. (WithField ℝ PseudoAffine x, SimpleSpace (Needle x))+                  => ShadeTree x -> [Shade x]+trunks t = case (pseudoAffineWitness :: PseudoAffineWitness x, t) of+  (PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness), PlainLeaves lvs)+                                         -> pointsCovers . catMaybes $ toInterior<$>lvs+  (_, DisjointBranches _ brs)            -> Hask.foldMap trunks brs+  (_, OverlappingBranches _ sh _)        -> [sh]+++nLeaves :: ShadeTree x -> Int+nLeaves (PlainLeaves lvs) = length lvs+nLeaves (DisjointBranches n _) = n+nLeaves (OverlappingBranches n _ _) = n+++instance ImpliesMetric ShadeTree where+  type MetricRequirement ShadeTree x = (WithField ℝ PseudoAffine x, SimpleSpace (Needle x))+  inferMetric = stInfMet+   where stInfMet :: ∀ x . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x))+                                => ShadeTree x -> Metric x+         stInfMet (OverlappingBranches _ (Shade _ e) _) = dualNorm' e+         stInfMet (PlainLeaves lvs)+               = case pointsShades $ Hask.toList . toInterior =<< lvs :: [Shade x] of+             (Shade _ sh:_) -> dualNorm' sh+             _ -> mempty+         stInfMet (DisjointBranches _ (br:|_)) = inferMetric br+  inferMetric' = stInfMet+   where stInfMet :: ∀ x . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x))+                                => ShadeTree x -> Metric' x+         stInfMet (OverlappingBranches _ (Shade _ e) _) = e+         stInfMet (PlainLeaves lvs)+               = case pointsShades $ Hask.toList . toInterior =<< lvs :: [Shade x] of+             (Shade _ sh:_) -> sh+             _ -> mempty+         stInfMet (DisjointBranches _ (br:|_)) = inferMetric' br++++overlappingBranches :: Shade x -> NonEmpty (DBranch x) -> ShadeTree x+overlappingBranches shx brs = OverlappingBranches n shx brs+ where n = sum $ fmap (sum . fmap nLeaves) brs++unsafeFmapLeaves :: (x -> x) -> ShadeTree x -> ShadeTree x+unsafeFmapLeaves f (PlainLeaves lvs) = PlainLeaves $ fmap f lvs+unsafeFmapLeaves f (DisjointBranches n brs)+                  = DisjointBranches n $ unsafeFmapLeaves f <$> brs+unsafeFmapLeaves f (OverlappingBranches n sh brs)+                  = OverlappingBranches n sh $ fmap (unsafeFmapLeaves f) <$> brs++unsafeFmapTree :: (NonEmpty x -> NonEmpty y)+               -> (Needle' x -> Needle' y)+               -> (Shade x -> Shade y)+               -> ShadeTree x -> ShadeTree y+unsafeFmapTree _ _ _ (PlainLeaves []) = PlainLeaves []+unsafeFmapTree f _ _ (PlainLeaves lvs) = PlainLeaves . toList . f $ NE.fromList lvs+unsafeFmapTree f fn fs (DisjointBranches n brs)+    = let brs' = unsafeFmapTree f fn fs <$> brs+      in DisjointBranches (sum $ nLeaves<$>brs') brs'+unsafeFmapTree f fn fs (OverlappingBranches n sh brs)+    = let brs' = fmap (\(DBranch dir br)+                      -> DBranch (fn dir) (unsafeFmapTree f fn fs<$>br)+                      ) brs+      in overlappingBranches (fs sh) brs'++coerceShadeTree :: ∀ x y . (LocallyCoercible x y, Manifold x, Manifold y)+                       => ShadeTree x -> ShadeTree y+coerceShadeTree = case ( dualSpaceWitness :: DualNeedleWitness x+                       , dualSpaceWitness :: DualNeedleWitness y ) of+   (DualSpaceWitness,DualSpaceWitness)+      -> unsafeFmapTree (fmap locallyTrivialDiffeomorphism)+                                 (coerceNeedle' ([]::[(x,y)]) $)+                                 coerceShade+++-- | 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+  -- | @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' ac ae) (Shade' tc te)+        = case pseudoAffineWitness :: PseudoAffineWitness y of+   PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness)+    | Just v <- tc.-~.ac+    , v² <- normSq te v+    , v² <= 1+     -> all (\(y',μ) -> case μ of+            Nothing -> True  -- 'te' has infinite extension in this direction+            Just ξ+              | ξ<1 -> False -- 'ae' would be vaster than 'te' in this direction+              | ω <- abs $ y'<.>^v+                    -> (ω + 1/ξ)^2 <= 1 - v² + ω^2+                 -- See @images/constructions/subellipse-check-heuristic.svg@+         ) $ sharedSeminormSpanningSystem te ae+   _ -> False+  +  -- | Intersection between two shades.+  refineShade' :: Shade' y -> Shade' y -> Maybe (Shade' y)+  refineShade' (Shade' c₀ (Norm e₁)) (Shade' c₀₂ (Norm e₂))+      = case ( dualSpaceWitness :: DualNeedleWitness y+             , pseudoAffineWitness :: PseudoAffineWitness y ) of+          (DualSpaceWitness, PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness))+               -> do+           c₂ <- c₀₂.-~.c₀+           let σe = arr $ e₁^+^e₂+               e₁c₂ = e₁ $ c₂+               e₂c₂ = e₂ $ c₂+               cc = σe \$ e₂c₂+               cc₂ = cc ^-^ c₂+               e₁cc = e₁ $ cc+               e₂cc = e₂ $ cc+               α = 2 + e₂c₂<.>^cc₂+           guard (α > 0)+           let ee = σe ^/ α+               c₂e₁c₂ = e₁c₂<.>^c₂+               c₂e₂c₂ = e₂c₂<.>^c₂+               c₂eec₂ = (c₂e₁c₂ + c₂e₂c₂) / α+           return $ case middle . sort+                $ quadraticEqnSol c₂e₁c₂+                                  (2 * (e₁cc<.>^c₂))+                                  (e₁cc<.>^cc - 1)+                ++quadraticEqnSol c₂e₂c₂+                                  (2 * (e₂cc<.>^c₂ - c₂e₂c₂))+                                  (e₂cc<.>^cc - 2 * (e₂c₂<.>^cc) + c₂e₂c₂ - 1) of+            [γ₁,γ₂] | abs (γ₁+γ₂) < 2 -> let+               cc' = cc ^+^ ((γ₁+γ₂)/2)*^c₂+               rγ = abs (γ₁ - γ₂) / 2+               η = if rγ * c₂eec₂ /= 0 && 1 - rγ^2 * c₂eec₂ > 0+                   then sqrt (1 - rγ^2 * c₂eec₂) / (rγ * c₂eec₂)+                   else 0+             in Shade' (c₀.+~^cc')+                       (Norm (arr ee) <> spanNorm [ee $ c₂^*η])+            _ -> Shade' (c₀.+~^cc) (Norm $ arr ee)+   where quadraticEqnSol a b c+             | a == 0, b /= 0       = [-c/b]+             | a /= 0 && disc == 0  = [- b / (2*a)]+             | a /= 0 && disc > 0   = [ (σ * sqrt disc - b) / (2*a)+                                      | σ <- [-1, 1] ]+             | otherwise            = []+          where disc = b^2 - 4*a*c+         middle (_:x:y:_) = [x,y]+         middle l = 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 _ ey eδ = spanNorm [ f ^* ζ crl+                                    | (f,crl) <- eδsp ]+   where eδsp = sharedSeminormSpanningSystem ey eδ+         ζ = case filter (>0) . catMaybes $ snd<$>eδsp of+            [] -> const 0+            nzrelap+               -> let cre₁ = 1/minimum nzrelap+                      cre₂ =  maximum nzrelap+                      edgeFactor = sqrt ( (1 + cre₁)^2 + (1 + cre₂)^2 )+                                / (sqrt (1 + cre₁^2) + sqrt (1 + cre₂^2))+                  in \case+                        Nothing -> 0+                        Just 0  -> 0+                        Just sq -> edgeFactor / (recip sq + 1)+  +  convolveShade' :: Shade' y -> Shade' (Needle y) -> Shade' y+  convolveShade' = defaultConvolveShade'+  +defaultConvolveShade' :: ∀ y . Refinable y => Shade' y -> Shade' (Needle y) -> Shade' y+defaultConvolveShade' = case (pseudoAffineWitness :: PseudoAffineWitness y) of+  PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness)+    -> \(Shade' y₀ ey) (Shade' δ₀ eδ) -> Shade' (y₀.+~^δ₀)+                                          $ convolveMetric ([]::[y]) ey eδ++instance Refinable ℝ where+  refineShade' (Shade' cl el) (Shade' cr er)+         = case (normSq el 1, normSq er 1) of+             (0, _) -> return $ Shade' cr er+             (_, 0) -> return $ Shade' cl el+             (ql,qr) | ql>0, qr>0+                    -> let [rl,rr] = sqrt . recip <$> [ql,qr]+                           b = maximum $ zipWith (-) [cl,cr] [rl,rr]+                           t = minimum $ zipWith (+) [cl,cr] [rl,rr]+                       in guard (b<t) >>+                           let cm = (b+t)/2+                               rm = (t-b)/2+                           in return $ Shade' cm (spanNorm [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 ( Refinable a, Interior a ~ a, Refinable b, Interior b ~ b+         , Scalar (DualVector (DualVector (Needle b)))+                      ~ Scalar (DualVector (DualVector (Needle a))) )+    => Refinable (a,b)+  +instance Refinable ℝ⁰+instance Refinable ℝ¹+instance Refinable ℝ²+instance Refinable ℝ³+instance Refinable ℝ⁴+                            +instance ( SimpleSpace a, SimpleSpace b+         , Scalar a ~ ℝ, Scalar b ~ ℝ+         , Scalar (DualVector a) ~ ℝ, Scalar (DualVector b) ~ ℝ+         , Scalar (DualVector (DualVector a)) ~ ℝ, Scalar (DualVector (DualVector b)) ~ ℝ )+            => Refinable (LinearMap ℝ a b)++intersectShade's :: ∀ y . Refinable y => NonEmpty (Shade' y) -> Maybe (Shade' y)+intersectShade's (sh:|shs) = Hask.foldrM refineShade' sh shs+++estimateLocalJacobian :: ∀ x y . ( WithField ℝ Manifold x, Refinable y+                                 , SimpleSpace (Needle x), SimpleSpace (Needle y) )+            => Metric x -> [(Local x, Shade' y)]+                             -> Maybe (Shade' (LocalLinear x y))+estimateLocalJacobian = elj ( pseudoAffineWitness :: PseudoAffineWitness x+                            , pseudoAffineWitness :: PseudoAffineWitness y )+ where elj ( PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness)+           , PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness) )+        mex [(Local x₁, Shade' y₁ ey₁),(Local x₀, Shade' y₀ ey₀)]+         = return $ Shade' (dx-+|>δy)+                          (Norm . LinearFunction $ \δj -> δx ⊗ (σey<$|δj $ δx))+        where Just δx = x₁.-~.x₀+              δx' = (mex<$|δx)+              dx = δx'^/(δx'<.>^δx)+              Just δy = y₁.-~.y₀+              σey = convolveMetric ([]::[y]) ey₀ ey₁+       elj _ mex (po:ps)+           | DualSpaceWitness <- dualSpaceWitness :: DualNeedleWitness y+           , length ps > 1+               = mixShade's =<< (:|) <$> estimateLocalJacobian mex ps +                             <*> sequenceA [estimateLocalJacobian mex [po,pi] | pi<-ps]+       elj _ _ _ = return $ Shade' zeroV mempty++++propagateDEqnSolution_loc :: ∀ x y . ( WithField ℝ Manifold x+                                     , Refinable y, Geodesic (Interior y)+                                     , SimpleSpace (Needle x) )+           => DifferentialEqn x y+               -> LocalDataPropPlan x (Shade' y)+               -> Maybe (Shade' y)+propagateDEqnSolution_loc f propPlan+                  = pdesl (dualSpaceWitness :: DualNeedleWitness x)+                          (dualSpaceWitness :: DualNeedleWitness y)+                          (boundarylessWitness :: BoundarylessWitness x)+                          (pseudoAffineWitness :: PseudoAffineWitness y)+ where pdesl DualSpaceWitness DualSpaceWitness BoundarylessWitness+             (PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness))+          | Nothing <- jacobian  = Nothing+          | otherwise            = pure result+         where jacobian = f shxy ^. predictDerivatives+               Just (Shade' j₀ jExpa) = jacobian++               mx = propPlan^.sourcePosition .+~^ propPlan^.targetPosOffset ^/ 2+               Just my = middleBetween (propPlan^.sourceData.shadeCtr)+                                       (propPlan^.targetAPrioriData.shadeCtr)+               shxy = coverAllAround (mx, my)+                                     [ (δx ^-^ propPlan^.targetPosOffset ^/ 2, py ^+^ v)+                                     | (δx,ney) <- (zeroV, propPlan^.sourceData)+                                                  : (propPlan^.relatedData)+                                     , let Just py = ney^.shadeCtr .-~. my+                                     , v <- normSpanningSystem' (ney^.shadeNarrowness)+                                     ]+               (Shade _ expax' :: Shade x)+                    = coverAllAround (propPlan^.sourcePosition)+                                     [δx | (δx,_) <- propPlan^.relatedData]+               expax = dualNorm expax'+               result :: Shade' y+               result = convolveShade'+                        (propPlan^.sourceData)+                        (Shade' δyb $ applyLinMapNorm jExpa dx)+                where δyb = j₀ $ δx+               δx = propPlan^.targetPosOffset+               dx = δx'^/(δx'<.>^δx)+                where δx' = expax<$|δx++applyLinMapNorm :: ∀ x y . (LSpace x, LSpace y, Scalar x ~ Scalar y)+           => Norm (x+>y) -> DualVector x -> Norm y+applyLinMapNorm = case dualSpaceWitness :: DualSpaceWitness y of+  DualSpaceWitness -> \n dx -> transformNorm (arr $ LinearFunction (dx-+|>)) n++ignoreDirectionalDependence :: ∀ x y . (LSpace x, LSpace y, Scalar x ~ Scalar y)+           => (x, DualVector x) -> Norm (x+>y) -> Norm (x+>y)+ignoreDirectionalDependence = case dualSpaceWitness :: DualSpaceWitness y of+  DualSpaceWitness -> \(v,v') -> transformNorm . arr . LinearFunction $+         \j -> j . arr (LinearFunction $ \x -> x ^-^ v^*(v'<.>^x))++type Twig x = (Int, ShadeTree x)+type TwigEnviron x = [Twig x]++allTwigs :: ∀ x . WithField ℝ PseudoAffine x => ShadeTree x -> [Twig x]+allTwigs tree = go 0 tree []+ where go n₀ (DisjointBranches _ dp)+         = snd (foldl' (\(n₀',prev) br -> (n₀'+nLeaves br, prev . go n₀' br)) (n₀,id) dp)+       go n₀ (OverlappingBranches _ _ dp)+         = snd (foldl' (\(n₀',prev) (DBranch _ (Hourglass top bot))+                          -> ( n₀'+nLeaves top+nLeaves bot+                             , prev . go n₀' top . go (n₀'+nLeaves top) bot) )+                        (n₀,id) $ NE.toList dp)+       go n₀ twig = ((n₀,twig):)++-- Formerly, 'twigsWithEnvirons' what has now become 'traverseTwigsWithEnvirons'.+-- The simple list-yielding version (see rev. b4a427d59ec82889bab2fde39225b14a57b694df)+-- may well be more efficient than the current traversal-derived version.++-- | Example: https://nbviewer.jupyter.org/github/leftaroundabout/manifolds/blob/master/test/Trees-and-Webs.ipynb#pseudorandomCloudTree+-- +--   <<images/examples/TreesAndWebs/2D-scatter_twig-environs.png>>+twigsWithEnvirons :: ∀ x. (WithField ℝ Manifold x, SimpleSpace (Needle x))+    => ShadeTree x -> [(Twig x, TwigEnviron x)]+twigsWithEnvirons = execWriter . traverseTwigsWithEnvirons (writer . (snd.fst&&&pure))++traverseTwigsWithEnvirons :: ∀ x f .+            (WithField ℝ PseudoAffine x, SimpleSpace (Needle x), Hask.Applicative f)+    => ( (Twig x, TwigEnviron x) -> f (ShadeTree x) ) -> ShadeTree x -> f (ShadeTree x)+traverseTwigsWithEnvirons f = fst . go pseudoAffineWitness [] . (0,)+ where go :: PseudoAffineWitness x -> TwigEnviron x -> Twig x -> (f (ShadeTree x), Bool)+       go sw _ (i₀, DisjointBranches nlvs djbs) = ( fmap (DisjointBranches nlvs)+                                                   . Hask.traverse (fst . go sw [])+                                                   $ NE.zip ioffs djbs+                                               , False )+        where ioffs = NE.scanl (\i -> (+i) . nLeaves) i₀ djbs+       go sw@(PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness)) envi+           ct@(i₀, (OverlappingBranches nlvs rob@(Shade robc _) brs))+                = ( case descentResult of+                     OuterNothing -> f+                         $ purgeRemotes+                            (ct, Hask.foldMap (\(io,te)+                                         -> first (+io) <$> twigProximæ sw robc te) envi)+                     OuterJust dR -> fmap (OverlappingBranches nlvs rob . NE.fromList) dR+                  , False )+        where descentResult = traverseDirectionChoices tdc $ NE.toList brs+              tdc (io, (vy, ty)) alts = case go sw envi'' (i₀+io, ty) of+                                   (_, True) -> OuterNothing+                                   (down, _) -> OuterJust down+               where envi'' = filter (snd >>> trunks >>> \(Shade ce _:_)+                                         -> let Just δyenv = ce.-~.robc+                                                qq = vy<.>^δyenv+                                            in qq > -1+                                       ) envi'+                              ++ map ((+i₀)***snd) alts+              envi' = approach =<< envi+              approach (i₀e, apt@(OverlappingBranches _ (Shade envc _) _))+                  = first (+i₀e) <$> twigsaveTrim hither apt+               where Just δxenv = robc .-~. envc+                     hither (DBranch bdir (Hourglass bdc₁ bdc₂))+                       =  [(0           , bdc₁) | overlap > -1]+                       ++ [(nLeaves bdc₁, bdc₂) | overlap < 1]+                      where overlap = bdir<.>^δxenv+              approach q = [q]+       go (PseudoAffineWitness (SemimanifoldWitness _)) envi plvs@(i₀, (PlainLeaves _))+                         = (f $ purgeRemotes (plvs, envi), True)+       +       twigProximæ :: PseudoAffineWitness x -> Interior x -> ShadeTree x -> TwigEnviron x+       twigProximæ sw x₀ (DisjointBranches _ djbs)+               = Hask.foldMap (\(i₀,st) -> first (+i₀) <$> twigProximæ sw x₀ st)+                    $ NE.zip ioffs djbs+        where ioffs = NE.scanl (\i -> (+i) . nLeaves) 0 djbs+       twigProximæ sw@(PseudoAffineWitness (SemimanifoldWitness _))+                          x₀ ct@(OverlappingBranches _ (Shade xb qb) brs)+                   = twigsaveTrim hither ct+        where Just δxb = x₀ .-~. xb+              hither (DBranch bdir (Hourglass bdc₁ bdc₂))+                =  ((guard (overlap > -1)) >> twigProximæ sw x₀ bdc₁)+                ++ ((guard (overlap < 1)) >> first (+nLeaves bdc₁)<$>twigProximæ sw x₀ bdc₂)+               where overlap = bdir<.>^δxb+       twigProximæ _ _ plainLeaves = [(0, plainLeaves)]+       +       twigsaveTrim :: (DBranch x -> TwigEnviron x) -> ShadeTree x -> TwigEnviron x+       twigsaveTrim f ct@(OverlappingBranches _ _ dbs)+                 = case Hask.mapM (\(i₀,dbr) -> noLeaf $ first(+i₀)<$>f dbr)+                                 $ NE.zip ioffs dbs of+                      Just pqe -> Hask.fold pqe+                      _        -> [(0,ct)]+        where noLeaf [(_,PlainLeaves _)] = empty+              noLeaf bqs = pure bqs+              ioffs = NE.scanl (\i -> (+i) . sum . fmap nLeaves . toList) 0 dbs+       +       purgeRemotes :: (Twig x, TwigEnviron x) -> (Twig x, TwigEnviron x)+       purgeRemotes = id -- See 7d1f3a4 for the implementation; this didn't work reliable. +    +completeTopShading :: ∀ x y . ( WithField ℝ PseudoAffine x, WithField ℝ PseudoAffine y+                              , SimpleSpace (Needle x), SimpleSpace (Needle y) )+                   => x`Shaded`y -> [Shade' (x,y)]+completeTopShading (PlainLeaves plvs) = case ( dualSpaceWitness :: DualNeedleWitness x+                                             , dualSpaceWitness :: DualNeedleWitness y ) of+       (DualSpaceWitness, DualSpaceWitness)+          -> pointsShade's . catMaybes+               $ toInterior . (_topological &&& _untopological) <$> plvs+completeTopShading (DisjointBranches _ bqs)+                     = take 1 . completeTopShading =<< NE.toList bqs+completeTopShading t = case ( dualSpaceWitness :: DualNeedleWitness x+                            , dualSpaceWitness :: DualNeedleWitness y ) of+       (DualSpaceWitness, DualSpaceWitness)+          -> pointsCover's . catMaybes+                . map (toInterior <<< _topological &&& _untopological) $ onlyLeaves t+++transferAsNormsDo :: ∀ v . LSpace v => Norm v -> Variance v -> v-+>v+transferAsNormsDo = case dualSpaceWitness :: DualSpaceWitness v of+                      DualSpaceWitness -> \(Norm m) (Norm n) -> n . m++flexTopShading :: ∀ x y f . ( WithField ℝ Manifold x, WithField ℝ Manifold y+                            , SimpleSpace (Needle x), SimpleSpace (Needle y)+                            , Applicative f (->) (->) )+                  => (Shade' (x,y) -> f (x, (Shade' y, LocalLinear x y)))+                      -> x`Shaded`y -> f (x`Shaded`y)+flexTopShading f tr = seq (assert_onlyToplevDisjoint tr)+                    $ recst (dualSpaceWitness::DualNeedleWitness x+                            ,dualSpaceWitness::DualNeedleWitness y+                            ,pseudoAffineWitness::PseudoAffineWitness y)+                            (completeTopShading tr) tr+ where recst _ qsh@(_:_) (DisjointBranches n bqs)+          = undefined -- DisjointBranches n $ NE.zipWith (recst . (:[])) (NE.fromList qsh) bqs+       recst (DualSpaceWitness,DualSpaceWitness,PseudoAffineWitness (SemimanifoldWitness _))+               [sha@(Shade' (_,yc₀) expa₀)] t = fmap fts $ f sha+        where expa'₀ = dualNorm expa₀+              j₀ :: LocalLinear x y+              j₀ = dependence expa'₀+              (_,expay₀) = summandSpaceNorms expa₀+              fts (xc, (Shade' yc expay, jtg)) = unsafeFmapLeaves applδj t+               where Just δyc = yc.-~.yc₀+                     tfm = transferAsNormsDo expay₀ (dualNorm expay)+                     applδj (WithAny y x)+                           = WithAny (yc₀ .+~^ ((tfm $ δy) ^+^ (jtg $ δx) ^+^ δyc)) x+                      where Just δx = x.-~.xc+                            Just δy = y.-~.(yc₀.+~^(j₀ $ δx))+       +       assert_onlyToplevDisjoint, assert_connected :: x`Shaded`y -> ()+       assert_onlyToplevDisjoint (DisjointBranches _ dp) = rnf (assert_connected<$>dp)+       assert_onlyToplevDisjoint t = assert_connected t+       assert_connected (OverlappingBranches _ _ dp)+           = rnf (Hask.foldMap assert_connected<$>dp)+       assert_connected (PlainLeaves _) = ()++flexTwigsShading :: ∀ x y f . ( WithField ℝ Manifold x, WithField ℝ Manifold y+                              , SimpleSpace (Needle x), SimpleSpace (Needle y)+                              , Hask.Applicative f )+                  => (Shade' (x,y) -> f (x, (Shade' y, LocalLinear x y)))+                      -> x`Shaded`y -> f (x`Shaded`y)+flexTwigsShading f = traverseTwigsWithEnvirons locFlex+ where locFlex :: ∀ μ . ((Int, x`Shaded`y), μ) -> f (x`Shaded`y)+       locFlex ((_,lsh), _) = flexTopShading f lsh+                +++seekPotentialNeighbours :: ∀ x . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x))+                => ShadeTree x -> x`Shaded`[Int]+seekPotentialNeighbours tree = zipTreeWithList tree+                     $ snd<$>leavesWithPotentialNeighbours tree++leavesWithPotentialNeighbours :: ∀ x . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x))+                => ShadeTree x -> [(x, [Int])]+leavesWithPotentialNeighbours = map (second snd) . go pseudoAffineWitness 0 0 []+ where go :: PseudoAffineWitness x -> Depth -> Int -> [Wall x] -> ShadeTree x+                -> [(x, ([Wall x], [Int]))]+       go (PseudoAffineWitness (SemimanifoldWitness _)) depth n₀ walls (PlainLeaves lvs)+               = [ (x, ( [ wall & wallDistance .~ d+                         | wall <- walls+                         , Just vw <- [toInterior x>>=(.-~.wall^.wallAnchor)]+                         , let d = (wall^.wallNormal)<.>^vw+                         , d < wall^.wallDistance ]+                       , [] ))+                 | x <- lvs ]+       go pw depth n₀ walls (DisjointBranches _ dp)+         = snd (foldl' (\(n₀',prev) br -> ( n₀'+nLeaves br+                                          , prev . (go pw depth n₀' walls br++)))+                        (n₀,id) dp) []+       go pw@(PseudoAffineWitness (SemimanifoldWitness _))+               depth n₀ walls (OverlappingBranches _ (Shade brCtr _) dp)+         = reassemble $ snd+             (foldl' assignWalls (n₀,id) . directionIChoices 0 $ NE.toList dp) []+        where assignWalls :: (Int, DList (x, ([Wall x],[Int])))+                     -> ((Int,(Needle' x, ShadeTree x)), [(Int,(Needle' x, ShadeTree x))])+                     -> (Int, DList (x, ([Wall x], [Int])))+              assignWalls (n₀',prev) ((iDir,(thisDir,br)),otherDirs)+                    = ( n₀'+nLeaves br+                      , prev . (go pw (depth+1) n₀'+                                   (newWalls ++ (updWall<$>walls))+                                   br ++) )+               where newWalls = [ Wall (depth,(iDir,iDir'))+                                       brCtr+                                       (thisDir^-^otherDir)+                                       (1/0)+                                | (iDir',(otherDir,_)) <- otherDirs ]+                     updWall wall = wall & wallDistance %~ min bcDist+                      where Just vbw = brCtr.-~.wall^.wallAnchor+                            bcDist = (wall^.wallNormal)<.>^vbw+              reassemble :: [(x, ([Wall x],[Int]))] -> [(x, ([Wall x],[Int]))]+              reassemble pts = [ (x, (higherWalls, newGroups++deeperGroups))+                               | (x, (allWalls, deeperGroups)) <- pts+                               , let (levelWalls,higherWalls)+                                      = break ((<depth) . fst . _wallID) allWalls+                                     newGroups = concat+                                         [ Map.findWithDefault []+                                              (wall^.wallID._2.swapped) groups+                                         | wall <- levelWalls ]+                               ]+               where groups = ($[]) <$> Map.fromListWith (.)+                               [ (wall^.wallID._2, (i:))+                               | (i,(_, (gsc,_))) <- zip [n₀..] pts+                               , wall <- takeWhile ((==depth) . fst . _wallID) gsc ]+++++++newtype BaryCoords n = BaryCoords { getBaryCoordsTail :: FreeVect n ℝ }++instance (KnownNat n) => AffineSpace (BaryCoords n) where+  type Diff (BaryCoords n) = FreeVect n ℝ+  BaryCoords v .-. BaryCoords w = v ^-^ w+  BaryCoords v .+^ w = BaryCoords $ v ^+^ w+instance (KnownNat n) => Semimanifold (BaryCoords n) where+  type Needle (BaryCoords n) = FreeVect n ℝ+  fromInterior = id+  toInterior = pure+  translateP = Tagged (.+~^)+  (.+~^) = (.+^)+  semimanifoldWitness = undefined+instance (KnownNat n) => PseudoAffine (BaryCoords n) where+  (.-~.) = pure .: (.-.)++getBaryCoords :: BaryCoords n -> ℝ ^ S n+getBaryCoords (BaryCoords (FreeVect bcs)) = FreeVect $ (1 - Arr.sum bcs) `Arr.cons` bcs+  +getBaryCoords' :: BaryCoords n -> [ℝ]+getBaryCoords' (BaryCoords (FreeVect bcs)) = 1 - Arr.sum bcs : Arr.toList bcs++getBaryCoord :: BaryCoords n -> Int -> ℝ+getBaryCoord (BaryCoords (FreeVect bcs)) 0 = 1 - Arr.sum bcs+getBaryCoord (BaryCoords (FreeVect bcs)) i = case bcs Arr.!? i of+    Just a -> a+    _      -> 0++mkBaryCoords :: KnownNat n => ℝ ^ S n -> BaryCoords n+mkBaryCoords (FreeVect bcs) = BaryCoords $ FreeVect (Arr.tail bcs) ^/ Arr.sum bcs++newtype ISimplex n x = ISimplex { iSimplexBCCordEmbed :: Embedding (->) (BaryCoords n) x }+++++data TriangBuilder n x where+  TriangVerticesSt :: [x] -> TriangBuilder Z x+  TriangBuilder :: Triangulation (S n) x+                    -> [x]+                    -> [(Simplex n x, [x] -> Maybe x)]+                            -> TriangBuilder (S n) x++++              +bottomExtendSuitability :: (KnownNat n, WithField ℝ Manifold x)+                => ISimplex (S n) x -> x -> ℝ+bottomExtendSuitability (ISimplex emb) x = case getBaryCoord (emb >-$ x) 0 of+     0 -> 0+     r -> - recip r++optimalBottomExtension :: (KnownNat n, WithField ℝ Manifold x)+                => ISimplex (S n) x -> [x] -> Maybe Int+optimalBottomExtension s xs+      = case filter ((>0).snd)+               $ zipWith ((. bottomExtendSuitability s) . (,)) [0..] xs of+             [] -> empty+             qs -> pure . fst . maximumBy (comparing snd) $ qs+++++iSimplexSideViews :: ∀ n x . KnownNat n => ISimplex n x -> [ISimplex n x]+iSimplexSideViews = \(ISimplex is)+              -> take (n+1) $ [ISimplex $ rot j is | j<-[0..] ]+ where rot j (Embedding emb proj)+            = Embedding ( emb . mkBaryCoords . freeRotate j     . getBaryCoords        )+                        (       mkBaryCoords . freeRotate (n-j) . getBaryCoords . proj )+       (Tagged n) = theNatN :: Tagged n Int+++type FullTriang t n x = TriangT t n x+          (State (Map.Map (SimplexIT t n x) (ISimplex n x)))++type TriangBuild t n x = TriangT t (S n) x+          ( State (Map.Map (SimplexIT t n x) (Metric x, ISimplex (S n) x) ))++doTriangBuild :: KnownNat n => (∀ t . TriangBuild t n x ()) -> [Simplex (S n) x]+doTriangBuild t = runIdentity (fst <$>+  doTriangT (unliftInTriangT (`evalStateT`mempty) t >> simplexITList >>= mapM lookSimplex))+++++++++data AutoTriang n x where+  AutoTriang :: { getAutoTriang :: ∀ t . TriangBuild t n x () } -> AutoTriang (S n) x++++breakdownAutoTriang :: ∀ n n' x . (KnownNat n', n ~ S n') => AutoTriang n x -> [Simplex n x]+breakdownAutoTriang (AutoTriang t) = doTriangBuild t+         +                    +   +   +   +       ++ +partitionsOfFstLength :: Int -> [a] -> [([a],[a])]+partitionsOfFstLength 0 l = [([],l)]+partitionsOfFstLength n [] = []+partitionsOfFstLength n (x:xs) = ( first (x:) <$> partitionsOfFstLength (n-1) xs )+                              ++ ( second (x:) <$> partitionsOfFstLength n xs )++splxVertices :: Simplex n x -> [x]+splxVertices (ZS x) = [x]+splxVertices (x :<| s') = x : splxVertices s'++++++++-- |+-- @+-- 'SimpleTree' x &#x2245; Maybe (x, 'Trees' x)+-- @+type SimpleTree = GenericTree Maybe []+-- |+-- @+-- 'Trees' x &#x2245; [(x, 'Trees' x)]+-- @+type Trees = GenericTree [] []+-- |+-- @+-- 'NonEmptyTree' x &#x2245; (x, 'Trees' x)+-- @+type NonEmptyTree = GenericTree NonEmpty []+    +newtype GenericTree c b x = GenericTree { treeBranches :: c (x,GenericTree b b x) }+ deriving (Generic, Hask.Functor, Hask.Foldable, Hask.Traversable)+instance (NFData x, Hask.Foldable c, Hask.Foldable b) => NFData (GenericTree c b x) where+  rnf (GenericTree t) = rnf $ toList t+instance (Hask.MonadPlus c) => Semigroup (GenericTree c b x) where+  GenericTree b1 <> GenericTree b2 = GenericTree $ Hask.mplus b1 b2+instance (Hask.MonadPlus c) => Monoid (GenericTree c b x) where+  mempty = GenericTree Hask.mzero+  mappend = (<>)+deriving instance Show (c (x, GenericTree b b x)) => Show (GenericTree c b x)++-- | Imitate the specialised 'ShadeTree' structure with a simpler, generic tree.+onlyNodes :: ∀ x . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x))+                => ShadeTree x -> Trees x+onlyNodes (PlainLeaves []) = GenericTree []+onlyNodes (PlainLeaves ps) = let (ctr,_) = pseudoECM ([]::[x]) $ NE.fromList ps+                             in GenericTree [ (ctr, GenericTree $ (,mempty) <$> ps) ]+onlyNodes (DisjointBranches _ brs) = Hask.foldMap onlyNodes brs+onlyNodes (OverlappingBranches _ (Shade ctr _) brs)+              = GenericTree [ ( fromInterior ctr+                              , Hask.foldMap (Hask.foldMap onlyNodes) brs ) ]+++-- | Left (and, typically, also right) inverse of 'fromLeafNodes'.+onlyLeaves :: WithField ℝ PseudoAffine x => ShadeTree x -> [x]+onlyLeaves tree = dismantle tree []+ where dismantle (PlainLeaves xs) = (xs++)+       dismantle (OverlappingBranches _ _ brs)+              = foldr ((.) . dismantle) id $ Hask.foldMap (Hask.toList) brs+       dismantle (DisjointBranches _ brs) = foldr ((.) . dismantle) id $ NE.toList brs+++++++++data Sawbones x = Sawbones { sawnTrunk1, sawnTrunk2 :: [x]->[x]+                           , sawdust1,   sawdust2   :: [x]      }+instance Semigroup (Sawbones x) where+  Sawbones st11 st12 sd11 sd12 <> Sawbones st21 st22 sd21 sd22+     = Sawbones (st11.st21) (st12.st22) (sd11<>sd21) (sd12<>sd22)+instance Monoid (Sawbones x) where+  mempty = Sawbones id id [] []+  mappend = (<>)++++type DList x = [x]->[x]+    +data DustyEdges x = DustyEdges { sawChunk :: DList x, chunkDust :: DBranches' x [x] }+instance Semigroup (DustyEdges x) where+  DustyEdges c1 d1 <> DustyEdges c2 d2 = DustyEdges (c1.c2) (d1<>d2)++data Sawboneses x = SingleCut (Sawbones x)+                  | Sawboneses (DBranches' x (DustyEdges x))+    deriving (Generic)+instance Semigroup (Sawboneses x) where+  SingleCut c <> SingleCut d = SingleCut $ c<>d+  Sawboneses c <> Sawboneses d = Sawboneses $ c<>d+++++++-- | 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 { _untopological :: y+                , _topological :: !x  }+ deriving (Hask.Functor, Show, 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+  type Interior (WithAny x y) = Interior x `WithAny` y+  WithAny y x .+~^ δx = WithAny y $ x.+~^δx+  fromInterior (WithAny y x) = WithAny y $ fromInterior x+  toInterior (WithAny y x) = fmap (WithAny y) $ toInterior x+  translateP = tpWD+   where tpWD :: ∀ x y . Semimanifold x => Tagged (WithAny x y)+                            (Interior x`WithAny`y -> Needle x -> Interior x`WithAny`y)+         tpWD = Tagged `id` \(WithAny y x) δx -> WithAny y $ tpx x δx+          where Tagged tpx = translateP :: Tagged x (Interior x -> Needle x -> Interior x)+  semimanifoldWitness = case semimanifoldWitness :: SemimanifoldWitness x of+      SemimanifoldWitness BoundarylessWitness -> SemimanifoldWitness BoundarylessWitness+            +instance (PseudoAffine x) => PseudoAffine (x`WithAny`y) where+  WithAny _ x .-~. WithAny _ ξ = x.-~.ξ+  pseudoAffineWitness = case pseudoAffineWitness :: PseudoAffineWitness x of+      PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness)+       -> PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness)++instance (AffineSpace x) => AffineSpace (x`WithAny`y) where+  type Diff (WithAny x y) = Diff x+  WithAny _ x .-. WithAny _ ξ = x.-.ξ+  WithAny y x .+^ δx = WithAny y $ x.+^δx ++instance (VectorSpace x, Monoid y) => VectorSpace (x`WithAny`y) where+  type Scalar (WithAny x y) = Scalar x+  μ *^ WithAny y x = WithAny y $ μ*^x ++instance (AdditiveGroup x, Monoid y) => AdditiveGroup (x`WithAny`y) where+  zeroV = WithAny mempty zeroV+  negateV (WithAny y x) = WithAny y $ negateV x+  WithAny y x ^+^ WithAny υ ξ = WithAny (mappend y υ) (x^+^ξ)++instance (AdditiveGroup x) => Hask.Applicative (WithAny x) where+  pure x = WithAny x zeroV+  WithAny f x <*> WithAny t ξ = WithAny (f t) (x^+^ξ)+  +instance (AdditiveGroup x) => Hask.Monad (WithAny x) where+  return x = WithAny x zeroV+  WithAny y x >>= f = WithAny r $ x^+^q+   where WithAny r q = f y++shadeWithAny :: y -> Shade x -> Shade (x`WithAny`y)+shadeWithAny y (Shade x xe) = Shade (WithAny y x) xe++shadeWithoutAnything :: Shade (x`WithAny`y) -> Shade x+shadeWithoutAnything (Shade (WithAny _ b) e) = Shade b e++constShaded :: y -> ShadeTree x -> x`Shaded`y+constShaded y = unsafeFmapTree (WithAny y<$>) id (shadeWithAny y)++stripShadedUntopological :: x`Shaded`y -> ShadeTree x+stripShadedUntopological = unsafeFmapTree (fmap _topological) id shadeWithoutAnything++fmapShaded :: (y -> υ) -> (x`Shaded`y) -> (x`Shaded`υ)+fmapShaded f = unsafeFmapTree (fmap $ \(WithAny y x) -> WithAny (f y) x)+                              id+                              (\(Shade yx shx) -> Shade (fmap f yx) shx)++joinShaded :: (x`WithAny`y)`Shaded`z -> x`Shaded`(y,z)+joinShaded = unsafeFmapTree (fmap $ \(WithAny z (WithAny y x)) -> WithAny (y,z) x)+                            id+                            (\(Shade (WithAny z (WithAny y x)) shx)+                                  -> Shade (WithAny (y,z) x) shx )++zipTreeWithList :: ShadeTree x -> [y] -> (x`Shaded`y)+zipTreeWithList tree = go tree . cycle+ where go (PlainLeaves lvs) ys = PlainLeaves $ zipWith WithAny ys lvs+       go (DisjointBranches n brs) ys+             = DisjointBranches n . NE.fromList+                  $ snd (foldl (\(ys',prev) br -> +                                    (drop (nLeaves br) ys', prev . (go br ys':)) )+                           (ys,id) $ NE.toList brs) []+       go (OverlappingBranches n (Shade xoc shx) brs) ys+             = OverlappingBranches n (Shade (WithAny (head ys) xoc) shx) . NE.fromList+                  $ snd (foldl (\(ys',prev) (DBranch dir (Hourglass top bot))+                        -> case drop (nLeaves top) ys' of+                              ys'' -> ( drop (nLeaves bot) ys''+                                      , prev . (DBranch dir (Hourglass (go top ys')+                                                                       (go bot ys'')):)+                                      ) )+                           (ys,id) $ NE.toList brs) []++-- | This is to 'ShadeTree' as 'Data.Map.Map' is to 'Data.Set.Set'.+type x`Shaded`y = ShadeTree (x`WithAny`y)++stiWithDensity :: ∀ x y . ( WithField ℝ PseudoAffine x, WithField ℝ LinearManifold y+                          , SimpleSpace (Needle x) )+         => x`Shaded`y -> x -> Cℝay y+stiWithDensity (PlainLeaves lvs)+  | [Shade baryc expa :: Shade x] <- pointsShades . catMaybes +                                       $ toInterior . _topological <$> lvs+       = let nlvs = fromIntegral $ length lvs :: ℝ+             indiShapes = [(Shade pi expa, y) | WithAny y p <- lvs+                                              , Just pi <- [toInterior p]]+         in \x -> let lcCoeffs = [ occlusion psh x | (psh, _) <- indiShapes ]+                      dens = sum lcCoeffs+                  in mkCone dens . linearCombo . zip (snd<$>indiShapes)+                       $ (/dens)<$>lcCoeffs+stiWithDensity (DisjointBranches _ lvs)+           = \x -> foldr1 qGather $ (`stiWithDensity`x)<$>lvs+ where qGather (Cℝay 0 _) o = o+       qGather o _ = o+stiWithDensity (OverlappingBranches n (Shade (WithAny _ bc) extend) brs)+           = ovbSWD (dualSpaceWitness, pseudoAffineWitness)+ where ovbSWD :: (DualNeedleWitness x, PseudoAffineWitness x) -> x -> Cℝay y+       ovbSWD (DualSpaceWitness, PseudoAffineWitness (SemimanifoldWitness _)) x+                     = case toInterior x>>=(.-~.bc) of+           Just v+             | dist² <- normSq ε v+             , dist² < 9+             , att <- exp(1/(dist²-9)+1/9)+               -> qGather att $ fmap ($ x) downPrepared+           _ -> coneTip+       ε = dualNorm' extend :: Norm (Needle x)+       downPrepared = dp =<< brs+        where dp (DBranch _ (Hourglass up dn))+                 = fmap stiWithDensity $ up:|[dn]+       qGather att contribs = mkCone (att*dens)+                 $ linearCombo [(v, d/dens) | Cℝay d v <- NE.toList contribs]+        where dens = sum (hParamCℝay <$> contribs)++stiAsIntervalMapping :: (x ~ ℝ, y ~ ℝ)+            => x`Shaded`y -> [(x, ((y, Diff y), LinearMap ℝ x y))]+stiAsIntervalMapping = twigsWithEnvirons >=> pure.snd.fst >=> completeTopShading >=> pure.+             \(Shade' (xloc, yloc) shd)+                 -> ( xloc, ( (yloc, recip $ shd|$|(0,1))+                            , dependence (dualNorm shd) ) )++smoothInterpolate :: ∀ x y . ( WithField ℝ Manifold x, WithField ℝ LinearManifold y+                             , SimpleSpace (Needle x) )+             => NonEmpty (x,y) -> x -> y+smoothInterpolate = si boundarylessWitness+ where si :: BoundarylessWitness x -> NonEmpty (x,y) -> x -> y+       si BoundarylessWitness l = \x ->+             case ltr x of+               Cℝay 0 _ -> defy+               Cℝay _ y -> y+        where defy = linearCombo [(y, 1/n) | WithAny y _ <- l']+              n = fromIntegral $ length l'+              l' = (uncurry WithAny . swap) <$> NE.toList l+              ltr = stiWithDensity $ fromLeafPoints l'+++spanShading :: ∀ x y . ( WithField ℝ Manifold x, WithField ℝ Manifold y+                       , SimpleSpace (Needle x), SimpleSpace (Needle y) )+          => (Shade x -> Shade y) -> ShadeTree x -> x`Shaded`y+spanShading f = unsafeFmapTree addYs id addYSh+ where addYs :: NonEmpty x -> NonEmpty (x`WithAny`y)+       addYs l = foldr (NE.<|) (fmap (WithAny $ fromInterior ymid) l     )+                               (fmap (`WithAny` fromInterior xmid) yexamp)+          where [xsh@(Shade xmid _)] = pointsCovers . catMaybes . toList+                                           $ toInterior<$>l+                Shade ymid yexpa = f xsh+                yexamp = [ ymid .+~^ σ*^δy+                         | δy <- varianceSpanningSystem yexpa, σ <- [-1,1] ]+       addYSh :: Shade x -> Shade (x`WithAny`y)+       addYSh xsh = shadeWithAny (fromInterior . _shadeCtr $ f xsh) xsh+                      +++coneTip :: (AdditiveGroup v) => Cℝay v+coneTip = Cℝay 0 zeroV++mkCone :: AdditiveGroup v => ℝ -> v -> Cℝay v+mkCone 0 _ = coneTip+mkCone h v = Cℝay h v+++foci :: [a] -> [(a,[a])]+foci [] = []+foci (x:xs) = (x,xs) : fmap (second (x:)) (foci xs)+       +fociNE :: NonEmpty a -> NonEmpty (a,[a])+fociNE (x:|xs) = (x,xs) :| fmap (second (x:)) (foci xs)+       ++(.:) :: (c->d) -> (a->b->c) -> a->b->d +(.:) = (.) . (.)+   

@@ -68,7 +68,6 @@ import Data.Basis import Data.Fixed import Data.Tagged-import Data.Semigroup import qualified Data.Vector.Generic as Arr import qualified Data.Vector import qualified Data.Vector.Unboxed as UArr@@ -164,9 +163,11 @@  deriveAffine((FiniteFreeSpace v, UArr.Unbox (Scalar v)), Stiefel1Needle v) -instance ∀ v . (FiniteFreeSpace v, UArr.Unbox (Scalar v))+instance ∀ v . (LSpace v, FiniteFreeSpace v, UArr.Unbox (Scalar v))               => TensorSpace (Stiefel1Needle v) where   type TensorProduct (Stiefel1Needle v) w = Array w+  scalarSpaceWitness = case scalarSpaceWitness :: ScalarSpaceWitness v of+         ScalarSpaceWitness -> ScalarSpaceWitness   zeroTensor = Tensor $ Arr.replicate (freeDimension ([]::[v]) - 1) zeroV   toFlatTensor = LinearFunction $ Tensor . Arr.convert . getStiefel1Tangent   fromFlatTensor = LinearFunction $ Stiefel1Needle . Arr.convert . getTensorProduct@@ -176,29 +177,39 @@   tensorProduct = bilinearFunction $ \(Stiefel1Needle n) w                         -> Tensor $ Arr.map (*^w) $ Arr.convert n   transposeTensor = LinearFunction $ \(Tensor a) -> Arr.foldl' (^+^) zeroV-       $ Arr.imap ( \i w -> (tensorProduct $ w) $ Stiefel1Needle+       $ Arr.imap ( \i w -> (getLinearFunction tensorProduct w) $ Stiefel1Needle                              $ UArr.generate d (\j -> if i==j then 1 else 0) ) a    where d = freeDimension ([]::[v]) - 1   fmapTensor = bilinearFunction $ \f (Tensor a) -> Tensor $ Arr.map (f$) a   fzipTensorWith = bilinearFunction $ \f (Tensor a, Tensor b)                      -> Tensor $ Arr.zipWith (curry $ arr f) a b   coerceFmapTensorProduct _ Coercion = Coercion++asTensor :: Coercion (LinearMap s a b) (Tensor s (DualVector a) b)+asTensor = Coercion+asLinearMap :: Coercion (Tensor s (DualVector a) b) (LinearMap s a b)+asLinearMap = Coercion+infixr 0 +$>+(+$>) :: (LinearSpace a, TensorSpace b, Scalar a ~ s, Scalar b ~ s)+            => LinearMap s a b -> a -> b+(+$>) = getLinearFunction . getLinearFunction applyLinear   -instance ∀ v . (FiniteFreeSpace v, UArr.Unbox (Scalar v), Num''' (Scalar v))+instance ∀ v . (LSpace v, FiniteFreeSpace v, UArr.Unbox (Scalar v))               => LinearSpace (Stiefel1Needle v) where   type DualVector (Stiefel1Needle v) = Stiefel1Needle v   linearId = LinearMap . Arr.generate d $ \i -> Stiefel1Needle . Arr.generate d $                                            \j -> if i==j then 1 else 0    where d = freeDimension ([]::[v]) - 1+  tensorId = ti dualSpaceWitness+   where ti :: ∀ w . (LinearSpace w, Scalar w ~ Scalar v)+           => DualSpaceWitness w -> (Stiefel1Needle v ⊗ w) +> (Stiefel1Needle v ⊗ w)+         ti DualSpaceWitness = LinearMap . Arr.generate d+           $ \i -> fmap (LinearFunction $ \w -> Tensor . Arr.generate d $+              \j -> if i==j then w else zeroV) $ asTensor $ id+         d = freeDimension ([]::[v]) - 1+  dualSpaceWitness = case dualSpaceWitness :: DualSpaceWitness v of+         DualSpaceWitness -> DualSpaceWitness   coerceDoubleDual = Coercion-  blockVectSpan = LinearFunction $ \w -> Tensor . Arr.generate d -                                  $ \i -> LinearMap . Arr.generate d-                                   $ \j -> if i==j then w else zeroV-   where d = freeDimension ([]::[v]) - 1-  blockVectSpan'= LinearFunction $ \w -> LinearMap . Arr.generate d -                                  $ \i -> Tensor . Arr.generate d-                                   $ \j -> if i==j then w else zeroV-   where d = freeDimension ([]::[v]) - 1   contractTensorMap = LinearFunction $ \(LinearMap m)                         -> Arr.ifoldl' (\acc i (Tensor t) -> acc ^+^ t Arr.! i) zeroV m   contractMapTensor = LinearFunction $ \(Tensor m)@@ -210,56 +221,70 @@                         -> UArr.sum $ UArr.zipWith (*) v w   applyLinear = bilinearFunction $ \(LinearMap m) (Stiefel1Needle v)                         -> Arr.ifoldl' (\acc i w -> acc ^+^ v UArr.! i *^ w) zeroV m-  composeLinear = bilinearFunction $ \f (LinearMap g) -> LinearMap $ Arr.map (f$) g+  applyTensorFunctional = bilinearFunction $ \(LinearMap f) (Tensor t)+                           -> Arr.ifoldl' (\acc i u -> acc + u <.>^ t Arr.! i) 0 f+  applyTensorLinMap = bilinearFunction $ \(LinearMap f) (Tensor t)+         -> Arr.ifoldl' (\w i u -> w ^+^ ((asLinearMap $ f Arr.! i) +$> u)) zeroV t+  composeLinear = bilinearFunction $ \f (LinearMap g)+                     -> LinearMap $ Arr.map (getLinearFunction applyLinear f$) g -instance ( WithField k LinearManifold v, FiniteFreeSpace v, FiniteFreeSpace (DualVector v)-         , RealFloat k, UArr.Unbox k-         ) => Semimanifold (Stiefel1 v) where +instance ∀ k v .+   ( WithField k LinearManifold v, FiniteFreeSpace v, FiniteFreeSpace (DualVector v)+   , RealFloat k, UArr.Unbox k ) => Semimanifold (Stiefel1 v) where    type Needle (Stiefel1 v) = Stiefel1Needle v   fromInterior = id   toInterior = pure   translateP = Tagged (.+~^)-  Stiefel1 s .+~^ Stiefel1Needle n = Stiefel1 . unsafeFromFullUnboxVect . uarrScale (signum s'i)-   $ if| ν==0      -> s' -- ν'≡0 is a special case of this, so we can otherwise assume ν'>0.-       | ν<=2      -> let m = uarrScale ιmν spro `uarrAdd` uarrScale ((1-abs ιmν)/ν') n-                          ιmν = 1-ν -                      in insi ιmν m-       | otherwise -> let m = uarrScale ιmν spro `uarrAdd` uarrScale ((abs ιmν-1)/ν') n-                          ιmν = ν-3-                      in insi ιmν m-   where d = UArr.length s'-         s'= toFullUnboxVect s-         ν' = l2norm n-         quop = signum s'i / ν'-         ν = ν' `mod'` 4-         im = UArr.maxIndex $ UArr.map abs s'-         s'i = s' UArr.! im-         spro = let v = deli s' in uarrScale (recip s'i) v-         deli v = Arr.take im v Arr.++ Arr.drop (im+1) v-         insi ti v = Arr.generate d $ \i -> if | i<im      -> v Arr.! i-                                               | i>im      -> v Arr.! (i-1) -                                               | otherwise -> ti-instance ( WithField k LinearManifold v, FiniteFreeSpace v, FiniteFreeSpace (DualVector v)-         , RealFloat k, UArr.Unbox k-         ) => PseudoAffine (Stiefel1 v) where -  Stiefel1 s .-~. Stiefel1 t = pure . Stiefel1Needle $ case s' UArr.! im of-            0 -> uarrScale (recip $ l2norm delis) delis-            s'i | v <- uarrScale (recip s'i) delis `uarrSubtract` tpro-                , absv <- l2norm v-                , absv > 0-                       -> let μ = (signum (t'i/s'i) - recip(absv + 1)) / absv-                          in uarrScale μ v-                | t'i/s'i > 0  -> samePoint-                | otherwise    -> antipode-   where d = UArr.length t'-         s'= toFullUnboxVect s; t' = toFullUnboxVect t-         im = UArr.maxIndex $ UArr.map abs t'-         t'i = t' UArr.! im-         tpro = let v = deli t' in uarrScale (recip t'i) v-         delis = deli s'-         deli v = Arr.take im v Arr.++ Arr.drop (im+1) v-         samePoint = UArr.replicate (d-1) 0-         antipode = (d-1) `UArr.fromListN` (2 : repeat 0)+  (.+~^) = tpst dualSpaceWitness+   where tpst :: DualSpaceWitness v -> Stiefel1 v -> Stiefel1Needle v -> Stiefel1 v+         tpst DualSpaceWitness (Stiefel1 s) (Stiefel1Needle n)+             = Stiefel1 . unsafeFromFullUnboxVect . uarrScale (signum s'i)+          $ if| ν==0      -> s' -- ν'≡0 is a special case of this, so if not ν=0+                                --  we can otherwise assume ν'>0.+              | ν<=2      -> let m = uarrScale ιmν spro+                                       `uarrAdd` uarrScale ((1-abs ιmν)/ν') n+                                 ιmν = 1-ν +                             in insi ιmν m+              | otherwise -> let m = uarrScale ιmν spro+                                       `uarrAdd` uarrScale ((abs ιmν-1)/ν') n+                                 ιmν = ν-3+                             in insi ιmν m+          where d = UArr.length s'+                s'= toFullUnboxVect s+                ν' = l2norm n+                quop = signum s'i / ν'+                ν = ν' `mod'` 4+                im = UArr.maxIndex $ UArr.map abs s'+                s'i = s' UArr.! im+                spro = let v = deli s' in uarrScale (recip s'i) v+                deli v = Arr.take im v Arr.++ Arr.drop (im+1) v+                insi ti v = Arr.generate d $ \i -> if | i<im      -> v Arr.! i+                                                      | i>im      -> v Arr.! (i-1) +                                                      | otherwise -> ti+instance ∀ k v .+   ( WithField k LinearManifold v, FiniteFreeSpace v, FiniteFreeSpace (DualVector v)+   , RealFloat k, UArr.Unbox k ) => PseudoAffine (Stiefel1 v) where +  (.-~.) = dpst dualSpaceWitness+   where dpst :: DualSpaceWitness v -> Stiefel1 v -> Stiefel1 v -> Maybe (Stiefel1Needle v)+         dpst DualSpaceWitness (Stiefel1 s) (Stiefel1 t)+             = pure . Stiefel1Needle $ case s' UArr.! im of+                   0 -> uarrScale (recip $ l2norm delis) delis+                   s'i | v <- uarrScale (recip s'i) delis `uarrSubtract` tpro+                       , absv <- l2norm v+                       , absv > 0+                              -> let μ = (signum (t'i/s'i) - recip(absv + 1)) / absv+                                 in uarrScale μ v+                       | t'i/s'i > 0  -> samePoint+                       | otherwise    -> antipode+          where d = UArr.length t'+                s'= toFullUnboxVect s; t' = toFullUnboxVect t+                im = UArr.maxIndex $ UArr.map abs t'+                t'i = t' UArr.! im+                tpro = let v = deli t' in uarrScale (recip t'i) v+                delis = deli s'+                deli v = Arr.take im v Arr.++ Arr.drop (im+1) v+                samePoint = UArr.replicate (d-1) 0+                antipode = (d-1) `UArr.fromListN` (2 : repeat 0)   -- instance ( WithField ℝ HilbertManifold x ) => ConeSemimfd (Stiefel1 x) where@@ -288,48 +313,53 @@   -sideOfCut :: WithField ℝ Manifold x => Cutplane x -> x -> Option S⁰-sideOfCut (Cutplane sh (Stiefel1 cn)) p = decideSide . (cn<.>^) =<< p .-~. sh+sideOfCut :: (WithField ℝ PseudoAffine x, LinearSpace (Needle x))+                   => Cutplane x -> x -> Maybe S⁰+sideOfCut (Cutplane sh (Stiefel1 cn)) p+              = decideSide . (cn<.>^) =<< p.-~.sh  where decideSide 0 = mzero        decideSide μ | μ > 0      = pure PositiveHalfSphere                     | otherwise  = pure NegativeHalfSphere  -fathomCutDistance :: WithField ℝ Manifold x-        => Cutplane x            -- ^ Hyperplane to measure the distance from.-         -> Metric' x            -- ^ Metric to use for measuring that distance.-                                 --   This can only be accurate if the metric-                                 --   is valid both around the cut-plane's 'sawHandle', and-                                 --   around the points you measure.-                                 --   (Strictly speaking, we would need /parallel transport/-                                 --   to ensure this).-         -> x                    -- ^ Point to measure the distance to.-         -> Option ℝ             -- ^ A signed number, giving the distance from plane-                                 --   to point with indication on which side the point lies.-                                 --   'Nothing' if the point isn't reachable from the plane.-fathomCutDistance (Cutplane sh (Stiefel1 cn)) met = \x -> fmap fathom $ x .-~. sh- where fathom v = (cn <.>^ v) / scaleDist-       scaleDist = met|$|cn+fathomCutDistance :: ∀ x . (WithField ℝ PseudoAffine x, LinearSpace (Needle x))+        => Cutplane x        -- ^ Hyperplane to measure the distance from.+         -> Metric' x        -- ^ Metric to use for measuring that distance.+                             --   This can only be accurate if the metric+                             --   is valid both around the cut-plane's 'sawHandle', and+                             --   around the points you measure.+                             --   (Strictly speaking, we would need /parallel transport/+                             --   to ensure this).+         -> x                -- ^ Point to measure the distance to.+         -> Maybe ℝ          -- ^ A signed number, giving the distance from plane+                             --   to point with indication on which side the point lies.+                             --   'Nothing' if the point isn't reachable from the plane.+fathomCutDistance = fcd dualSpaceWitness+ where fcd (DualSpaceWitness :: DualSpaceWitness (Needle x))+           (Cutplane sh (Stiefel1 cn)) met+               = \x -> fmap fathom $ x .-~. sh+        where fathom v = (cn <.>^ v) / scaleDist+              scaleDist = met|$|cn            -cutPosBetween :: WithField ℝ Manifold x => Cutplane x -> (x,x) -> Option D¹+cutPosBetween :: WithField ℝ Manifold x => Cutplane x -> (x,x) -> Maybe D¹ cutPosBetween (Cutplane h (Stiefel1 cn)) (x₀,x₁)-    | Option (Just [d₀,d₁]) <- map (cn<.>^) <$> sequenceA [x₀.-~.h, x₁.-~.h]-    , d₀*d₁ < 0-                  = pure . D¹ $ d₁ / (d₁ - d₀)-    | otherwise   = empty+    | Just [d₀,d₁] <- map (cn<.>^) <$> sequenceA [x₀.-~.h, x₁.-~.h]+    , d₀*d₁ < 0  = pure . D¹ $ 2 * d₀ / (d₀ - d₁) - 1+    | otherwise  = empty  -lineAsPlaneIntersection ::+lineAsPlaneIntersection :: ∀ x .        (WithField ℝ Manifold x, FiniteDimensional (Needle' x))            => Line x -> [Cutplane x]-lineAsPlaneIntersection (Line h (Stiefel1 dir))-      = [ Cutplane h . Stiefel1-              $ candidate ^-^ worstCandidate ^* (overlap/worstOvlp)-        | (i, (candidate, overlap)) <- zip [0..] $ zip candidates overlaps-        , i /= worstId ]- where candidates = enumerateSubBasis entireBasis-       overlaps = (<.>^dir) <$> candidates-       (worstId, worstOvlp) = maximumBy (comparing $ abs . snd) $ zip [0..] overlaps-       worstCandidate = candidates !! worstId+lineAsPlaneIntersection = lapi dualSpaceWitness+ where lapi (DualSpaceWitness :: DualSpaceWitness (Needle x)) (Line h (Stiefel1 dir))+             = [ Cutplane h . Stiefel1+                     $ candidate ^-^ worstCandidate ^* (overlap/worstOvlp)+               | (i, (candidate, overlap)) <- zip [0..] $ zip candidates overlaps+               , i /= worstId ]+        where candidates = enumerateSubBasis entireBasis+              overlaps = (<.>^dir) <$> candidates+              (worstId, worstOvlp) = maximumBy (comparing $ abs . snd) $ zip [0..] overlaps+              worstCandidate = candidates !! worstId 

@@ -16,7 +16,7 @@  {-# LANGUAGE FlexibleInstances        #-} {-# LANGUAGE UndecidableInstances     #-}--- {-# LANGUAGE OverlappingInstances     #-}+{-# LANGUAGE ExplicitNamespaces       #-} {-# LANGUAGE TypeFamilies             #-} {-# LANGUAGE FunctionalDependencies   #-} {-# LANGUAGE FlexibleContexts         #-}@@ -48,7 +48,7 @@         , ℝay         , CD¹(..), Cℝay(..)         -- * Tensor products-        , (⊗)(..)+        , type (⊗)(..)         -- * Utility (deprecated)         , NaturallyEmbedded(..)         , GraphWindowSpec(..), Endomorphism, (^), (^.), EqFloating@@ -56,6 +56,8 @@    ) where  +import Math.Manifold.Core.Types+ import Data.VectorSpace import Data.VectorSpace.Free import Linear.V2@@ -65,11 +67,11 @@ import Data.Basis import Data.Void import Data.Monoid-import Math.LinearMap.Category ((⊗)())+import Math.LinearMap.Category (type (⊗)())  import Control.Applicative (Const(..), Alternative(..)) -import Lens.Micro ((^.))+import Control.Lens ((^.))  import qualified Prelude @@ -95,18 +97,7 @@   --- | The zero-dimensional sphere is actually just two points. Implementation might---   therefore change to @ℝ⁰ 'Control.Category.Constrained.+' ℝ⁰@: the disjoint sum of two---   single-point spaces.-data S⁰ = PositiveHalfSphere | NegativeHalfSphere deriving(Eq, Show) -otherHalfSphere :: S⁰ -> S⁰-otherHalfSphere PositiveHalfSphere = NegativeHalfSphere-otherHalfSphere NegativeHalfSphere = PositiveHalfSphere---- | The unit circle.-newtype S¹ = S¹ { φParamS¹ :: Double -- ^ Must be in range @[-π, π[@.-                } deriving (Show) -- | The ordinary unit sphere. data S² = S² { ϑParamS² :: !Double -- ^ Range @[0, π[@.              , φParamS² :: !Double -- ^ Range @[-π, π[@.@@ -114,9 +105,6 @@   --type ℝP¹ = S¹- -- | The two-dimensional real projective space, implemented as a unit disk with --   opposing points on the rim glued together. data ℝP² = ℝP² { rParamℝP² :: !Double -- ^ Range @[0, 1]@.@@ -125,15 +113,6 @@   --- | The &#x201c;one-dimensional disk&#x201d; &#x2013; really just the line segment between---   the two points -1 and 1 of 'S⁰', i.e. this is simply a closed interval.-newtype D¹ = D¹ { xParamD¹ :: Double -- ^ Range @[-1, 1]@.-                }-fromIntv0to1 :: ℝ -> D¹-fromIntv0to1 x | x<0        = D¹ (-1)-               | x>1        = D¹ 1-               | otherwise  = D¹ $ (x+1)/2- -- | The standard, closed unit disk. Homeomorphic to the cone over 'S¹', but not in the --   the obvious, &#x201c;flat&#x201d; way. (And not at all, despite --   the identical ADT definition, to the projective space 'ℝP²'!)@@ -149,7 +128,7 @@ --   special case @x = 'S¹'@. data CD¹ x = CD¹ { hParamCD¹ :: !Double -- ^ Range @[0, 1]@                  , pParamCD¹ :: !x      -- ^ Irrelevant at @h = 0@.-                 }+                 } deriving (Show)   -- | An open cone is homeomorphic to a closed cone without the &#x201c;lid&#x201d;,@@ -158,7 +137,7 @@ --   more natural to express it as the entire real ray, hence the name. data Cℝay x = Cℝay { hParamCℝay :: !Double -- ^ Range @[0, &#x221e;[@                    , pParamCℝay :: !x      -- ^ Irrelevant at @h = 0@.-                   }+                   } deriving (Show)   @@ -208,8 +187,6 @@ type Endomorphism a = a->a  -type ℝ = Double-type ℝ⁰ = ZeroDim ℝ type ℝ¹ = V1 ℝ type ℝ² = V2 ℝ type ℝ³ = V3 ℝ@@ -243,18 +220,6 @@ type OpenCone = Cℝay  --instance VectorSpace () where-  type Scalar () = ℝ-  _ *^ () = ()--instance HasBasis () where-  type Basis () = Void-  basisValue = absurd-  decompose () = []-  decompose' () = absurd-instance InnerSpace () where-  () <.> () = 0   infixr 8 ^

@@ -25,7 +25,6 @@  import Data.Maybe import qualified Data.Vector as Arr-import Data.Semigroup  import Data.VectorSpace import Data.AffineSpace

@@ -41,26 +41,32 @@             , nearestNeighbour, indexWeb, webEdges, toGraph               -- ** Decomposition             , sliceWeb_lin -- , sampleWebAlongLine_lin+            , sampleWeb_2Dcartesian_lin, sampleEntireWeb_2Dcartesian_lin               -- ** Local environments             , localFocusWeb+              -- * Uncertain functions+            , differentiateUncertainWebFunction               -- * Differential equations               -- ** Fixed resolution             , filterDEqnSolution_static, iterateFilterDEqn_static               -- ** Automatic resolution             , filterDEqnSolutions_adaptive, iterateFilterDEqn_adaptive+              -- ** Configuration+            , InconsistencyStrategy(..)               -- * Misc-            , ConvexSet(..), ellipsoid+            , ConvexSet(..), ellipsoid, coerceWebDomain             ) where  -import Data.List hiding (filter, all, elem, sum, foldr1)+import Data.List hiding (filter, all, foldr1) import Data.Maybe import qualified Data.Set as Set import qualified Data.Vector as Arr+import qualified Data.Vector.Mutable as MArr import qualified Data.Vector.Unboxed as UArr import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE-import Data.List.FastNub (fastNubBy)+import Data.List.FastNub (fastNub,fastNubBy) import Data.Ord (comparing) import Data.Semigroup import Control.DeepSeq@@ -82,8 +88,11 @@ import qualified Prelude as Hask hiding(foldl, sum, sequence) import qualified Control.Applicative as Hask import qualified Control.Monad       as Hask hiding(forM_, sequence)+import Control.Monad.ST (runST)+import Data.STRef (newSTRef, modifySTRef, readSTRef) import Control.Monad.Trans.State import Control.Monad.Trans.List+import Data.Functor.Identity (Identity(..)) import qualified Data.Foldable       as Hask import Data.Foldable (all, toList) import qualified Data.Traversable as Hask@@ -98,8 +107,8 @@ import Data.Traversable.Constrained (Traversable, traverse)  import Control.Comonad (Comonad(..))-import Lens.Micro ((&), (%~), (^.), (.~))-import Lens.Micro.TH+import Control.Lens ((&), (%~), (^.), (.~), (+~))+import Control.Lens.TH  import GHC.Generics (Generic) @@ -107,11 +116,36 @@ type WebNodeId = Int  data Neighbourhood x = Neighbourhood {-     neighbours :: UArr.Vector WebNodeId-   , localScalarProduct :: Metric x+     _neighbours :: UArr.Vector WebNodeId+   , _localScalarProduct :: Metric x    }   deriving (Generic)+makeLenses ''Neighbourhood +deriving instance ( WithField ℝ PseudoAffine x+                  , SimpleSpace (Needle x), Show (Needle' x) )+             => Show (Neighbourhood x)++data WebLocally x y = LocalWebInfo {+      _thisNodeCoord :: x+    , _thisNodeData :: y+    , _thisNodeId :: WebNodeId+    , _nodeNeighbours :: [(WebNodeId, (Needle x, WebLocally x y))]+    , _nodeLocalScalarProduct :: Metric x+    , _nodeIsOnBoundary :: Bool+    } deriving (Generic)+makeLenses ''WebLocally++data NeighbourhoodVector x = NeighbourhoodVector+          { _nvectId :: Int+          , _theNVect :: Needle x+          , _nvectNormal :: Needle' x+          , _nvectLength :: Scalar (Needle x)+          , _otherNeighboursOverlap :: Scalar (Needle x)+          }+makeLenses ''NeighbourhoodVector++ instance (NFData x, NFData (Metric x)) => NFData (Neighbourhood x)  -- | A 'PointsWeb' is almost, but not quite a mesh. It is a stongly connected†@@ -144,15 +178,19 @@  fromWebNodes :: ∀ x y . (WithField ℝ Manifold x, SimpleSpace (Needle x))                     => (MetricChoice x) -> [(x,y)] -> PointsWeb x y-fromWebNodes mf = fromShaded mf . fromLeafPoints . map (uncurry WithAny . swap)+fromWebNodes = case boundarylessWitness :: BoundarylessWitness x of+   BoundarylessWitness ->+       \mf -> fromShaded mf . fromLeafPoints . map (uncurry WithAny . swap)  fromTopWebNodes :: ∀ x y . (WithField ℝ Manifold x, SimpleSpace (Needle x))-                    => (MetricChoice x) -> [((x,[Needle x]),y)] -> PointsWeb x y-fromTopWebNodes mf = fromTopShaded mf . fromLeafPoints+                    => (MetricChoice x) -> [((x,[Int+Needle x]),y)] -> PointsWeb x y+fromTopWebNodes = case boundarylessWitness :: BoundarylessWitness x of+   BoundarylessWitness ->+       \mf -> fromTopShaded mf . fromLeafPoints                    . map (uncurry WithAny . swap . regroup')  fromShadeTree_auto :: ∀ x . (WithField ℝ Manifold x, SimpleSpace (Needle x)) => ShadeTree x -> PointsWeb x ()-fromShadeTree_auto = fromShaded (dualNorm . _shadeExpanse) . constShaded ()+fromShadeTree_auto = fromShaded (dualNorm' . _shadeExpanse) . constShaded ()  fromShadeTree :: ∀ x . (WithField ℝ Manifold x, SimpleSpace (Needle x))      => (Shade x -> Metric x) -> ShadeTree x -> PointsWeb x ()@@ -165,70 +203,164 @@                               --   Riemannian metric).      -> (x`Shaded`y)          -- ^ Source tree.      -> PointsWeb x y-fromShaded metricf = fromTopShaded metricf . fmapShaded ([],)+fromShaded metricf = smoothenWebTopology metricf+                   . fromTopShaded metricf . fmapShaded (first (map Left) . swap)+                       . joinShaded . seekPotentialNeighbours +toShaded :: WithField ℝ PseudoAffine x => PointsWeb x y -> (x`Shaded`y)+toShaded (PointsWeb shd asd) = zipTreeWithList shd $ Arr.toList (fst<$>asd)+ fromTopShaded :: ∀ x y . (WithField ℝ Manifold x, SimpleSpace (Needle x))      => (MetricChoice x)-     -> (x`Shaded`([Needle x], y))  -- ^ Source tree, with a priori topology information-                                    --   (needles pointing to already-known neighbour candidates)+     -> (x`Shaded`([Int+Needle x], y))+                      -- ^ Source tree, with topology information+                      --   (IDs of neighbour-candidates, or needles pointing to them)      -> PointsWeb x y fromTopShaded metricf shd = PointsWeb shd' assocData   where shd' = stripShadedUntopological shd-       assocData = Hask.foldMap locMesh $ twigsWithEnvirons shd+       assocData = Hask.foldMap locMesh $ allTwigs shd        -       locMesh :: ( (Int, ShadeTree (x`WithAny`([Needle x], y)))-                  , [(Int, ShadeTree (x`WithAny`([Needle x], y)))])+       locMesh :: (Int, ShadeTree (x`WithAny`([Int+Needle x], y)))                    -> Arr.Vector (y, Neighbourhood x)-       locMesh ((i₀, locT), neighRegions) = Arr.map findNeighbours $ Arr.fromList locLeaves-        where locLeaves :: [ (Int, x`WithAny`([Needle x], y)) ]+       locMesh (i₀, locT) = Arr.map findNeighbours $ Arr.fromList locLeaves+        where locLeaves :: [ (Int, x`WithAny`([Int+Needle x], y)) ]               locLeaves = map (first (+i₀)) . zip [0..] $ onlyLeaves locT-              vicinityLeaves :: [(Int, x)]-              vicinityLeaves = Hask.foldMap-                                (\(i₀n, ngbR) -> map ((+i₀n) *** _topological)-                                               . zip [0..]-                                               $ onlyLeaves ngbR-                                ) neighRegions-              findNeighbours :: (Int, x`WithAny`([Needle x], y)) -> (y, Neighbourhood x)+              findNeighbours :: (Int, x`WithAny`([Int+Needle x], y)) -> (y, Neighbourhood x)               findNeighbours (i, WithAny (vns,y) x)-                         = (y, Neighbourhood-                                 (UArr.fromList $ fst<$>execState seek mempty)-                                 locRieM )-               where seek :: State [(Int, (Needle x, Needle' x))] ()-                     seek = do-                        Hask.forM_ ( fastNubBy (comparing fst)-                                      $ map (second _topological) locLeaves-                                           ++ vicinityLeaves ++ aprioriNgbs )-                                  $ \(iNgb, xNgb) ->-                           when (iNgb/=i) `id`do-                              let (Option (Just v)) = xNgb.-~.x-                              oldNgbs <- get-                              when (all (\(_,(_,nw)) -> visibleOverlap nw v) oldNgbs) `id`do-                                 let w = w₀ ^/ (w₀<.>^v)-                                      where w₀ = locRieM<$|v-                                 put $ (iNgb, (v,w))-                                       : [ neighbour-                                         | neighbour@(_,(nv,_))<-oldNgbs-                                         , visibleOverlap w nv-                                         ]-                     aprioriNgbs :: [(Int, x)]+                         = (y, cullNeighbours locRieM+                                 (i, WithAny([ (i,v)+                                             | (i,WithAny _ xN) <- locLeaves+                                             , Just v <- [xN.-~.x] ]+                                                ++ aprioriNgbs)+                                             x))+               where aprioriNgbs :: [(Int, Needle x)]                      aprioriNgbs = catMaybes-                                    [ getOption $ (second $ const xN) <$>+                                    [ (second $ const v) <$>                                           positionIndex (pure locRieM) shd' xN-                                    | v <- vns-                                    , let xN = x.+~^v :: x ]-              -              visibleOverlap :: Needle' x -> Needle x -> Bool-              visibleOverlap w v = o < 1-               where o = w<.>^v+                                    | Right v <- vns+                                    , let xN = xi.+~^v :: x ]+                                 ++ [ (i,v) | Left i <- vns+                                            , Right (_,xN) <- [indexShadeTree shd' i]+                                            , Just v <- [xN.-~.x] ]+                     Just xi = toInterior x                              locRieM :: Metric x-              locRieM = case pointsCovers . map _topological-                                  $ onlyLeaves locT-                                   ++ Hask.foldMap (onlyLeaves . snd) neighRegions of+              locRieM = case pointsCovers . catMaybes . map (toInterior . _topological)+                                  $ onlyLeaves locT of                           [sh₀] -> metricf sh₀ +cullNeighbours :: ∀ x . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x))+      => Metric x -> (Int, x`WithAny`[(Int,Needle x)]) -> Neighbourhood x+cullNeighbours locRieM (i, WithAny vns x)+           = Neighbourhood (UArr.fromList . sort $ _nvectId<$>execState seek mempty)+                           locRieM+ where seek :: State [NeighbourhoodVector x] ()+       seek = do+          Hask.forM_ ( fastNubBy (comparing fst) $ vns )+                    $ \(iNgb, v) ->+             when (iNgb/=i) `id`do+                oldNgbs <- get+                let w₀ = locRieM<$|v+                    l = sqrt $ w₀<.>^v+                    onOverlap = sum [ o^2 | nw<-oldNgbs+                                          , let o = (nw^.nvectNormal)<.>^v+                                          , o > 0 ]+                when (l > onOverlap) `id`do+                   let w = w₀^/sqrt l^3+                       newCandidates+                          = NeighbourhoodVector iNgb v w l 0+                          : [ ongb & otherNeighboursOverlap .~ 0+                            | ongb <- oldNgbs+                            , let o = w<.>^(ongb^.theNVect)+                                  newOverlap = (if o > 0 then (o^2+) else id)+                                                $ ongb^.otherNeighboursOverlap+                            , newOverlap < ongb^.nvectLength ]+                   put $ recalcOverlaps newCandidates+       recalcOverlaps [] = []+       recalcOverlaps (ngb:ngbs)+             = (ngb & otherNeighboursOverlap +~ furtherOvl)+             : recalcOverlaps [ ngb' & otherNeighboursOverlap +~ max 0 o ^ 2+                              | ngb' <- ngbs+                              , let o = (ngb^.nvectNormal)<.>^(ngb'^.theNVect) ]+        where furtherOvl = sum [ o^2 | nw<-ngbs+                                     , let o = (nw^.nvectNormal)<.>^(ngb^.theNVect)+                                     , o > 0 ]+              ++-- | Re-calculate the links in a web, so as to give each point a satisfyingly+--   “complete-spanning” environment.+smoothenWebTopology :: (WithField ℝ Manifold x, SimpleSpace (Needle x))+             => MetricChoice x -> PointsWeb x y -> PointsWeb x y+smoothenWebTopology mc = swt+ where swt (PointsWeb shd net) = PointsWeb shd . go allNodes Set.empty+                                                   . fst $ makeIndexLinksSymmetric net+        where allNodes = Set.fromList . Arr.toList $ fst <$> Arr.indexed net+              go activeSet pastLinks asd+                 | all (isNothing.fst) refined+                 , Set.null (Set.difference symmetryTouched pastLinks)+                               = Arr.imap finalise asd'+                 | otherwise   = go (Set.fromList+                                         [ j | (Just i, (_,Neighbourhood ngbs' _))+                                               <-refined+                                         , j <- i : UArr.toList ngbs' ]+                                      `Set.union` (Set.map fst symmetryTouched))+                                    updtLinks+                                    asd'+               where refined = reseek<$>Set.toList activeSet+                      where reseek i = ( guard isNews >> pure i+                                       , (y, Neighbourhood newNgbs locRieM) )+                             where isNews = newNgbs /= oldNgbs+                                             && or [ not $ Set.member (i,j) pastLinks+                                                   | j <- UArr.toList newNgbs ]+                                   (y,Neighbourhood oldNgbs locRieM) = asd Arr.! i+                                   nextNeighbours = fastNub+                                     $ UArr.toList oldNgbs+                                     ++ (UArr.toList._neighbours.snd.(asd Arr.!)+                                             =<< UArr.toList oldNgbs)+                                   x = xLookup Arr.! i+                                   Neighbourhood newNgbs _+                                     = cullNeighbours locRieM+                                        ( i, WithAny [ (j,v)+                                                     | j <- nextNeighbours+                                                     , Just v+                                                         <- [x .-~. xLookup Arr.! j] ]+                                                     x )+                     (asd', symmetryTouched) = makeIndexLinksSymmetric+                              $ asd Arr.// [(i,n) | (Just i,n) <- refined]+                     updtLinks = Set.unions+                                   [ pastLinks+                                   , Set.fromList+                                      [ (i,j) | (Just i,(_,Neighbourhood n _)) <- refined+                                              , j<-UArr.toList n ]+                                   , symmetryTouched ]+              finalise i (y, Neighbourhood n em)+                  = (y, cullNeighbours em (i, WithAny [ (j,v)+                                                      | j<-UArr.toList n+                                                      , let xN = xLookup Arr.! j+                                                      , Just v <- [xN.-~.x] ]+                                                      x ))+               where x = xLookup Arr.! i+              xLookup = Arr.fromList $ onlyLeaves shd++makeIndexLinksSymmetric+       :: Arr.Vector (y, Neighbourhood x)+       -> (Arr.Vector (y, Neighbourhood x), Set.Set (WebNodeId,WebNodeId))+makeIndexLinksSymmetric orig = runST (do+    result <- Arr.thaw orig+    touched <- newSTRef $ Set.empty+    (`Arr.imapM_`orig) $ \i (_,Neighbourhood ngbs _) -> do+       UArr.forM_ ngbs $ \j -> do+          (yn, Neighbourhood nngbs lsc) <- MArr.read result j+          when (not $ i`UArr.elem`nngbs) `id`do+             MArr.write result j (yn, Neighbourhood (UArr.snoc nngbs i) lsc)+             modifySTRef touched $ Set.insert (j,i)+    final <- Arr.freeze result+    allTouched <- readSTRef touched+    return (final, allTouched)+  )+ indexWeb :: (WithField ℝ Manifold x, SimpleSpace (Needle x))-                => PointsWeb x y -> WebNodeId -> Option (x,y)+                => PointsWeb x y -> WebNodeId -> Maybe (x,y) indexWeb (PointsWeb rsc assocD) i   | i>=0, i<Arr.length assocD   , Right (_,x) <- indexShadeTree rsc i  = pure (x, fst (assocD Arr.! i))@@ -245,9 +377,20 @@                     -> Set.fromList [(min i i', max i i')                                     | i'<-UArr.toList ngbs ]                                ) $ Arr.indexed assoc-       lookId i | Option (Just xy) <- indexWeb web i  = xy+       lookId i | Just xy <- indexWeb web i  = xy  +coerceWebDomain :: ∀ a b y . (Manifold a, Manifold b, LocallyCoercible a b)+                                 => PointsWeb a y -> PointsWeb b y+coerceWebDomain (PointsWeb rsc assoc)+         = case oppositeLocalCoercion :: CanonicalDiffeomorphism b a of+   CanonicalDiffeomorphism+       -> PointsWeb ( coerceShadeTree rsc )+                    ( fmap (second $ localScalarProduct+                              %~transformNorm (arr $ coerceNeedle ([]::[(b,a)])))+                         assoc )++ data InterpolationIv y = InterpolationIv {           _interpolationSegRange :: (ℝ,ℝ)         , _interpolationFunction :: ℝ -> y@@ -262,7 +405,7 @@            (xψ,xω)            (\x -> let drel = fromIntv0to1 $ (x-xψ)/(xω-xψ)                   in yio drel )- where Option (Just yio) = geodesicBetween yψ yω+ where Just yio = geodesicBetween yψ yω mkInterpolationSeq_lin (p₀:p₁:ps)     = mkInterpolationSeq_lin [p₀,p₁] <> mkInterpolationSeq_lin (p₁:ps) mkInterpolationSeq_lin _ = []@@ -278,14 +421,11 @@  where edgs = webEdges web        sliceEdgs cp = [ (xi d, yi d)  -- Brute-force search through all edges                       | ((x₀,y₀), (x₁,y₁)) <- edgs-                      , Option (Just d) <- [cutPosBetween cp (x₀,x₁)]-                      , Option (Just xi) <- [geodesicBetween x₀ x₁]-                      , Option (Just yi) <- [geodesicBetween y₀ y₁]+                      , Just d <- [cutPosBetween cp (x₀,x₁)]+                      , Just xi <- [geodesicBetween x₀ x₁]+                      , Just yi <- [geodesicBetween y₀ y₁]                       ] --- sampleWebAlongLine_lin :: ∀ x y . (WithField ℝ Manifold x, Geodesic x, Geodesic y)---                => PointsWeb x y -> x -> Needle x -> [(x,y)]--- sampleWebAlongLine_lin web x₀ dir = sampleWebAlongLines_lin web x₀ [(dir, maxBound)]   data GridPlanes x = GridPlanes {@@ -293,15 +433,19 @@       , _gridPlaneSpacing :: Needle x       , _gridPlanesCount :: Int       }+deriving instance (Show x, Show (Needle x), Show (Needle' x)) => Show (GridPlanes x) data GridSetup x = GridSetup {         _gridStartCorner :: x       , _gridSplitDirs :: [GridPlanes x]       }+deriving instance (Show x, Show (Needle x), Show (Needle' x)) => Show (GridSetup x)  cartesianGrid2D :: (x~ℝ, y~ℝ) => ((x,x), Int) -> ((y,y), Int) -> GridSetup (x,y) cartesianGrid2D ((x₀,x₁), nx) ((y₀,y₁), ny)-    = GridSetup (x₀,y₀) [ GridPlanes (0,1) (0, (y₁-y₀)/fromIntegral ny) ny-                        , GridPlanes (1,0) ((x₁-x₀)/fromIntegral nx, 0) ny ]+    = GridSetup (x₀+dx/2, y₀+dy/2)+                [ GridPlanes (0,1) (0, dy) ny, GridPlanes (1,0) (dx, 0) nx ]+ where dx = (x₁-x₀)/fromIntegral nx+       dy = (y₁-y₀)/fromIntegral ny  splitToGridLines :: ( WithField ℝ Manifold x, SimpleSpace (Needle x)                     , Geodesic x, Geodesic y )@@ -309,27 +453,32 @@ splitToGridLines web (GridSetup x₀ [GridPlanes dirΩ spcΩ nΩ, linePln])     = [ ((x₀', linePln), sliceWeb_lin web $ Cutplane x₀' (Stiefel1 dirΩ))       | k <- [0 .. nΩ-1]-      , let x₀' = x₀.+~^(fromIntegral k *^ spcΩ) ]+      , let x₀' = x₀i.+~^(fromIntegral k *^ spcΩ) ]+ where Just x₀i = toInterior x₀  sampleWebAlongGrid_lin :: ∀ x y . ( WithField ℝ Manifold x, SimpleSpace (Needle x)                                   , Geodesic x, Geodesic y )-               => PointsWeb x y -> GridSetup x -> [(x,Option y)]-sampleWebAlongGrid_lin web grid = finalLine =<< splitToGridLines web grid- where finalLine :: ((x, GridPlanes x), [(x,y)]) -> [(x,Option y)]-       finalLine ((x₀, GridPlanes _ dir nSpl), verts)+               => PointsWeb x y -> GridSetup x -> [(x,Maybe y)]+sampleWebAlongGrid_lin web grid = finalLine boundarylessWitness+                                      =<< splitToGridLines web grid+ where finalLine :: BoundarylessWitness x -> ((x, GridPlanes x), [(x,y)]) -> [(x,Maybe y)]+       finalLine BoundarylessWitness ((x₀, GridPlanes _ dir nSpl), verts)           | length verts < 2  = take nSpl $ (,empty)<$>iterate (.+~^dir) x₀-       finalLine ((x₀, GridPlanes _ dir nSpl), verts)  = take nSpl $ go (x₀,0) intpseq -        where intpseq = mkInterpolationSeq_lin-                         [ (metr |$| x.-~!x₀, y) | (x,y) <- verts ]+       finalLine BoundarylessWitness ((x₀, GridPlanes dx dir nSpl), verts)+                     = take nSpl $ go (x₀,0) intpseq +        where intpseq = mkInterpolationSeq_lin $ sortBy (comparing fst)+                         [ (dx <.>^ (x.-~!x₀), y) | (x,y) <- verts ]               go (x,_) [] = (,empty)<$>iterate (.+~^dir) x-              go xt (InterpolationIv (_,te) f:fs)-                        = case break ((<te) . snd) $ iterate ((.+~^dir)***(+1)) xt of+              go xt (InterpolationIv (tb,te) f:fs)+                        = case span ((<te) . snd) $ iterate ((.+~^dir)***(+δt)) xt of                              (thisRange, xtn:_)-                                 -> ((id***pure.f)<$>thisRange) ++ go xtn fs-       metr = inferMetric $ webNodeRsc web+                                 -> [ (x, if t<tb then empty else return $ f t)+                                    | (x,t) <- thisRange ]+                                     ++ go xtn fs+              δt = dx<.>^dir         sampleWeb_2Dcartesian_lin :: (x~ℝ, y~ℝ, Geodesic z)-             => PointsWeb (x,y) z -> ((x,x),Int) -> ((y,y),Int) -> [(y,[(x,Option z)])]+             => PointsWeb (x,y) z -> ((x,x),Int) -> ((y,y),Int) -> [(y,[(x,Maybe z)])] sampleWeb_2Dcartesian_lin web (xspec@(_,nx)) yspec        = go . sampleWebAlongGrid_lin web $ cartesianGrid2D xspec yspec  where go [] = []@@ -337,7 +486,7 @@                              in (y, map (\((x,_),z) -> (x,z)) ln) : go l'         sampleEntireWeb_2Dcartesian_lin :: (x~ℝ, y~ℝ, Geodesic z)-             => PointsWeb (x,y) z -> Int -> Int -> [(y,[(x,Option z)])]+             => PointsWeb (x,y) z -> Int -> Int -> [(y,[(x,Maybe z)])] sampleEntireWeb_2Dcartesian_lin web nx ny        = sampleWeb_2Dcartesian_lin web ((x₀,x₁),nx) ((y₀,y₁),ny)  where x₀ = minimum (fst<$>pts)@@ -356,11 +505,14 @@             = ( LocalWebInfo {                   _thisNodeCoord = x                 , _thisNodeData = y-                , _containingWeb = result                 , _thisNodeId = i-                , _nodeNeighbours = zip (UArr.toList $ neighbours ngbH) ngbCo-                , _nodeLocalScalarProduct = localScalarProduct ngbH-                , _nodeIsOnBoundary = anyUnopposed (localScalarProduct ngbH) ngbCo+                , _nodeNeighbours = [ (iNgb, (δx, neighbour))+                                    | iNgb <- UArr.toList $ ngbH^.neighbours+                                    , let neighbour = unsafeIndexWebData result iNgb+                                          Just δx = _thisNodeCoord neighbour.-~.x+                                    ]+                , _nodeLocalScalarProduct = ngbH^.localScalarProduct+                , _nodeIsOnBoundary = anyUnopposed (ngbH^.localScalarProduct) ngbCo                 }, ngbH )        anyUnopposed rieM ngbCo = (`any`ngbCo) $ \(v,_)                          -> not $ (`any`ngbCo) $ \(v',_)@@ -373,16 +525,16 @@                                          Right (_,x) -> ((x,y),n) ) asd        asd''= Arr.map (\((x,y),n) ->                        (((x,y), [ ( case x'.-~.x of-                                     Option (Just v) -> v+                                     Just v -> v                                   , y')-                                | j<-UArr.toList (neighbours n)+                                | j<-UArr.toList (n^.neighbours)                                 , let ((x',y'),_) = asd' Arr.! j                                 ]), n)                  ) asd'   nearestNeighbour :: (WithField ℝ Manifold x, SimpleSpace (Needle x))-                      => PointsWeb x y -> x -> Option (x,y)+                      => PointsWeb x y -> x -> Maybe (x,y) nearestNeighbour (PointsWeb rsc asd) x = fmap lkBest $ positionIndex empty rsc x  where lkBest (iEst, (_, xEst)) = (xProx, yProx)         where (iProx, (xProx, _)) = minimumBy (comparing $ snd . snd)@@ -393,38 +545,89 @@               neighbours = [ (i, (xNgb, normSq locMetr v))                            | i <- UArr.toList neighbourIds                            , let Right (_, xNgb) = indexShadeTree rsc i-                                 Option (Just v) = xNgb.-~.x+                                 Just v = xNgb.-~.x                            ]-              Option (Just vEst) = xEst.-~.x+              Just vEst = xEst.-~.x   -data WebLocally x y = LocalWebInfo {-      _thisNodeCoord :: x-    , _thisNodeData :: y-    , _containingWeb :: PointsWeb x (WebLocally x y)-    , _thisNodeId :: WebNodeId-    , _nodeNeighbours :: [(WebNodeId, (Needle x, y))]-    , _nodeLocalScalarProduct :: Metric x-    , _nodeIsOnBoundary :: Bool-    } deriving (Generic)-makeLenses ''WebLocally- instance Hask.Functor (WebLocally x) where-  fmap f (LocalWebInfo co dt wb id ng sp bn)-       = LocalWebInfo co (f dt) (fmap (fmap f) wb) id (map (second $ second f) ng) sp bn+  fmap f (LocalWebInfo co dt id ng sp bn)+       = LocalWebInfo co (f dt) id (map (second . second $ fmap f) ng) sp bn instance WithField ℝ Manifold x => Comonad (WebLocally x) where   extract = _thisNodeData-  duplicate lweb = unsafeIndexWebData deepened $ _thisNodeId lweb-   where deepened = webLocalInfo $ _containingWeb lweb+  extend f this@(LocalWebInfo co _ id ng sp bn)+      = LocalWebInfo co (f this) id (map (second . second $ extend f) ng) sp bn+  duplicate this@(LocalWebInfo co _ id ng sp bn)+      = LocalWebInfo co this id (map (second $ second duplicate) ng) sp bn +-- ^ 'fmap' from the co-Kleisli category of 'WebLocally'.+localFmapWeb :: WithField ℝ Manifold x+                => (WebLocally x y -> z) -> PointsWeb x y -> PointsWeb x z+localFmapWeb f = webLocalInfo >>> fmap f +traverseWebWithStrategy :: ( WithField ℝ Manifold x, Hask.Applicative m )+               => InconsistencyStrategy m x y -> (WebLocally x y -> Maybe y)+                     -> PointsWeb x y -> m (PointsWeb x y)+traverseWebWithStrategy strat f = webLocalInfo+               >>> traverse (\info -> handleInconsistency strat+                                       (info^.thisNodeData) (f info)) +differentiateUncertainWebLocally :: ∀ x y+   . ( WithField ℝ Manifold x, SimpleSpace (Needle x)+     , WithField ℝ Refinable y, SimpleSpace (Needle y) )+            => WebLocally x (Shade' y)+             -> Shade' (LocalLinear x y)+differentiateUncertainWebLocally info+          = case estimateLocalJacobian+                          (info^.nodeLocalScalarProduct)+                          [ ( Local δx :: Local x, ngb^.thisNodeData )+                          | (δx,ngb) <- (zeroV, info)+                                      : (snd<$>info^.nodeNeighbours)+                          ] of+               Just j -> j+               _      -> Shade' zeroV mempty +differentiateUncertainWebFunction :: ∀ x y+   . ( WithField ℝ Manifold x, SimpleSpace (Needle x)+     , WithField ℝ Manifold y, SimpleSpace (Needle y), Refinable y )+            => PointsWeb x (Shade' y)+             -> PointsWeb x (Shade' (LocalLinear x y))+differentiateUncertainWebFunction = localFmapWeb differentiateUncertainWebLocally +rescanPDELocally :: ∀ x y .+     ( WithField ℝ Manifold x, SimpleSpace (Needle x)+     , WithField ℝ Refinable y, SimpleSpace (Needle y) )+         => DifferentialEqn x y -> WebLocally x (Shade' y)+                                -> Maybe (Shade' y)+rescanPDELocally = case ( dualSpaceWitness :: DualNeedleWitness x+                        , dualSpaceWitness :: DualNeedleWitness y+                        , boundarylessWitness :: BoundarylessWitness x+                        , pseudoAffineWitness :: PseudoAffineWitness y ) of+   ( DualSpaceWitness,DualSpaceWitness,BoundarylessWitness+    , PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness) )+     -> \f info -> let xc = info^.thisNodeCoord+                       yc = info^.thisNodeData.shadeCtr+                   in case f $ coverAllAround (xc, yc)+                                     [ (δx, (ngb^.thisNodeData.shadeCtr.-~!yc) ^+^ v)+                                     | (_,(δx,ngb))<-info^.nodeNeighbours+                                     , v <- normSpanningSystem'+                                              (ngb^.thisNodeData.shadeNarrowness)] of+                        LocalDifferentialEqn _ rescan+                            -> rescan (differentiateUncertainWebLocally info)+                                      (info^.thisNodeData)++rescanPDEOnWeb :: ( WithField ℝ Manifold x, SimpleSpace (Needle x)+                  , WithField ℝ Refinable y, SimpleSpace (Needle y)+                  , Hask.Applicative m )+                => InconsistencyStrategy m x (Shade' y)+                  -> DifferentialEqn x y -> PointsWeb x (Shade' y)+                                   -> m (PointsWeb x (Shade' y))+rescanPDEOnWeb strat = traverseWebWithStrategy strat . rescanPDELocally+ toGraph :: (WithField ℝ Manifold x, SimpleSpace (Needle x))               => PointsWeb x y -> (Graph, Vertex -> (x, y))-toGraph wb = second (>>> \(i,_,_) -> case indexWeb wb i of {Option (Just xy) -> xy})+toGraph wb = second (>>> \(i,_,_) -> case indexWeb wb i of {Just xy -> xy})                 (graphFromEdges' edgs)  where edgs :: [(Int, Int, [Int])]        edgs = Arr.toList@@ -441,11 +644,13 @@       -- ^ If @p@ is in all intersectors, it must also be in the hull.     , convexSetIntersectors :: [Shade' x]     }+deriving instance ( WithField ℝ Manifold x, SimpleSpace (Needle x)+                  , Show (Interior x), Show (Needle' x) ) => Show (ConvexSet x)  ellipsoid :: Shade' x -> ConvexSet x ellipsoid s = ConvexSet s [s] -intersectors :: ConvexSet x -> Option (NonEmpty (Shade' x))+intersectors :: ConvexSet x -> Maybe (NonEmpty (Shade' x)) intersectors (ConvexSet h []) = pure (h:|[]) intersectors (ConvexSet _ (i:sts)) = pure (i:|sts) intersectors _ = empty@@ -454,9 +659,9 @@ instance Refinable x => Semigroup (ConvexSet x) where   a<>b = sconcat (a:|[b])   sconcat csets-    | Option (Just allIntersectors) <- sconcat <$> Hask.traverse intersectors csets+    | Just allIntersectors <- sconcat <$> Hask.traverse intersectors csets     , IntersectT ists <- rmTautologyIntersect perfectRefine $ IntersectT allIntersectors-    , Option (Just hull') <- intersectShade's ists+    , Just hull' <- intersectShade's ists                  = ConvexSet hull' (NE.toList ists)     | otherwise  = EmptyConvex    where perfectRefine sh₁ sh₂@@ -466,201 +671,325 @@   -itWhileJust :: (a -> Option a) -> a -> [a]-itWhileJust f x | Option (Just y) <- f x  = x : itWhileJust f y-itWhileJust _ x = [x]+itWhileJust :: InconsistencyStrategy m x y -> (a -> m a) -> a -> [a]+itWhileJust AbortOnInconsistency f x+ | Just y <- f x  = x : itWhileJust AbortOnInconsistency f y+itWhileJust IgnoreInconsistencies f x+ | Identity y <- f x  = x : itWhileJust IgnoreInconsistencies f y+itWhileJust (HighlightInconsistencies yh) f x+ | Identity y <- f x  = x : itWhileJust (HighlightInconsistencies yh) f y+itWhileJust _ _ x = [x]  dupHead :: NonEmpty a -> NonEmpty a dupHead (x:|xs) = x:|x:xs  ++data InconsistencyStrategy m x y where+    AbortOnInconsistency :: InconsistencyStrategy Maybe x y+    IgnoreInconsistencies :: InconsistencyStrategy Identity x y+    HighlightInconsistencies :: y -> InconsistencyStrategy Identity x y+deriving instance Hask.Functor (InconsistencyStrategy m x)++ iterateFilterDEqn_static :: ( WithField ℝ Manifold x, SimpleSpace (Needle x)-                            , Refinable y )-       => DifferentialEqn x y -> PointsWeb x (Shade' y) -> [PointsWeb x (Shade' y)]-iterateFilterDEqn_static f = map (fmap convexSetHull)-                           . itWhileJust (filterDEqnSolutions_static f)+                            , Refinable y, Geodesic (Interior y)+                            , Hask.Applicative m )+       => InconsistencyStrategy m x (Shade' y) -> DifferentialEqn x y+                 -> PointsWeb x (Shade' y) -> [PointsWeb x (Shade' y)]+iterateFilterDEqn_static strategy f+                           = map (fmap convexSetHull)+                           . itWhileJust strategy+                                (filterDEqnSolutions_static (ellipsoid<$>strategy) f)                            . fmap (`ConvexSet`[]) -filterDEqnSolution_static :: ( WithField ℝ Manifold x, SimpleSpace (Needle x)-                             , Refinable y )-       => DifferentialEqn x y -> PointsWeb x (Shade' y) -> Option (PointsWeb x (Shade' y))-filterDEqnSolution_static f = localFocusWeb >>> Hask.traverse `id`-                   \((x,shy), ngbs) -> if null ngbs-                     then pure shy-                     else refineShade' shy+filterDEqnSolution_static :: ∀ x y m . ( WithField ℝ Manifold x, SimpleSpace (Needle x)+                                       , Refinable y, Geodesic (Interior y) )+       => InconsistencyStrategy m x (Shade' y) -> DifferentialEqn x y+            -> PointsWeb x (Shade' y) -> m (PointsWeb x (Shade' y))+filterDEqnSolution_static strat@AbortOnInconsistency f+    = case boundarylessWitness :: BoundarylessWitness x of+     BoundarylessWitness ->+        rescanPDEOnWeb strat f >=> webLocalInfo+           >>> Hask.traverse `id`\me -> case me^.nodeNeighbours of+                  []   -> return $ me^.thisNodeData+                  ngbs -> refineShade' (me^.thisNodeData)                             =<< intersectShade's-                                  ( propagateDEqnSolution_loc f ((x,shy), NE.fromList ngbs) )+                            =<< ( sequenceA $ NE.fromList+                                  [ propagateDEqnSolution_loc+                                       f (LocalDataPropPlan+                                             (ngbInfo^.thisNodeCoord)+                                             (negateV δx)+                                             (ngbInfo^.thisNodeData)+                                             (me^.thisNodeData)+                                             (fmap (second _thisNodeData . snd)+                                                       $ ngbInfo^.nodeNeighbours)+                                          )+                                  | (_, (δx, ngbInfo)) <- ngbs+                                  ] ) -filterDEqnSolutions_static :: ( WithField ℝ Manifold x, SimpleSpace (Needle x)-                              , Refinable y )-       => DifferentialEqn x y -> PointsWeb x (ConvexSet y) -> Option (PointsWeb x (ConvexSet y))-filterDEqnSolutions_static f = localFocusWeb >>> Hask.traverse `id`-            \((x, shy@(ConvexSet hull _)), ngbs) -> if null ngbs-              then pure shy-              else ((shy<>) . ellipsoid)-                      <$> intersectShade's -                            ( propagateDEqnSolution_loc f-                               ((x,hull), second convexSetHull<$>NE.fromList ngbs) )-                     >>= \case EmptyConvex -> empty-                               c           -> pure c+filterDEqnSolutions_static :: ∀ x y m .+                              ( WithField ℝ Manifold x, SimpleSpace (Needle x)+                              , Refinable y, Geodesic (Interior y)+                              , Hask.Applicative m )+       => InconsistencyStrategy m x (ConvexSet y) -> DifferentialEqn x y+            -> PointsWeb x (ConvexSet y) -> m (PointsWeb x (ConvexSet y))+filterDEqnSolutions_static strategy f+       = webLocalInfo+           >>> fmap (id &&& rescanPDELocally f . fmap convexSetHull)+           >>> localFocusWeb >>> Hask.traverse `id`\((_,(me,updShy)), ngbs)+          -> let oldValue = me^.thisNodeData :: ConvexSet y+             in  case updShy of+              Just shy -> case ngbs of+                  []  -> pure oldValue+                  _:_ | BoundarylessWitness <- (boundarylessWitness::BoundarylessWitness x)+                    -> handleInconsistency strategy oldValue+                          $ ( sequenceA $ NE.fromList+                                  [ sj >>= \ngbShy ->+                                     propagateDEqnSolution_loc+                                       f (LocalDataPropPlan+                                             (ngbInfo^.thisNodeCoord)+                                             (negateV δx)+                                             ngbShy+                                             shy+                                             (fmap (second (convexSetHull . _thisNodeData)+                                                    . snd) $ ngbInfo^.nodeNeighbours)+                                          )+                                  | (δx, (ngbInfo,sj)) <- ngbs+                                  ] )+                            >>= intersectShade's+                            >>= pure . ((oldValue<>) . ellipsoid)+                            >>= \case EmptyConvex -> empty+                                      c           -> pure c+              _ -> handleInconsistency strategy oldValue empty +handleInconsistency :: InconsistencyStrategy m x a -> a -> Maybe a -> m a+handleInconsistency AbortOnInconsistency _ i = i+handleInconsistency IgnoreInconsistencies _ (Just v) = Identity v+handleInconsistency IgnoreInconsistencies b _ = Identity b+handleInconsistency (HighlightInconsistencies _) _ (Just v) = Identity v+handleInconsistency (HighlightInconsistencies b) _ _ = Identity b -data SolverNodeState y = SolverNodeInfo {+data SolverNodeState x y = SolverNodeInfo {       _solverNodeStatus :: ConvexSet y+    , _solverNodeJacobian :: Shade' (LocalLinear x y)     , _solverNodeBadness :: ℝ     , _solverNodeAge :: Int     } makeLenses ''SolverNodeState  -type OldAndNew d = (Option d, [d])+type OldAndNew d = (Maybe d, [d])  oldAndNew :: OldAndNew d -> [d]-oldAndNew (Option (Just x), l) = x : l+oldAndNew (Just x, l) = x : l oldAndNew (_, l) = l  oldAndNew' :: OldAndNew d -> [(Bool, d)]-oldAndNew' (Option (Just x), l) = (True, x) : fmap (False,) l+oldAndNew' (Just x, l) = (True, x) : fmap (False,) l oldAndNew' (_, l) = (False,) <$> l  -filterDEqnSolutions_adaptive :: ∀ x y badness-        . (WithField ℝ Manifold x, SimpleSpace (Needle x), Refinable y, badness ~ ℝ)+filterDEqnSolutions_adaptive :: ∀ x y badness m+        . ( WithField ℝ Manifold x, SimpleSpace (Needle x)+          , WithField ℝ AffineManifold y, Refinable y, Geodesic y+          , badness ~ ℝ, Hask.Monad m )        => MetricChoice x      -- ^ Scalar product on the domain, for regularising the web.+       -> InconsistencyStrategy m x (Shade' y)        -> DifferentialEqn x y         -> (x -> Shade' y -> badness)-             -> PointsWeb x (SolverNodeState y)-                        -> Option (PointsWeb x (SolverNodeState y))-filterDEqnSolutions_adaptive mf f badness' oldState-         = fmap (fromTopWebNodes mf . concat . fmap retraceBonds-                                        . Hask.toList . webLocalInfo . webLocalInfo)-             $ Hask.traverse (uncurry localChange) preproc'd- where preproc'd :: PointsWeb x ((WebLocally x (SolverNodeState y), [(Shade' y, badness)]))-       preproc'd = fmap addPropagation $ webLocalInfo oldState+             -> PointsWeb x (SolverNodeState x y)+                        -> m (PointsWeb x (SolverNodeState x y))+filterDEqnSolutions_adaptive mf strategy f badness' oldState+            = fmap recomputeJacobian $ filterGo boundarylessWitness+                                         =<< tryPreproc boundarylessWitness+ where tryPreproc :: BoundarylessWitness x+                      -> m (PointsWeb x ( (WebLocally x (SolverNodeState x y)+                                        , [(Shade' y, badness)]) ))+       tryPreproc BoundarylessWitness = traverse addPropagation $ webLocalInfo oldState         where addPropagation wl-                 | null neighbourHulls = (wl, [])-                 | otherwise           = (wl, map (id&&&badness undefined) propFromNgbs)-               where propFromNgbs = NE.toList $ propagateDEqnSolution_loc f-                                     ( (thisPos, thisShy), NE.fromList neighbourHulls )+                 | null neighbourInfo = pure (wl, [])+                 | otherwise           = (wl,) . map (id&&&badness undefined)+                                           <$> propFromNgbs+               where propFromNgbs :: m [Shade' y]+                     propFromNgbs = mapM (handleInconsistency strategy thisShy) [+                                       propagateDEqnSolution_loc f+                                        (LocalDataPropPlan+                                           (neigh^.thisNodeCoord)+                                           (negateV δx)+                                           (convexSetHull $ neigh^.thisNodeData+                                                                  .solverNodeStatus)+                                           (thisShy)+                                           [ second (convexSetHull+                                                     . _solverNodeStatus . _thisNodeData) nn+                                           | (_,nn)<-neigh^.nodeNeighbours ] )+                                     | (δx, neigh) <- neighbourInfo ]  -- ( (thisPos, thisShy), NE.fromList neighbourHulls )                      thisPos = _thisNodeCoord wl :: x                      thisShy = convexSetHull . _solverNodeStatus $ _thisNodeData wl-                     neighbourHulls = second (convexSetHull . _solverNodeStatus) . snd-                                        <$> _nodeNeighbours wl-       smallBadnessGradient, largeBadnessGradient :: ℝ-       (smallBadnessGradient, largeBadnessGradient)-           = ( badnessGradRated!!(n`div`4), badnessGradRated!!(n*3`div`4) )-        where n = case length badnessGradRated of-                    0 -> error "No neighbours available for badness-grading."-                    l -> l-              badnessGradRated = sort [ ngBad / bad-                                      | ( LocalWebInfo {-                                            _thisNodeData-                                              = SolverNodeInfo _ bad _-                                          , _nodeNeighbours=ngbs        }-                                        , ngbProps) <- Hask.toList preproc'd-                                      , (_, ngBad) <- ngbProps-                                      , ngBad>bad ]-       localChange :: WebLocally x (SolverNodeState y) -> [(Shade' y, badness)]-                             -> Option (OldAndNew (x, SolverNodeState y))-       localChange localInfo@LocalWebInfo{-                         _thisNodeCoord = x-                       , _thisNodeData = SolverNodeInfo-                                            shy@(ConvexSet hull _) prevBadness age-                       , _nodeNeighbours = ngbs-                       }-                   ngbProps-        | null ngbs  = return (pure (x, SolverNodeInfo shy prevBadness (age+1)), [])-        | otherwise  = do-               let neighbourHulls = second (convexSetHull . _solverNodeStatus) . snd-                                       <$> NE.fromList ngbs-                   (environAge, unfreshness)-                      = maximum&&&minimum $ age : (_solverNodeAge . snd . snd <$> ngbs)-               case find (\(_, badnessN)-                               -> badnessN / prevBadness > smallBadnessGradient)-                              $ ngbProps of-                 Nothing | age < environAge   -- point is an obsolete step-stone;-                   -> return (empty,empty)    -- do not further use it.-                 _otherwise -> do-                   shy' <- ((shy<>) . ellipsoid)-                            <$> intersectShade's (fst <$> NE.fromList ngbProps)-                   newBadness <- case shy' of-                      EmptyConvex        -> empty-                      ConvexSet hull' _  -> return $ badness x hull'-                   let updatedNode = SolverNodeInfo shy' newBadness (age+1)-                   stepStones <--                     if unfreshness < 3-                      then return []-                      else fmap concat . forM (zip (snd<$>ngbs) ngbProps)-                                   $ \( (vN, SolverNodeInfo (ConvexSet hullN _)-                                                          _ ageN)-                                        , (_, nBadnessProp'd) ) -> do-                       case ageN of-                        _  | ageN > 0-                           , badnessGrad <- nBadnessProp'd / prevBadness-                           , badnessGrad > largeBadnessGradient -> do-                                 let stepV = vN^/2-                                     xStep = x .+~^ stepV-                                 shyStep <- intersectShade's $-                                            propagateDEqnSolution_loc f-                                            ( (xStep, hull)-                                            , NE.cons (negateV stepV, hull)-                                                $ fmap (\(vN',hullN')-                                                         -> (vN'^-^stepV, hullN') )-                                                    neighbourHulls )-                                 return [( xStep-                                         , SolverNodeInfo (ellipsoid shyStep)-                                                 (badness xStep shyStep) 1-                                         )]-                        _otherwise -> return []-                   let updated = (x, updatedNode)-                   return $ (pure updated, stepStones)-       -       totalAge = maximum $ _solverNodeAge . _thisNodeData . fst <$> preproc'd+                     neighbourInfo = snd <$> _nodeNeighbours wl++       totalAge = maximum $ _solverNodeAge <$> oldState        errTgtModulation = (1-) . (`mod'`1) . negate . sqrt $ fromIntegral totalAge        badness x = badness' x . (shadeNarrowness %~ (scaleNorm errTgtModulation))-       -       retraceBonds :: WebLocally x (WebLocally x (OldAndNew (x, SolverNodeState y)))-                       -> [((x, [Needle x]), SolverNodeState y)]-       retraceBonds locWeb@LocalWebInfo{ _thisNodeId = myId-                                       , _thisNodeCoord = xOld-                                       , _nodeLocalScalarProduct = locMetr }-            = [ ( (x, fst<$>neighbourCandidates), snsy)-              | (isOld, (x, snsy)) <- focused-              , let neighbourCandidates-                     = [ (v,nnId)-                       | (_,ngb) <- knownNgbs-                       , (Option (Just v), nnId)-                          <- case oldAndNew $ ngb^.thisNodeData of-                                   [] -> [ (xN.-~.x, nnId)-                                         | (nnId, (_,nnWeb)) <- ngb^.nodeNeighbours-                                         , nnId /= myId-                                         , (xN,_) <- oldAndNew nnWeb ]-                                   l -> [(xN.-~.x, ngb^.thisNodeId) | (xN,_) <- l]-                       ]-                    possibleConflicts = [ normSq locMetr v-                                        | (v,nnId)<-neighbourCandidates-                                        , nnId > myId ]-              , isOld || null possibleConflicts-                  || minimum possibleConflicts > oldMinDistSq / 4-              ]-        where focused = oldAndNew' $ locWeb^.thisNodeData^.thisNodeData-              knownNgbs = snd <$> locWeb^.nodeNeighbours-              oldMinDistSq = minimum [ normSq locMetr vOld-                                     | (_,ngb) <- knownNgbs-                                     , let Option (Just vOld) = ngb^.thisNodeCoord .-~. xOld-                                     ]+              +       filterGo :: BoundarylessWitness x+                   -> (PointsWeb x ( (WebLocally x (SolverNodeState x y)+                                   , [(Shade' y, badness)]) ))+                   -> m (PointsWeb x (SolverNodeState x y))+       filterGo BoundarylessWitness preproc'd   = fmap (smoothenWebTopology mf+                                     . fromTopWebNodes mf . concat . fmap retraceBonds+                                        . Hask.toList . webLocalInfo . webLocalInfo)+             $ Hask.traverse (uncurry localChange) preproc'd+        where smallBadnessGradient, largeBadnessGradient :: ℝ+              (smallBadnessGradient, largeBadnessGradient)+                  = ( badnessGradRated!!(n`div`4), badnessGradRated!!(n*3`div`4) )+               where n = case length badnessGradRated of+                           0 -> error "No statistics available for badness-grading."+                           l -> l+                     badnessGradRated :: [badness]+                     badnessGradRated = sort [ ngBad / bad+                                             | ( LocalWebInfo {+                                                   _thisNodeData+                                                     = SolverNodeInfo _ _ bad _+                                                 , _nodeNeighbours=ngbs        }+                                               , ngbProps) <- Hask.toList preproc'd+                                             , (_, ngBad) <- ngbProps+                                             , ngBad>bad ]+              localChange :: WebLocally x (SolverNodeState x y) -> [(Shade' y, badness)]+                                    -> m (OldAndNew (x, SolverNodeState x y))+              localChange localInfo@LocalWebInfo{+                                _thisNodeCoord = x+                              , _thisNodeData = SolverNodeInfo+                                                   shy@(ConvexSet hull _) prevJacobi+                                                   prevBadness age+                              , _nodeNeighbours = ngbs+                              }+                          ngbProps+               | null ngbs  = return ( pure (x, SolverNodeInfo shy prevJacobi+                                                           prevBadness (age+1))+                                     , [] )+               | otherwise  = do+                      let (environAge, unfreshness)+                             = maximum&&&minimum $ age : (_solverNodeAge . _thisNodeData+                                                               . snd . snd <$> ngbs)+                      case find (\(_, badnessN)+                                      -> badnessN / prevBadness > smallBadnessGradient)+                                     $ ngbProps of+                        Nothing | age < environAge   -- point is an obsolete step-stone;+                          -> return (empty,empty)    -- do not further use it.+                        _otherwise -> do+                          shy' <- handleInconsistency (ellipsoid<$>strategy) shy+                                  $ ((shy<>) . ellipsoid)+                                   <$> intersectShade's (fst <$> NE.fromList ngbProps)+                          newBadness+                               <- handleInconsistency (badness x<$>strategy) prevBadness+                                      $ case shy' of+                             EmptyConvex        -> empty+                             ConvexSet hull' _  -> return $ badness x hull'+                          let updatedNode = SolverNodeInfo shy' prevJacobi+                                                     newBadness (age+1)+                          stepStones <-+                            if unfreshness < 3+                             then return []+                             else fmap concat . forM (zip (second _thisNodeData.snd<$>ngbs)+                                                          ngbProps)+                                          $ \( (vN, SolverNodeInfo (ConvexSet hullN _)+                                                               _ _ ageN)+                                               , (_, nBadnessProp'd) ) -> do+                              case ageN of+                               _  | ageN > 0+                                  , badnessGrad <- nBadnessProp'd / prevBadness+                                  , badnessGrad > largeBadnessGradient -> do+                                        let stepV = vN^/2+                                            xStep = x .+~^ stepV+                                            aprioriInterpolate :: Shade' y+                                            Just aprioriInterpolate+                                               = middleBetween hull hullN+                                        case intersectShade's =<<+                                               (sequenceA $ NE.fromList+                                               [ propagateDEqnSolution_loc f+                                                   (LocalDataPropPlan+                                                      (n^.thisNodeCoord)+                                                      (stepV ^-^ δx)+                                                      (convexSetHull $+                                                        n^.thisNodeData.solverNodeStatus)+                                                      (aprioriInterpolate)+                                                      (second (convexSetHull+                                                               ._solverNodeStatus+                                                               ._thisNodeData)+                                                              . snd+                                                              <$> n^.nodeNeighbours) )+                                                -- ( (xStep, hull)+                                                -- , NE.cons (negateV stepV, hull)+                                                --     $ fmap (\(vN',hullN')+                                                --              -> (vN'^-^stepV, hullN') ) )+                                                | (_, (δx, n)) <- ngbs ]) of+                                         Just shyStep -> return+                                               [( xStep+                                                , SolverNodeInfo (ellipsoid shyStep)+                                                       prevJacobi (badness xStep shyStep) 1+                                                )]+                                         _ -> return []+                               _otherwise -> return []+                          let updated = (x, updatedNode)+                          return $ (pure updated, stepStones)+              +              retraceBonds :: WebLocally x (WebLocally x (OldAndNew (x, SolverNodeState x y)))+                              -> [((x, [Int+Needle x]), SolverNodeState x y)]+              retraceBonds locWeb@LocalWebInfo{ _thisNodeId = myId+                                              , _thisNodeCoord = xOld+                                              , _nodeLocalScalarProduct = locMetr }+                   = [ ( (x, Right . fst<$>neighbourCandidates), snsy)+                     | (isOld, (x, snsy)) <- focused+                     , let neighbourCandidates+                            = [ (v,nnId)+                              | (_,ngb) <- knownNgbs+                              , (Just v, nnId)+                                 <- case oldAndNew $ ngb^.thisNodeData of+                                          [] -> [ (xN.-~.x, nnId)+                                                | (nnId, (_,nnWeb)) <- ngb^.nodeNeighbours+                                                , nnId /= myId+                                                , (xN,_) <- oldAndNew $ nnWeb^.thisNodeData ]+                                          l -> [(xN.-~.x, ngb^.thisNodeId) | (xN,_) <- l]+                              ]+                           possibleConflicts = [ normSq locMetr v+                                               | (v,nnId)<-neighbourCandidates+                                               , nnId > myId ]+                     , isOld || null possibleConflicts+                         || minimum possibleConflicts > oldMinDistSq / 4+                     ]+               where focused = oldAndNew' $ locWeb^.thisNodeData^.thisNodeData+                     knownNgbs = second _thisNodeData . snd <$> locWeb^.nodeNeighbours+                     oldMinDistSq = minimum [ normSq locMetr vOld+                                            | (_,ngb) <- knownNgbs+                                            , let Just vOld = ngb^.thisNodeCoord .-~. xOld+                                            ]                               +recomputeJacobian :: ( WithField ℝ Manifold x, SimpleSpace (Needle x)+                     , WithField ℝ Manifold y, SimpleSpace (Needle y), Refinable y )+             => PointsWeb x (SolverNodeState x y)+             -> PointsWeb x (SolverNodeState x y)+recomputeJacobian = webLocalInfo+                >>> fmap ((_thisNodeData+                           &&& differentiateUncertainWebLocally+                                   . fmap (convexSetHull . _solverNodeStatus))+                          >>> \(nst, shj) -> nst & solverNodeJacobian .~ shj )  -iterateFilterDEqn_adaptive :: (WithField ℝ Manifold x, SimpleSpace (Needle x), Refinable y)+iterateFilterDEqn_adaptive+     :: ( WithField ℝ Manifold x, SimpleSpace (Needle x)+        , WithField ℝ AffineManifold y, Refinable y, Geodesic y, Hask.Monad m )        => MetricChoice x      -- ^ Scalar product on the domain, for regularising the web.+       -> InconsistencyStrategy m x (Shade' y)        -> DifferentialEqn x y        -> (x -> Shade' y -> ℝ) -- ^ Badness function for local results.              -> PointsWeb x (Shade' y) -> [PointsWeb x (Shade' y)]-iterateFilterDEqn_adaptive mf f badness+iterateFilterDEqn_adaptive mf strategy f badness     = map (fmap (convexSetHull . _solverNodeStatus))-    . itWhileJust (filterDEqnSolutions_adaptive mf f badness)+    . itWhileJust strategy (filterDEqnSolutions_adaptive mf strategy f badness)+    . recomputeJacobian     . fmap (\((x,shy),_) -> SolverNodeInfo (ellipsoid shy)+                                           (Shade' zeroV mempty)                                            (badness x shy)                                            1            )

@@ -12,7 +12,6 @@  module Data.SetLike.Intersection where -import Data.Semigroup import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty(..)) @@ -24,14 +23,14 @@ singleIntersect = IntersectT . pure  rmTautologyIntersect ::-         (s x -> s x -> Option (s x)) -- ^ Subset-finder+         (s x -> s x -> Maybe (s x)) -- ^ Subset-finder       -> IntersectT s x -> IntersectT s x rmTautologyIntersect smaller (IntersectT isoa) = IntersectT $ rti isoa  where rti (s₀:|ss) = reduce [] ss         where reduce [] [] = s₀:|[]               reduce (sp₀:sp) [] = NE.cons s₀ $ rti (sp₀:|sp)               reduce sp (s₁:sr) = case smaller s₀ s₁ of-               Option (Just si) -> rti $ si :| (sp ++ sr)-               Option Nothing   -> reduce (s₁:sp) sr+               Just si -> rti $ si :| (sp ++ sr)+               Nothing -> reduce (s₁:sp) sr              

binary file changed (84463 → 89277 bytes)

binary file changed (absent → 52444 bytes)

binary file changed (161269 → 247358 bytes)

binary file changed (276911 → 328843 bytes)

binary file changed (176908 → 213891 bytes)

@@ -1,5 +1,5 @@ Name:                manifolds-Version:             0.3.0.0+Version:             0.4.0.0 Category:            Math Synopsis:            Coordinate-free hypersurfaces Description:         Manifolds, a generalisation of the notion of &#x201c;smooth curves&#x201d; or surfaces,@@ -40,21 +40,21 @@  Library   Build-Depends:     base>=4.5 && < 6+                     , manifolds-core == 0.4.0.0                      , transformers                      , vector-space>=0.8                      , free-vector-spaces>=0.1.1                      , linear                      , MemoTrie                      , vector-                     , linearmap-category > 0.1 && < 0.2+                     , linearmap-category > 0.3 && < 0.4                      , containers                      , comonad                      , semigroups                      , void                      , tagged                      , deepseq-                     , microlens >= 0.4 && <= 0.5, microlens-th-                     , trivial-constraint >= 0.4+                     , lens                      , constrained-categories >= 0.2.3 && < 0.3.1   other-extensions:  FlexibleInstances                      , TypeFamilies@@ -77,6 +77,7 @@                      Data.Manifold.Types                      Data.Manifold.Types.Stiefel                      Data.Manifold.Griddable+                     Data.Manifold.Atlas                      Data.Manifold.Riemannian   Other-modules:   Data.List.FastNub                    Data.Manifold.Types.Primitive