-- |
-- Module      : Data.Manifold.TreeCover
-- Copyright   : (c) Justus Sagemüller 2015
-- License     : GPL v3
-- 
-- Maintainer  : (@) jsag $ hvl.no
-- Stability   : experimental
-- Portability : portable
-- 
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveFoldable             #-}
{-# LANGUAGE DeriveTraversable          #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE FunctionalDependencies     #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE UnicodeSyntax              #-}
{-# LANGUAGE PatternSynonyms            #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# 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, prettyShowsPrecShade', prettyShowShade'
       -- ** Misc
       , factoriseShade, intersectShade's, linIsoTransformShade
       , embedShade, projectShade
       , Refinable, subShade', refineShade', convolveShade', coerceShade
       , mixShade's
       -- * Shade trees
       , ShadeTree, fromLeafPoints, fromLeafPoints_, onlyLeaves, onlyLeaves_
       , indexShadeTree, treeLeaf, positionIndex
       -- ** View helpers
       , entireTree, onlyNodes, trunkBranches, nLeaves, treeDepth
       -- ** Auxiliary types
       , SimpleTree, Trees, NonEmptyTree, GenericTree(..), 朳
       -- * Misc
       , HasFlatView(..), shadesMerge
       , allTwigs, twigsWithEnvirons, Twig, TwigEnviron, seekPotentialNeighbours
       , completeTopShading, flexTwigsShading, traverseTrunkBranchChoices
       , Shaded(..), fmapShaded
       , constShaded, zipTreeWithList
       , stiAsIntervalMapping, spanShading
       , DBranch, DBranch'(..), Hourglass(..)
       , unsafeFmapTree
       -- ** External
       , AffineManifold, euclideanMetric
    ) 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.Manifold.Shade
import Data.Manifold.Types
import Data.Manifold.Types.Primitive ((^), empty)
import Data.Manifold.PseudoAffine
import Data.Manifold.Riemannian
import Data.Manifold.Atlas
import Data.Function.Affine
    
import Data.Embedding

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 ListT (ListT)
import qualified ListT
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

import Development.Placeholders


type Depth = Int
data Wall x = Wall { forall x. Wall x -> (Depth, (Depth, Depth))
_wallID :: (Depth,(Int,Int))
                   , forall x. Wall x -> x
_wallAnchor :: x
                   , forall x. Wall x -> Needle' x
_wallNormal :: Needle' x
                   , forall x. Wall x -> Scalar (Needle x)
_wallDistance :: Scalar (Needle x)
                   }
makeLenses ''Wall


subshadeId' :: ∀ x . (WithField ℝ PseudoAffine x, LinearSpace (Needle x))
                   => x -> NonEmpty (Needle' x) -> x -> (Int, HourglassBulb)
subshadeId' :: forall x.
(WithField ℝ PseudoAffine x, LinearSpace (Needle x)) =>
x -> NonEmpty (Needle' x) -> x -> (Depth, HourglassBulb)
subshadeId' x
c NonEmpty (Needle' x)
expvs x
x = case ( forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualNeedleWitness x
                             , x
x forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~. x
c ) of
    (DualSpaceWitness (Needle x)
DualSpaceWitness, Just Needle x
v)
                    -> let (Depth
iu,Scalar (Needle' x)
vl) = forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. Num a => a -> a
abs forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd)
                                      forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Depth
0..] (forall a b. (a -> b) -> [a] -> [b]
map (Needle x
v forall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Needle' x)
expvs)
                       in (Depth
iu, if Scalar (Needle' x)
vlforall a. Ord a => a -> a -> Bool
>Scalar (Needle' x)
0 then HourglassBulb
UpperBulb else HourglassBulb
LowerBulb)
    (DualSpaceWitness (Needle x), Maybe (Needle x))
_ -> (-Depth
1, forall a. HasCallStack => [Char] -> a
error [Char]
"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 :: forall x.
(WithField ℝ PseudoAffine x, LinearSpace (Needle x),
 FiniteDimensional (Needle' x)) =>
Shade x -> x -> (Depth, HourglassBulb)
subshadeId (Shade x
c Metric' x
expa) = forall x.
(WithField ℝ PseudoAffine x, LinearSpace (Needle x)) =>
x -> NonEmpty (Needle' x) -> x -> (Depth, HourglassBulb)
subshadeId' x
c
                              forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall a. [a] -> NonEmpty a
NE.fromList forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall v.
(FiniteDimensional v, IEEE (Scalar v)) =>
Seminorm v -> [v]
normSpanningSystem' Metric' x
expa
                 





-- | 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 { forall s. Hourglass s -> s
upperBulb, forall s. Hourglass s -> s
lowerBulb :: !s }
            deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall s x. Rep (Hourglass s) x -> Hourglass s
forall s x. Hourglass s -> Rep (Hourglass s) x
$cto :: forall s x. Rep (Hourglass s) x -> Hourglass s
$cfrom :: forall s x. Hourglass s -> Rep (Hourglass s) x
Generic, forall a b. a -> Hourglass b -> Hourglass a
forall a b. (a -> b) -> Hourglass a -> Hourglass b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Hourglass b -> Hourglass a
$c<$ :: forall a b. a -> Hourglass b -> Hourglass a
fmap :: forall a b. (a -> b) -> Hourglass a -> Hourglass b
$cfmap :: forall a b. (a -> b) -> Hourglass a -> Hourglass b
Hask.Functor, forall a. Eq a => a -> Hourglass a -> Bool
forall a. Num a => Hourglass a -> a
forall a. Ord a => Hourglass a -> a
forall m. Monoid m => Hourglass m -> m
forall a. Hourglass a -> Bool
forall a. Hourglass a -> Depth
forall a. Hourglass a -> [a]
forall a. (a -> a -> a) -> Hourglass a -> a
forall m a. Monoid m => (a -> m) -> Hourglass a -> m
forall b a. (b -> a -> b) -> b -> Hourglass a -> b
forall a b. (a -> b -> b) -> b -> Hourglass a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Depth)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Hourglass a -> a
$cproduct :: forall a. Num a => Hourglass a -> a
sum :: forall a. Num a => Hourglass a -> a
$csum :: forall a. Num a => Hourglass a -> a
minimum :: forall a. Ord a => Hourglass a -> a
$cminimum :: forall a. Ord a => Hourglass a -> a
maximum :: forall a. Ord a => Hourglass a -> a
$cmaximum :: forall a. Ord a => Hourglass a -> a
elem :: forall a. Eq a => a -> Hourglass a -> Bool
$celem :: forall a. Eq a => a -> Hourglass a -> Bool
length :: forall a. Hourglass a -> Depth
$clength :: forall a. Hourglass a -> Depth
null :: forall a. Hourglass a -> Bool
$cnull :: forall a. Hourglass a -> Bool
toList :: forall a. Hourglass a -> [a]
$ctoList :: forall a. Hourglass a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Hourglass a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Hourglass a -> a
foldr1 :: forall a. (a -> a -> a) -> Hourglass a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Hourglass a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Hourglass a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Hourglass a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Hourglass a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Hourglass a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Hourglass a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Hourglass a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Hourglass a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Hourglass a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Hourglass a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Hourglass a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Hourglass a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Hourglass a -> m
fold :: forall m. Monoid m => Hourglass m -> m
$cfold :: forall m. Monoid m => Hourglass m -> m
Hask.Foldable, Functor Hourglass
Foldable Hourglass
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
Hourglass (m a) -> m (Hourglass a)
forall (f :: * -> *) a.
Applicative f =>
Hourglass (f a) -> f (Hourglass a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Hourglass a -> m (Hourglass b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Hourglass a -> f (Hourglass b)
sequence :: forall (m :: * -> *) a.
Monad m =>
Hourglass (m a) -> m (Hourglass a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
Hourglass (m a) -> m (Hourglass a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Hourglass a -> m (Hourglass b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Hourglass a -> m (Hourglass b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Hourglass (f a) -> f (Hourglass a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Hourglass (f a) -> f (Hourglass a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Hourglass a -> f (Hourglass b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Hourglass a -> f (Hourglass b)
Hask.Traversable, Depth -> Hourglass s -> ShowS
forall s. Show s => Depth -> Hourglass s -> ShowS
forall s. Show s => [Hourglass s] -> ShowS
forall s. Show s => Hourglass s -> [Char]
forall a.
(Depth -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Hourglass s] -> ShowS
$cshowList :: forall s. Show s => [Hourglass s] -> ShowS
show :: Hourglass s -> [Char]
$cshow :: forall s. Show s => Hourglass s -> [Char]
showsPrec :: Depth -> Hourglass s -> ShowS
$cshowsPrec :: forall s. Show s => Depth -> Hourglass s -> ShowS
Show)
instance (NFData s) => NFData (Hourglass s)
instance (Semigroup s) => Semigroup (Hourglass s) where
  Hourglass s
u s
l <> :: Hourglass s -> Hourglass s -> Hourglass s
<> Hourglass s
u' s
l' = forall s. s -> s -> Hourglass s
Hourglass (s
uforall a. Semigroup a => a -> a -> a
<>s
u') (s
lforall a. Semigroup a => a -> a -> a
<>s
l')
  sconcat :: NonEmpty (Hourglass s) -> Hourglass s
sconcat NonEmpty (Hourglass s)
hgs = let (NonEmpty s
us,NonEmpty s
ls) = forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
NE.unzip forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (forall s. Hourglass s -> s
upperBulbforall (a :: * -> * -> *) b c c'.
(PreArrow a, Object a b, ObjectPair a c c') =>
a b c -> a b c' -> a b (c, c')
&&&forall s. Hourglass s -> s
lowerBulb) forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> NonEmpty (Hourglass s)
hgs
                in forall s. s -> s -> Hourglass s
Hourglass (forall a. Semigroup a => NonEmpty a -> a
sconcat NonEmpty s
us) (forall a. Semigroup a => NonEmpty a -> a
sconcat NonEmpty s
ls)
instance (Monoid s, Semigroup s) => Monoid (Hourglass s) where
  mempty :: Hourglass s
mempty = forall s. s -> s -> Hourglass s
Hourglass forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty; mappend :: Hourglass s -> Hourglass s -> Hourglass s
mappend = forall a. Semigroup a => a -> a -> a
(<>)
  mconcat :: [Hourglass s] -> Hourglass s
mconcat [Hourglass s]
hgs = let ([s]
us,[s]
ls) = forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (forall s. Hourglass s -> s
upperBulbforall (a :: * -> * -> *) b c c'.
(PreArrow a, Object a b, ObjectPair a c c') =>
a b c -> a b c' -> a b (c, c')
&&&forall s. Hourglass s -> s
lowerBulb) forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> [Hourglass s]
hgs
                in forall s. s -> s -> Hourglass s
Hourglass (forall a. Monoid a => [a] -> a
mconcat [s]
us) (forall a. Monoid a => [a] -> a
mconcat [s]
ls)
instance Hask.Applicative Hourglass where
  pure :: forall a. a -> Hourglass a
pure a
x = forall s. s -> s -> Hourglass s
Hourglass a
x a
x
  Hourglass a -> b
f a -> b
g <*> :: forall a b. Hourglass (a -> b) -> Hourglass a -> Hourglass b
<*> Hourglass a
x a
y = forall s. s -> s -> Hourglass s
Hourglass (a -> b
f a
x) (a -> b
g a
y)
instance Foldable Hourglass (->) (->) where
  ffoldl :: forall a b.
(ObjectPair (->) a b, ObjectPair (->) a (Hourglass b)) =>
((a, b) -> a) -> (a, Hourglass b) -> a
ffoldl (a, b) -> a
f (a
x, Hourglass b
a b
b) = (a, b) -> a
f ((a, b) -> a
f(a
x,b
a), b
b)
  foldMap :: forall a m.
(Object (->) a, Object (->) (Hourglass a), Semigroup m, Monoid m,
 Object (->) m, Object (->) m) =>
(a -> m) -> Hourglass a -> m
foldMap a -> m
f (Hourglass a
a a
b) = a -> m
f a
a forall a. Monoid a => a -> a -> a
`mappend` a -> m
f a
b

flipHour :: Hourglass s -> Hourglass s
flipHour :: forall s. Hourglass s -> Hourglass s
flipHour (Hourglass s
u s
l) = forall s. s -> s -> Hourglass s
Hourglass s
l s
u

data HourglassBulb = UpperBulb | LowerBulb
oneBulb :: HourglassBulb -> (a->a) -> Hourglass a->Hourglass a
oneBulb :: forall a. HourglassBulb -> (a -> a) -> Hourglass a -> Hourglass a
oneBulb HourglassBulb
UpperBulb a -> a
f (Hourglass a
u a
l) = forall s. s -> s -> Hourglass s
Hourglass (a -> a
f a
u) a
l
oneBulb HourglassBulb
LowerBulb a -> a
f (Hourglass a
u a
l) = forall s. s -> s -> Hourglass s
Hourglass a
u (a -> a
f a
l)


type LeafCount = Int
type LeafIndex = Int

type ShadeTree x = x`Shaded`()

data Shaded x y = PlainLeaves [(x,y)]
                | DisjointBranches !LeafCount (NonEmpty (x`Shaded`y))
                | OverlappingBranches !LeafCount !(Shade x) (NonEmpty (DBranch x y))
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall x y x. Rep (Shaded x y) x -> Shaded x y
forall x y x. Shaded x y -> Rep (Shaded x y) x
$cto :: forall x y x. Rep (Shaded x y) x -> Shaded x y
$cfrom :: forall x y x. Shaded x y -> Rep (Shaded x y) x
Generic, forall a b. a -> Shaded x b -> Shaded x a
forall a b. (a -> b) -> Shaded x a -> Shaded x b
forall x a b. a -> Shaded x b -> Shaded x a
forall x a b. (a -> b) -> Shaded x a -> Shaded x b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Shaded x b -> Shaded x a
$c<$ :: forall x a b. a -> Shaded x b -> Shaded x a
fmap :: forall a b. (a -> b) -> Shaded x a -> Shaded x b
$cfmap :: forall x a b. (a -> b) -> Shaded x a -> Shaded x b
Hask.Functor, forall a. Shaded x a -> Bool
forall x a. Eq a => a -> Shaded x a -> Bool
forall x a. Num a => Shaded x a -> a
forall x a. Ord a => Shaded x a -> a
forall m a. Monoid m => (a -> m) -> Shaded x a -> m
forall x m. Monoid m => Shaded x m -> m
forall x a. Shaded x a -> Bool
forall x a. Shaded x a -> Depth
forall x a. Shaded x a -> [a]
forall a b. (a -> b -> b) -> b -> Shaded x a -> b
forall x a. (a -> a -> a) -> Shaded x a -> a
forall x m a. Monoid m => (a -> m) -> Shaded x a -> m
forall x b a. (b -> a -> b) -> b -> Shaded x a -> b
forall x a b. (a -> b -> b) -> b -> Shaded x a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Depth)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Shaded x a -> a
$cproduct :: forall x a. Num a => Shaded x a -> a
sum :: forall a. Num a => Shaded x a -> a
$csum :: forall x a. Num a => Shaded x a -> a
minimum :: forall a. Ord a => Shaded x a -> a
$cminimum :: forall x a. Ord a => Shaded x a -> a
maximum :: forall a. Ord a => Shaded x a -> a
$cmaximum :: forall x a. Ord a => Shaded x a -> a
elem :: forall a. Eq a => a -> Shaded x a -> Bool
$celem :: forall x a. Eq a => a -> Shaded x a -> Bool
length :: forall a. Shaded x a -> Depth
$clength :: forall x a. Shaded x a -> Depth
null :: forall a. Shaded x a -> Bool
$cnull :: forall x a. Shaded x a -> Bool
toList :: forall a. Shaded x a -> [a]
$ctoList :: forall x a. Shaded x a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Shaded x a -> a
$cfoldl1 :: forall x a. (a -> a -> a) -> Shaded x a -> a
foldr1 :: forall a. (a -> a -> a) -> Shaded x a -> a
$cfoldr1 :: forall x a. (a -> a -> a) -> Shaded x a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Shaded x a -> b
$cfoldl' :: forall x b a. (b -> a -> b) -> b -> Shaded x a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Shaded x a -> b
$cfoldl :: forall x b a. (b -> a -> b) -> b -> Shaded x a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Shaded x a -> b
$cfoldr' :: forall x a b. (a -> b -> b) -> b -> Shaded x a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Shaded x a -> b
$cfoldr :: forall x a b. (a -> b -> b) -> b -> Shaded x a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Shaded x a -> m
$cfoldMap' :: forall x m a. Monoid m => (a -> m) -> Shaded x a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Shaded x a -> m
$cfoldMap :: forall x m a. Monoid m => (a -> m) -> Shaded x a -> m
fold :: forall m. Monoid m => Shaded x m -> m
$cfold :: forall x m. Monoid m => Shaded x m -> m
Hask.Foldable, forall x. Functor (Shaded x)
forall x. Foldable (Shaded x)
forall x (m :: * -> *) a.
Monad m =>
Shaded x (m a) -> m (Shaded x a)
forall x (f :: * -> *) a.
Applicative f =>
Shaded x (f a) -> f (Shaded x a)
forall x (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Shaded x a -> m (Shaded x b)
forall x (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Shaded x a -> f (Shaded x b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Shaded x a -> f (Shaded x b)
sequence :: forall (m :: * -> *) a. Monad m => Shaded x (m a) -> m (Shaded x a)
$csequence :: forall x (m :: * -> *) a.
Monad m =>
Shaded x (m a) -> m (Shaded x a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Shaded x a -> m (Shaded x b)
$cmapM :: forall x (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Shaded x a -> m (Shaded x b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Shaded x (f a) -> f (Shaded x a)
$csequenceA :: forall x (f :: * -> *) a.
Applicative f =>
Shaded x (f a) -> f (Shaded x a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Shaded x a -> f (Shaded x b)
$ctraverse :: forall x (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Shaded x a -> f (Shaded x b)
Hask.Traversable)
deriving instance ( WithField ℝ PseudoAffine x, Show x
                  , Show x, Show (Needle' x), Show (Metric' x) )
             => Show (ShadeTree x)
           
data DBranch' x c = DBranch { forall x c. DBranch' x c -> Needle' x
boughDirection :: !(Needle' x)
                            , forall x c. DBranch' x c -> Hourglass c
boughContents :: !(Hourglass c) }
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall x c x. Rep (DBranch' x c) x -> DBranch' x c
forall x c x. DBranch' x c -> Rep (DBranch' x c) x
$cto :: forall x c x. Rep (DBranch' x c) x -> DBranch' x c
$cfrom :: forall x c x. DBranch' x c -> Rep (DBranch' x c) x
Generic, forall a b. a -> DBranch' x b -> DBranch' x a
forall a b. (a -> b) -> DBranch' x a -> DBranch' x b
forall x a b. a -> DBranch' x b -> DBranch' x a
forall x a b. (a -> b) -> DBranch' x a -> DBranch' x b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> DBranch' x b -> DBranch' x a
$c<$ :: forall x a b. a -> DBranch' x b -> DBranch' x a
fmap :: forall a b. (a -> b) -> DBranch' x a -> DBranch' x b
$cfmap :: forall x a b. (a -> b) -> DBranch' x a -> DBranch' x b
Hask.Functor, forall a. DBranch' x a -> Bool
forall x a. Eq a => a -> DBranch' x a -> Bool
forall x a. Num a => DBranch' x a -> a
forall x a. Ord a => DBranch' x a -> a
forall m a. Monoid m => (a -> m) -> DBranch' x a -> m
forall x m. Monoid m => DBranch' x m -> m
forall x a. DBranch' x a -> Bool
forall x a. DBranch' x a -> Depth
forall x a. DBranch' x a -> [a]
forall a b. (a -> b -> b) -> b -> DBranch' x a -> b
forall x a. (a -> a -> a) -> DBranch' x a -> a
forall x m a. Monoid m => (a -> m) -> DBranch' x a -> m
forall x b a. (b -> a -> b) -> b -> DBranch' x a -> b
forall x a b. (a -> b -> b) -> b -> DBranch' x a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Depth)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => DBranch' x a -> a
$cproduct :: forall x a. Num a => DBranch' x a -> a
sum :: forall a. Num a => DBranch' x a -> a
$csum :: forall x a. Num a => DBranch' x a -> a
minimum :: forall a. Ord a => DBranch' x a -> a
$cminimum :: forall x a. Ord a => DBranch' x a -> a
maximum :: forall a. Ord a => DBranch' x a -> a
$cmaximum :: forall x a. Ord a => DBranch' x a -> a
elem :: forall a. Eq a => a -> DBranch' x a -> Bool
$celem :: forall x a. Eq a => a -> DBranch' x a -> Bool
length :: forall a. DBranch' x a -> Depth
$clength :: forall x a. DBranch' x a -> Depth
null :: forall a. DBranch' x a -> Bool
$cnull :: forall x a. DBranch' x a -> Bool
toList :: forall a. DBranch' x a -> [a]
$ctoList :: forall x a. DBranch' x a -> [a]
foldl1 :: forall a. (a -> a -> a) -> DBranch' x a -> a
$cfoldl1 :: forall x a. (a -> a -> a) -> DBranch' x a -> a
foldr1 :: forall a. (a -> a -> a) -> DBranch' x a -> a
$cfoldr1 :: forall x a. (a -> a -> a) -> DBranch' x a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> DBranch' x a -> b
$cfoldl' :: forall x b a. (b -> a -> b) -> b -> DBranch' x a -> b
foldl :: forall b a. (b -> a -> b) -> b -> DBranch' x a -> b
$cfoldl :: forall x b a. (b -> a -> b) -> b -> DBranch' x a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> DBranch' x a -> b
$cfoldr' :: forall x a b. (a -> b -> b) -> b -> DBranch' x a -> b
foldr :: forall a b. (a -> b -> b) -> b -> DBranch' x a -> b
$cfoldr :: forall x a b. (a -> b -> b) -> b -> DBranch' x a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> DBranch' x a -> m
$cfoldMap' :: forall x m a. Monoid m => (a -> m) -> DBranch' x a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> DBranch' x a -> m
$cfoldMap :: forall x m a. Monoid m => (a -> m) -> DBranch' x a -> m
fold :: forall m. Monoid m => DBranch' x m -> m
$cfold :: forall x m. Monoid m => DBranch' x m -> m
Hask.Foldable, forall x. Functor (DBranch' x)
forall x. Foldable (DBranch' x)
forall x (m :: * -> *) a.
Monad m =>
DBranch' x (m a) -> m (DBranch' x a)
forall x (f :: * -> *) a.
Applicative f =>
DBranch' x (f a) -> f (DBranch' x a)
forall x (m :: * -> *) a b.
Monad m =>
(a -> m b) -> DBranch' x a -> m (DBranch' x b)
forall x (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> DBranch' x a -> f (DBranch' x b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> DBranch' x a -> f (DBranch' x b)
sequence :: forall (m :: * -> *) a.
Monad m =>
DBranch' x (m a) -> m (DBranch' x a)
$csequence :: forall x (m :: * -> *) a.
Monad m =>
DBranch' x (m a) -> m (DBranch' x a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> DBranch' x a -> m (DBranch' x b)
$cmapM :: forall x (m :: * -> *) a b.
Monad m =>
(a -> m b) -> DBranch' x a -> m (DBranch' x b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
DBranch' x (f a) -> f (DBranch' x a)
$csequenceA :: forall x (f :: * -> *) a.
Applicative f =>
DBranch' x (f a) -> f (DBranch' x a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> DBranch' x a -> f (DBranch' x b)
$ctraverse :: forall x (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> DBranch' x a -> f (DBranch' x b)
Hask.Traversable)
type DBranch x y = DBranch' x (x`Shaded`y)
deriving instance ( WithField ℝ PseudoAffine x, Show (Needle' x), Show c )
             => Show (DBranch' x c)

newtype DBranches' x c = DBranches (NonEmpty (DBranch' x c))
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall x c x. Rep (DBranches' x c) x -> DBranches' x c
forall x c x. DBranches' x c -> Rep (DBranches' x c) x
$cto :: forall x c x. Rep (DBranches' x c) x -> DBranches' x c
$cfrom :: forall x c x. DBranches' x c -> Rep (DBranches' x c) x
Generic, forall a b. a -> DBranches' x b -> DBranches' x a
forall a b. (a -> b) -> DBranches' x a -> DBranches' x b
forall x a b. a -> DBranches' x b -> DBranches' x a
forall x a b. (a -> b) -> DBranches' x a -> DBranches' x b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> DBranches' x b -> DBranches' x a
$c<$ :: forall x a b. a -> DBranches' x b -> DBranches' x a
fmap :: forall a b. (a -> b) -> DBranches' x a -> DBranches' x b
$cfmap :: forall x a b. (a -> b) -> DBranches' x a -> DBranches' x b
Hask.Functor, forall a. DBranches' x a -> Bool
forall x a. Eq a => a -> DBranches' x a -> Bool
forall x a. Num a => DBranches' x a -> a
forall x a. Ord a => DBranches' x a -> a
forall m a. Monoid m => (a -> m) -> DBranches' x a -> m
forall x m. Monoid m => DBranches' x m -> m
forall x a. DBranches' x a -> Bool
forall x a. DBranches' x a -> Depth
forall x a. DBranches' x a -> [a]
forall a b. (a -> b -> b) -> b -> DBranches' x a -> b
forall x a. (a -> a -> a) -> DBranches' x a -> a
forall x m a. Monoid m => (a -> m) -> DBranches' x a -> m
forall x b a. (b -> a -> b) -> b -> DBranches' x a -> b
forall x a b. (a -> b -> b) -> b -> DBranches' x a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Depth)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => DBranches' x a -> a
$cproduct :: forall x a. Num a => DBranches' x a -> a
sum :: forall a. Num a => DBranches' x a -> a
$csum :: forall x a. Num a => DBranches' x a -> a
minimum :: forall a. Ord a => DBranches' x a -> a
$cminimum :: forall x a. Ord a => DBranches' x a -> a
maximum :: forall a. Ord a => DBranches' x a -> a
$cmaximum :: forall x a. Ord a => DBranches' x a -> a
elem :: forall a. Eq a => a -> DBranches' x a -> Bool
$celem :: forall x a. Eq a => a -> DBranches' x a -> Bool
length :: forall a. DBranches' x a -> Depth
$clength :: forall x a. DBranches' x a -> Depth
null :: forall a. DBranches' x a -> Bool
$cnull :: forall x a. DBranches' x a -> Bool
toList :: forall a. DBranches' x a -> [a]
$ctoList :: forall x a. DBranches' x a -> [a]
foldl1 :: forall a. (a -> a -> a) -> DBranches' x a -> a
$cfoldl1 :: forall x a. (a -> a -> a) -> DBranches' x a -> a
foldr1 :: forall a. (a -> a -> a) -> DBranches' x a -> a
$cfoldr1 :: forall x a. (a -> a -> a) -> DBranches' x a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> DBranches' x a -> b
$cfoldl' :: forall x b a. (b -> a -> b) -> b -> DBranches' x a -> b
foldl :: forall b a. (b -> a -> b) -> b -> DBranches' x a -> b
$cfoldl :: forall x b a. (b -> a -> b) -> b -> DBranches' x a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> DBranches' x a -> b
$cfoldr' :: forall x a b. (a -> b -> b) -> b -> DBranches' x a -> b
foldr :: forall a b. (a -> b -> b) -> b -> DBranches' x a -> b
$cfoldr :: forall x a b. (a -> b -> b) -> b -> DBranches' x a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> DBranches' x a -> m
$cfoldMap' :: forall x m a. Monoid m => (a -> m) -> DBranches' x a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> DBranches' x a -> m
$cfoldMap :: forall x m a. Monoid m => (a -> m) -> DBranches' x a -> m
fold :: forall m. Monoid m => DBranches' x m -> m
$cfold :: forall x m. Monoid m => DBranches' x m -> m
Hask.Foldable, forall x. Functor (DBranches' x)
forall x. Foldable (DBranches' x)
forall x (m :: * -> *) a.
Monad m =>
DBranches' x (m a) -> m (DBranches' x a)
forall x (f :: * -> *) a.
Applicative f =>
DBranches' x (f a) -> f (DBranches' x a)
forall x (m :: * -> *) a b.
Monad m =>
(a -> m b) -> DBranches' x a -> m (DBranches' x b)
forall x (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> DBranches' x a -> f (DBranches' x b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> DBranches' x a -> f (DBranches' x b)
sequence :: forall (m :: * -> *) a.
Monad m =>
DBranches' x (m a) -> m (DBranches' x a)
$csequence :: forall x (m :: * -> *) a.
Monad m =>
DBranches' x (m a) -> m (DBranches' x a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> DBranches' x a -> m (DBranches' x b)
$cmapM :: forall x (m :: * -> *) a b.
Monad m =>
(a -> m b) -> DBranches' x a -> m (DBranches' x b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
DBranches' x (f a) -> f (DBranches' x a)
$csequenceA :: forall x (f :: * -> *) a.
Applicative f =>
DBranches' x (f a) -> f (DBranches' x a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> DBranches' x a -> f (DBranches' x b)
$ctraverse :: forall x (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> DBranches' x a -> f (DBranches' x b)
Hask.Traversable)
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 NonEmpty (DBranch' x c)
b1 <> :: DBranches' x c -> DBranches' x c -> DBranches' x c
<> DBranches NonEmpty (DBranch' x c)
b2 = forall x c. NonEmpty (DBranch' x c) -> DBranches' x c
DBranches forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
NE.zipWith (\(DBranch Needle' x
d1 Hourglass c
c1) (DBranch Needle' x
_ Hourglass c
c2)
                                                              -> forall x c. Needle' x -> Hourglass c -> DBranch' x c
DBranch Needle' x
d1 forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Hourglass c
c1forall a. Semigroup a => a -> a -> a
<>Hourglass c
c2 ) NonEmpty (DBranch' x c)
b1 NonEmpty (DBranch' x c)
b2



trunkBranches :: x`Shaded`y -> NonEmpty (LeafIndex, x`Shaded`y)
trunkBranches :: forall x y. Shaded x y -> NonEmpty (Depth, Shaded x y)
trunkBranches (OverlappingBranches Depth
_ Shade x
_ NonEmpty (DBranch x y)
brs)
        = (forall s a. State s a -> s -> a
`evalState`Depth
0)
            forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (NonEmpty (DBranch x y)
brs forall (f :: * -> * -> *) (m :: * -> *) a b.
(Function f, Monad m f, Object f a, Object f b, Object f (m a),
 Object f (m b), Object f (m (m b))) =>
m a -> f a (m b) -> m b
>>= \(DBranch Needle' x
_ (Hourglass Shaded x y
t Shaded x y
b)) -> Shaded x y
tforall a. a -> [a] -> NonEmpty a
:|[Shaded x y
b]) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \Shaded x y
st -> do
               Depth
i₀ <- forall (m :: * -> *) s. Monad m => StateT s m s
get
               forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Depth
i₀ forall a. Num a => a -> a -> a
+ forall x a. Shaded x a -> Depth
nLeaves Shaded x y
st
               forall (m :: * -> *) a. Monad m (->) => a -> m a
return (Depth
i₀, Shaded x y
st)
trunkBranches (DisjointBranches Depth
_ NonEmpty (Shaded x y)
brs) = (forall s a. State s a -> s -> a
`evalState`Depth
0) forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty (Shaded x y)
brs forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \Shaded x y
st -> do
               Depth
i₀ <- forall (m :: * -> *) s. Monad m => StateT s m s
get
               forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Depth
i₀ forall a. Num a => a -> a -> a
+ forall x a. Shaded x a -> Depth
nLeaves Shaded x y
st
               forall (m :: * -> *) a. Monad m (->) => a -> m a
return (Depth
i₀, Shaded x y
st)
trunkBranches Shaded x y
t = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a.
(Applicative f r t, Object r a, Object t (f a)) =>
t a (f a)
pure (Depth
0,Shaded x y
t)
  
directionChoices :: ∀ x y . WithField ℝ Manifold x
               => [DBranch x y]
                 -> [ ( (Needle' x, x`Shaded`y)
                      ,[(Needle' x, x`Shaded`y)] ) ]
directionChoices :: forall x y.
WithField ℝ Manifold x =>
[DBranch x y]
-> [((Needle' x, Shaded x y), [(Needle' x, Shaded x y)])]
directionChoices = case forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness @(Needle x) of
   DualSpaceWitness (Needle x)
DualSpaceWitness -> forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd forall (a :: * -> * -> *) b b' c c'.
(Morphism a, ObjectPair a b b', ObjectPair a c c') =>
a b c -> a b' c' -> a (b, b') (c, c')
*** forall a b. (a -> b) -> [a] -> [b]
map forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd) forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall x y.
(WithField ℝ PseudoAffine x, AdditiveGroup (Needle' x)) =>
Depth
-> [DBranch x y]
-> [((Depth, (Needle' x, Shaded x y)),
     [(Depth, (Needle' x, Shaded x y))])]
directionIChoices Depth
0

directionIChoices :: (WithField ℝ PseudoAffine x, AdditiveGroup (Needle' x))
               => Int -> [DBranch x y]
                 -> [ ( (Int, (Needle' x, x`Shaded`y))
                      ,[(Int, (Needle' x, x`Shaded`y))] ) ]
directionIChoices :: forall x y.
(WithField ℝ PseudoAffine x, AdditiveGroup (Needle' x)) =>
Depth
-> [DBranch x y]
-> [((Depth, (Needle' x, Shaded x y)),
     [(Depth, (Needle' x, Shaded x y))])]
directionIChoices Depth
_ [] = []
directionIChoices Depth
i₀ (DBranch Needle' x
ѧ (Hourglass Shaded x y
t Shaded x y
b) : [DBranch x y]
hs)
         =  ( (Depth, (Needle' x, Shaded x y))
top, (Depth, (Needle' x, Shaded x y))
bot forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst [((Depth, (Needle' x, Shaded x y)),
  [(Depth, (Needle' x, Shaded x y))])]
uds )
          forall a. a -> [a] -> [a]
: ( (Depth, (Needle' x, Shaded x y))
bot, (Depth, (Needle' x, Shaded x y))
top forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst [((Depth, (Needle' x, Shaded x y)),
  [(Depth, (Needle' x, Shaded x y))])]
uds )
          forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) d b c.
(Morphism a, ObjectPair a d b, ObjectPair a d c) =>
a b c -> a (d, b) (d, c)
second forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ ((Depth, (Needle' x, Shaded x y))
topforall a. a -> [a] -> [a]
:) forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. ((Depth, (Needle' x, Shaded x y))
botforall a. a -> [a] -> [a]
:)) [((Depth, (Needle' x, Shaded x y)),
  [(Depth, (Needle' x, Shaded x y))])]
uds
 where top :: (Depth, (Needle' x, Shaded x y))
top = (Depth
i₀,(Needle' x
ѧ,Shaded x y
t))
       bot :: (Depth, (Needle' x, Shaded x y))
bot = (Depth
i₀forall a. Num a => a -> a -> a
+Depth
1,(forall v. AdditiveGroup v => v -> v
negateV Needle' x
ѧ,Shaded x y
b))
       uds :: [((Depth, (Needle' x, Shaded x y)),
  [(Depth, (Needle' x, Shaded x y))])]
uds = forall x y.
(WithField ℝ PseudoAffine x, AdditiveGroup (Needle' x)) =>
Depth
-> [DBranch x y]
-> [((Depth, (Needle' x, Shaded x y)),
     [(Depth, (Needle' x, Shaded x y))])]
directionIChoices (Depth
i₀forall a. Num a => a -> a -> a
+Depth
2) [DBranch x y]
hs

traverseDirectionChoices :: ( AdditiveGroup (Needle' x), Hask.Applicative f )
               => (    (Int, (Needle' x, x`Shaded`y))
                    -> [(Int, (Needle' x, x`Shaded`y))]
                    -> f (x`Shaded`z) )
                 -> [DBranch x y]
                 -> f [DBranch x z]
traverseDirectionChoices :: forall x (f :: * -> *) y z.
(AdditiveGroup (Needle' x), Applicative f) =>
((Depth, (Needle' x, Shaded x y))
 -> [(Depth, (Needle' x, Shaded x y))] -> f (Shaded x z))
-> [DBranch x y] -> f [DBranch x z]
traverseDirectionChoices (Depth, (Needle' x, Shaded x y))
-> [(Depth, (Needle' x, Shaded x y))] -> f (Shaded x z)
f [DBranch x y]
dbs
           = [(Depth, (Needle' x, Shaded x y))]
-> [(Depth, (Needle' x, Shaded x y))]
-> f [DBranch' x (Shaded x z)]
td [] forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall {a} {x} {y}.
Depth -> [(a, Shaded x y)] -> [(Depth, (a, Shaded x y))]
scanLeafNums Depth
0
               forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ [DBranch x y]
dbs forall (f :: * -> * -> *) (m :: * -> *) a b.
(Function f, Monad m f, Object f a, Object f b, Object f (m a),
 Object f (m b), Object f (m (m b))) =>
m a -> f a (m b) -> m b
>>= \(DBranch Needle' x
ѧ (Hourglass Shaded x y
τ Shaded x y
β))
                              -> [(Needle' x
ѧ,Shaded x y
τ), (forall v. AdditiveGroup v => v -> v
negateV Needle' x
ѧ,Shaded x y
β)]
 where td :: [(Depth, (Needle' x, Shaded x y))]
-> [(Depth, (Needle' x, Shaded x y))]
-> f [DBranch' x (Shaded x z)]
td [(Depth, (Needle' x, Shaded x y))]
pds (ѧt :: (Depth, (Needle' x, Shaded x y))
ѧt@(Depth
_,(Needle' x
ѧ,Shaded x y
_)):(Depth, (Needle' x, Shaded x y))
vb:[(Depth, (Needle' x, Shaded x y))]
vds)
         = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) c d b a.
(Applicative f r t, Object r c, Object r d, ObjectMorphism r c d,
 ObjectMorphism r b (r c d), Object r (r c d), ObjectPair r a b,
 ObjectPair r (r c d) c, Object t (f c), Object t (f d),
 Object t (f a, f b), ObjectMorphism t (f c) (f d),
 ObjectMorphism t (f b) (t (f c) (f d)), Object t (t (f c) (f d)),
 ObjectPair t (f a) (f b), ObjectPair t (t (f c) (f d)) (f c),
 ObjectPair t (f (r c d)) (f c)) =>
r a (r b (r c d)) -> t (f a) (t (f b) (t (f c) (f d)))
liftA3 (\Shaded x z
t' Shaded x z
b' -> (forall x c. Needle' x -> Hourglass c -> DBranch' x c
DBranch Needle' x
ѧ (forall s. s -> s -> Hourglass s
Hourglass Shaded x z
t' Shaded x z
b') forall a. a -> [a] -> [a]
:))
             ((Depth, (Needle' x, Shaded x y))
-> [(Depth, (Needle' x, Shaded x y))] -> f (Shaded x z)
f (Depth, (Needle' x, Shaded x y))
ѧt forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (Depth, (Needle' x, Shaded x y))
vbforall a. a -> [a] -> [a]
:[(Depth, (Needle' x, Shaded x y))]
uds)
             ((Depth, (Needle' x, Shaded x y))
-> [(Depth, (Needle' x, Shaded x y))] -> f (Shaded x z)
f (Depth, (Needle' x, Shaded x y))
vb forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (Depth, (Needle' x, Shaded x y))
ѧtforall a. a -> [a] -> [a]
:[(Depth, (Needle' x, Shaded x y))]
uds)
             forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ [(Depth, (Needle' x, Shaded x y))]
-> [(Depth, (Needle' x, Shaded x y))]
-> f [DBranch' x (Shaded x z)]
td ((Depth, (Needle' x, Shaded x y))
ѧtforall a. a -> [a] -> [a]
:(Depth, (Needle' x, Shaded x y))
vbforall a. a -> [a] -> [a]
:[(Depth, (Needle' x, Shaded x y))]
pds) [(Depth, (Needle' x, Shaded x y))]
vds
        where uds :: [(Depth, (Needle' x, Shaded x y))]
uds = [(Depth, (Needle' x, Shaded x y))]
pds forall a. [a] -> [a] -> [a]
++ [(Depth, (Needle' x, Shaded x y))]
vds
       td [(Depth, (Needle' x, Shaded x y))]
_ [(Depth, (Needle' x, Shaded x y))]
_ = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a.
(Applicative f r t, Object r a, Object t (f a)) =>
t a (f a)
pure []
       scanLeafNums :: Depth -> [(a, Shaded x y)] -> [(Depth, (a, Shaded x y))]
scanLeafNums Depth
_ [] = []
       scanLeafNums Depth
i₀ ((a
v,Shaded x y
t):[(a, Shaded x y)]
vts) = (Depth
i₀, (a
v,Shaded x y
t)) forall a. a -> [a] -> [a]
: Depth -> [(a, Shaded x y)] -> [(Depth, (a, Shaded x y))]
scanLeafNums (Depth
i₀ forall a. Num a => a -> a -> a
+ forall x a. Shaded x a -> Depth
nLeaves Shaded x y
t) [(a, Shaded x y)]
vts



traverseTrunkBranchChoices :: Hask.Applicative f
               => ( (Int, x`Shaded`y) -> x`Shaded`y -> f (x`Shaded`z) )
                 -> x`Shaded`y -> f (x`Shaded`z)
traverseTrunkBranchChoices :: forall (f :: * -> *) x y z.
Applicative f =>
((Depth, Shaded x y) -> Shaded x y -> f (Shaded x z))
-> Shaded x y -> f (Shaded x z)
traverseTrunkBranchChoices (Depth, Shaded x y) -> Shaded x y -> f (Shaded x z)
f (OverlappingBranches Depth
n Shade x
sh NonEmpty (DBranch' x (Shaded x y))
bs)
        = forall x y.
Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
OverlappingBranches Depth
n Shade x
sh forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall a. [a] -> NonEmpty a
NE.fromList forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> Depth
-> ([DBranch' x (Shaded x y)] -> [DBranch' x (Shaded x y)])
-> [DBranch' x (Shaded x y)]
-> f [DBranch' x (Shaded x z)]
go Depth
0 forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id (forall a. NonEmpty a -> [a]
NE.toList NonEmpty (DBranch' x (Shaded x y))
bs)
 where go :: Depth
-> ([DBranch' x (Shaded x y)] -> [DBranch' x (Shaded x y)])
-> [DBranch' x (Shaded x y)]
-> f [DBranch' x (Shaded x z)]
go Depth
_ [DBranch' x (Shaded x y)] -> [DBranch' x (Shaded x y)]
_ [] = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a.
(Applicative f r t, Object r a, Object t (f a)) =>
t a (f a)
pure []
       go Depth
i₀ [DBranch' x (Shaded x y)] -> [DBranch' x (Shaded x y)]
prbs (tbs :: DBranch' x (Shaded x y)
tbs@(DBranch Needle' x
v (Hourglass Shaded x y
τ Shaded x y
β)) : [DBranch' x (Shaded x y)]
dbs)
        = (:) forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall x c. Needle' x -> Hourglass c -> DBranch' x c
DBranch Needle' x
v forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>
            (forall s. s -> s -> Hourglass s
Hourglass forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> ((Depth, Shaded x y) -> Shaded x y -> f (Shaded x z)
f (Depth
i₀, Shaded x y
τ) forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall x y.
Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
OverlappingBranches (Depth
nforall a. Num a => a -> a -> a
-Depth
nτ) Shade x
sh
                            forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall a. [a] -> NonEmpty a
NE.fromList forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. [DBranch' x (Shaded x y)] -> [DBranch' x (Shaded x y)]
prbs forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall x c. Needle' x -> Hourglass c -> DBranch' x c
DBranch Needle' x
v (forall s. s -> s -> Hourglass s
Hourglass forall {x} {y}. Shaded x y
hole Shaded x y
β) forall a. a -> [a] -> [a]
: [DBranch' x (Shaded x y)]
dbs)
                       forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Applicative f r t, ObjectMorphism r a b,
 ObjectMorphism t (f a) (f b), Object t (t (f a) (f b)),
 ObjectPair r (r a b) a, ObjectPair t (f (r a b)) (f a), Object r a,
 Object r b) =>
t (f (r a b)) (t (f a) (f b))
<*> ((Depth, Shaded x y) -> Shaded x y -> f (Shaded x z)
f (Depth
i₀forall a. Num a => a -> a -> a
+Depth
nτ, Shaded x y
β) forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall x y.
Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
OverlappingBranches (Depth
nforall a. Num a => a -> a -> a
-Depth
nβ) Shade x
sh
                            forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall a. [a] -> NonEmpty a
NE.fromList forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. [DBranch' x (Shaded x y)] -> [DBranch' x (Shaded x y)]
prbs forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall x c. Needle' x -> Hourglass c -> DBranch' x c
DBranch Needle' x
v (forall s. s -> s -> Hourglass s
Hourglass Shaded x y
τ forall {x} {y}. Shaded x y
hole) forall a. a -> [a] -> [a]
: [DBranch' x (Shaded x y)]
dbs))
            forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Applicative f r t, ObjectMorphism r a b,
 ObjectMorphism t (f a) (f b), Object t (t (f a) (f b)),
 ObjectPair r (r a b) a, ObjectPair t (f (r a b)) (f a), Object r a,
 Object r b) =>
t (f (r a b)) (t (f a) (f b))
<*> Depth
-> ([DBranch' x (Shaded x y)] -> [DBranch' x (Shaded x y)])
-> [DBranch' x (Shaded x y)]
-> f [DBranch' x (Shaded x z)]
go (Depth
i₀forall a. Num a => a -> a -> a
+Depth
nτforall a. Num a => a -> a -> a
+Depth
nβ) ([DBranch' x (Shaded x y)] -> [DBranch' x (Shaded x y)]
prbs forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. (DBranch' x (Shaded x y)
tbsforall a. a -> [a] -> [a]
:)) [DBranch' x (Shaded x y)]
dbs
        where [Depth
nτ, Depth
nβ] = forall x a. Shaded x a -> Depth
nLeavesforall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>[Shaded x y
τ,Shaded x y
β]
              hole :: Shaded x y
hole = forall x y. [(x, y)] -> Shaded x y
PlainLeaves []


indexDBranches :: NonEmpty (DBranch x y) -> NonEmpty (DBranch' x (Int, x`Shaded`y))
indexDBranches :: forall x y.
NonEmpty (DBranch x y) -> NonEmpty (DBranch' x (Depth, Shaded x y))
indexDBranches (DBranch DualVector (Needle x)
d (Hourglass Shaded x y
t Shaded x y
b) :| [DBranch x y]
l) -- this could more concisely be written as a traversal
              = forall x c. Needle' x -> Hourglass c -> DBranch' x c
DBranch DualVector (Needle x)
d (forall s. s -> s -> Hourglass s
Hourglass (Depth
0,Shaded x y
t) (Depth
nt,Shaded x y
b)) forall a. a -> [a] -> NonEmpty a
:| forall {x} {x} {x} {y}.
(DualVector (Needle x) ~ DualVector (Needle x)) =>
Depth
-> [DBranch' x (Shaded x y)] -> [DBranch' x (Depth, Shaded x y)]
ixDBs (Depth
nt forall a. Num a => a -> a -> a
+ Depth
nb) [DBranch x y]
l
 where nt :: Depth
nt = forall x a. Shaded x a -> Depth
nLeaves Shaded x y
t; nb :: Depth
nb = forall x a. Shaded x a -> Depth
nLeaves Shaded x y
b
       ixDBs :: Depth
-> [DBranch' x (Shaded x y)] -> [DBranch' x (Depth, Shaded x y)]
ixDBs Depth
_ [] = []
       ixDBs Depth
i₀ (DBranch DualVector (Needle x)
δ (Hourglass Shaded x y
τ Shaded x y
β) : [DBranch' x (Shaded x y)]
l)
               = forall x c. Needle' x -> Hourglass c -> DBranch' x c
DBranch DualVector (Needle x)
δ (forall s. s -> s -> Hourglass s
Hourglass (Depth
i₀,Shaded x y
τ) (Depth
i₀forall a. Num a => a -> a -> a
+Depth
nτ,Shaded x y
β)) forall a. a -> [a] -> [a]
: Depth
-> [DBranch' x (Shaded x y)] -> [DBranch' x (Depth, Shaded x y)]
ixDBs (Depth
i₀ forall a. Num a => a -> a -> a
+ Depth
nτ forall a. Num a => a -> a -> a
+ Depth
nβ) [DBranch' x (Shaded x y)]
l
        where nτ :: Depth
nτ = forall x a. Shaded x a -> Depth
nLeaves Shaded x y
τ; nβ :: Depth
nβ = forall x a. Shaded x a -> Depth
nLeaves Shaded x y
β

instance (NFData x, NFData (Needle' x), NFData y) => NFData (x`Shaded`y) where
  rnf :: Shaded x y -> ()
rnf (PlainLeaves [(x, y)]
xs) = forall a. NFData a => a -> ()
rnf [(x, y)]
xs
  rnf (DisjointBranches Depth
n NonEmpty (Shaded x y)
bs) = Depth
n seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf (forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Shaded x y)
bs)
  rnf (OverlappingBranches Depth
n Shade x
sh NonEmpty (DBranch x y)
bs) = Depth
n seq :: forall a b. a -> b -> b
`seq` Shade x
sh seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf (forall a. NonEmpty a -> [a]
NE.toList NonEmpty (DBranch x y)
bs)
instance (NFData x, NFData (Needle' x), NFData y) => NFData (DBranch x y)
  

-- | WRT union.
instance (WithField ℝ Manifold x, SimpleSpace (Needle x)) => Semigroup (ShadeTree x) where
  PlainLeaves [] <> :: ShadeTree x -> ShadeTree x -> ShadeTree x
<> ShadeTree x
t = ShadeTree x
t
  ShadeTree x
t <> PlainLeaves [] = ShadeTree x
t
  ShadeTree x
t <> ShadeTree x
s = forall x.
(WithField ℝ Manifold x, SimpleSpace (Needle x)) =>
[x] -> ShadeTree x
fromLeafPoints forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall x. WithField ℝ PseudoAffine x => ShadeTree x -> [x]
onlyLeaves_ ShadeTree x
t forall a. [a] -> [a] -> [a]
++ forall x. WithField ℝ PseudoAffine x => ShadeTree x -> [x]
onlyLeaves_ ShadeTree x
s
           -- Could probably be done more efficiently
  sconcat :: NonEmpty (ShadeTree x) -> ShadeTree x
sconcat = forall a. Monoid a => [a] -> a
mconcat forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall a. NonEmpty a -> [a]
NE.toList
instance (WithField ℝ Manifold x, SimpleSpace (Needle x)) => Monoid (ShadeTree x) where
  mempty :: ShadeTree x
mempty = forall x y. [(x, y)] -> Shaded x y
PlainLeaves []
  mappend :: ShadeTree x -> ShadeTree x -> ShadeTree x
mappend = forall a. Semigroup a => a -> a -> a
(<>)
  mconcat :: [ShadeTree x] -> ShadeTree x
mconcat [ShadeTree x]
l = case forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a.
(SumToProduct f r t, Object r a, Object r Bool, Object t (f a)) =>
r a Bool -> t (f a) (f a)
filter forall x a. Shaded x a -> Bool
ne [ShadeTree x]
l of
               [] -> forall a. Monoid a => a
mempty
               [ShadeTree x
t] -> ShadeTree x
t
               [ShadeTree x]
l' -> forall x.
(WithField ℝ Manifold x, SimpleSpace (Needle x)) =>
[x] -> ShadeTree x
fromLeafPoints forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall x. WithField ℝ PseudoAffine x => ShadeTree x -> [x]
onlyLeaves_ forall (m :: * -> *) (k :: * -> * -> *) a b.
(Monad m k, Object k a, Object k b, Object k (m a), Object k (m b),
 Object k (m (m b))) =>
k a (m b) -> k (m a) (m b)
=<< [ShadeTree x]
l'
   where ne :: Shaded x y -> Bool
ne (PlainLeaves []) = Bool
False; ne Shaded x y
_ = Bool
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 :: forall x.
(WithField ℝ Manifold x, SimpleSpace (Needle x)) =>
[x] -> ShadeTree x
fromLeafPoints = forall x y.
(WithField ℝ Manifold x, SimpleSpace (Needle x)) =>
[(x, y)] -> Shaded x y
fromLeafPoints_ forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall a b. (a -> b) -> [a] -> [b]
map (,())

fromLeafPoints_ :: ∀ x y. (WithField ℝ Manifold x, SimpleSpace (Needle x))
                        => [(x,y)] -> x`Shaded`y
fromLeafPoints_ :: forall x y.
(WithField ℝ Manifold x, SimpleSpace (Needle x)) =>
[(x, y)] -> Shaded x y
fromLeafPoints_ = forall x y.
(WithField ℝ Manifold x, SimpleSpace (Needle x)) =>
(Shade x -> [(x, y)] -> NonEmpty (DBranch' x [(x, y)]))
-> [(x, y)] -> Shaded x y
fromLeafPoints' forall x y.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
Shade x -> [(x, y)] -> NonEmpty (DBranch' x [(x, y)])
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 y . x`Shaded`y -> Int -> Either Int ([x`Shaded`y], (x,y))
indexShadeTree :: forall x y.
Shaded x y -> Depth -> Either Depth ([Shaded x y], (x, y))
indexShadeTree Shaded x y
_ Depth
i
    | Depth
iforall a. Ord a => a -> a -> Bool
<Depth
0        = forall a b. a -> Either a b
Left Depth
i
indexShadeTree sh :: Shaded x y
sh@(PlainLeaves [(x, y)]
lvs) Depth
i = case forall (t :: * -> *) a. Foldable t => t a -> Depth
length [(x, y)]
lvs of
  Depth
n | Depth
iforall a. Ord a => a -> a -> Bool
<Depth
n       -> forall a b. b -> Either a b
Right ([Shaded x y
sh], [(x, y)]
lvsforall a. [a] -> Depth -> a
!!Depth
i)
    | Bool
otherwise -> forall a b. a -> Either a b
Left forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Depth
iforall a. Num a => a -> a -> a
-Depth
n
indexShadeTree (DisjointBranches Depth
n NonEmpty (Shaded x y)
brs) Depth
i
    | Depth
iforall a. Ord a => a -> a -> Bool
<Depth
n        = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\case 
                             Left Depth
i' -> (forall x y.
Shaded x y -> Depth -> Either Depth ([Shaded x y], (x, y))
`indexShadeTree`Depth
i')
                             Either Depth ([Shaded x y], (x, y))
result  -> forall (m :: * -> *) a. Monad m (->) => a -> m a
return Either Depth ([Shaded x y], (x, y))
result
                         ) (forall a b. a -> Either a b
Left Depth
i) NonEmpty (Shaded x y)
brs
    | Bool
otherwise  = forall a b. a -> Either a b
Left forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Depth
iforall a. Num a => a -> a -> a
-Depth
n
indexShadeTree sh :: Shaded x y
sh@(OverlappingBranches Depth
n Shade x
_ NonEmpty (DBranch x y)
brs) Depth
i
    | Depth
iforall a. Ord a => a -> a -> Bool
<Depth
n        = forall (a :: * -> * -> *) b d c.
(Morphism a, ObjectPair a b d, ObjectPair a c d) =>
a b c -> a (b, d) (c, d)
first (Shaded x y
shforall a. a -> [a] -> [a]
:) forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\case 
                             Left Depth
i' -> (forall x y.
Shaded x y -> Depth -> Either Depth ([Shaded x y], (x, y))
`indexShadeTree`Depth
i')
                             Either Depth ([Shaded x y], (x, y))
result  -> forall (m :: * -> *) a. Monad m (->) => a -> m a
return Either Depth ([Shaded x y], (x, y))
result
                         ) (forall a b. a -> Either a b
Left Depth
i) (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (DBranch x y)
brsforall (f :: * -> * -> *) (m :: * -> *) a b.
(Function f, Monad m f, Object f a, Object f b, Object f (m a),
 Object f (m b), Object f (m (m b))) =>
m a -> f a (m b) -> m b
>>=forall (t :: * -> *) a. Foldable t => t a -> [a]
toList)
    | Bool
otherwise  = forall a b. a -> Either a b
Left forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Depth
iforall a. Num a => a -> a -> a
-Depth
n

treeLeaf :: ∀ x y f . Hask.Functor f
        => Int -> (y -> f y) -> x`Shaded`y -> Either Int (f (x`Shaded`y))
treeLeaf :: forall x y (f :: * -> *).
Functor f =>
Depth -> (y -> f y) -> Shaded x y -> Either Depth (f (Shaded x y))
treeLeaf Depth
i y -> f y
_ Shaded x y
_
    | Depth
iforall a. Ord a => a -> a -> Bool
<Depth
0        = forall a b. a -> Either a b
Left Depth
i
treeLeaf Depth
i y -> f y
f sh :: Shaded x y
sh@(PlainLeaves [(x, y)]
lvs) = case forall (t :: * -> *) a. Foldable t => t a -> Depth
length [(x, y)]
lvs of
  Depth
n | Depth
iforall a. Ord a => a -> a -> Bool
<Depth
n
    , ([(x, y)]
pre, (x
x,y
node):[(x, y)]
post) <- forall a. Depth -> [a] -> ([a], [a])
splitAt Depth
i [(x, y)]
lvs
              -> forall a b. b -> Either a b
Right forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (forall x y. [(x, y)] -> Shaded x y
PlainLeaves forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. ([(x, y)]
preforall a. [a] -> [a] -> [a]
++) forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. (forall a. a -> [a] -> [a]
:[(x, y)]
post) forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. (x
x,)) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ y -> f y
f y
node
    | Bool
otherwise -> forall a b. a -> Either a b
Left forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Depth
iforall a. Num a => a -> a -> a
-Depth
n
treeLeaf Depth
i y -> f y
f (DisjointBranches Depth
n NonEmpty (Shaded x y)
_)
    | Depth
iforall a. Ord a => a -> a -> Bool
>=Depth
n   = forall a b. a -> Either a b
Left forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Depth
iforall a. Num a => a -> a -> a
-Depth
n
treeLeaf Depth
i y -> f y
f (DisjointBranches Depth
n (Shaded x y
br:|[]))
        = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (forall x y. Depth -> NonEmpty (Shaded x y) -> Shaded x y
DisjointBranches Depth
n forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a.
(Applicative f r t, Object r a, Object t (f a)) =>
t a (f a)
pure) forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> forall x y (f :: * -> *).
Functor f =>
Depth -> (y -> f y) -> Shaded x y -> Either Depth (f (Shaded x y))
treeLeaf Depth
i y -> f y
f Shaded x y
br
treeLeaf Depth
i y -> f y
f (DisjointBranches Depth
n (Shaded x y
br:|Shaded x y
br':[Shaded x y]
brs))
        = case forall x y (f :: * -> *).
Functor f =>
Depth -> (y -> f y) -> Shaded x y -> Either Depth (f (Shaded x y))
treeLeaf Depth
i y -> f y
f Shaded x y
br of
            Left Depth
overshoot -> forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (\(DisjointBranches Depth
_ (Shaded x y
br'':|[Shaded x y]
brs'))
                                   -> forall x y. Depth -> NonEmpty (Shaded x y) -> Shaded x y
DisjointBranches Depth
n (Shaded x y
brforall a. a -> [a] -> NonEmpty a
:|Shaded x y
br''forall a. a -> [a] -> [a]
:[Shaded x y]
brs'))
                  forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> forall x y (f :: * -> *).
Functor f =>
Depth -> (y -> f y) -> Shaded x y -> Either Depth (f (Shaded x y))
treeLeaf Depth
overshoot y -> f y
f
                     (forall x y. Depth -> NonEmpty (Shaded x y) -> Shaded x y
DisjointBranches (Depth
nforall a. Num a => a -> a -> a
-forall x a. Shaded x a -> Depth
nLeaves Shaded x y
br) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Shaded x y
br'forall a. a -> [a] -> NonEmpty a
:|[Shaded x y]
brs)
            Right f (Shaded x y)
done -> forall a b. b -> Either a b
Right forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall x y. Depth -> NonEmpty (Shaded x y) -> Shaded x y
DisjointBranches Depth
n forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. (forall a. a -> [a] -> NonEmpty a
:|Shaded x y
br'forall a. a -> [a] -> [a]
:[Shaded x y]
brs) forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> f (Shaded x y)
done
treeLeaf Depth
i y -> f y
f (OverlappingBranches Depth
n Shade x
extend (br :: DBranch x y
br@(DBranch Needle' x
dir (Hourglass Shaded x y
t Shaded x y
b)):|[DBranch x y]
brs))
    | Depth
iforall a. Ord a => a -> a -> Bool
<Depth
nt       = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (forall x y.
Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
OverlappingBranches Depth
n Shade x
extend
                         forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. (forall a. a -> [a] -> NonEmpty a
:|[DBranch x y]
brs) forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall x c. Needle' x -> Hourglass c -> DBranch' x c
DBranch Needle' x
dir forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. (forall s. s -> s -> Hourglass s
`Hourglass`Shaded x y
b))
                    forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> forall x y (f :: * -> *).
Functor f =>
Depth -> (y -> f y) -> Shaded x y -> Either Depth (f (Shaded x y))
treeLeaf Depth
i y -> f y
f Shaded x y
t
    | Depth
iforall a. Ord a => a -> a -> Bool
<Depth
ntforall a. Num a => a -> a -> a
+Depth
nb    = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (forall x y.
Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
OverlappingBranches Depth
n Shade x
extend
                         forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. (forall a. a -> [a] -> NonEmpty a
:|[DBranch x y]
brs) forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall x c. Needle' x -> Hourglass c -> DBranch' x c
DBranch Needle' x
dir forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. ( forall s. s -> s -> Hourglass s
Hourglass Shaded x y
t))
                    forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> forall x y (f :: * -> *).
Functor f =>
Depth -> (y -> f y) -> Shaded x y -> Either Depth (f (Shaded x y))
treeLeaf (Depth
iforall a. Num a => a -> a -> a
-Depth
nt) y -> f y
f Shaded x y
b
    | DBranch x y
br':[DBranch x y]
brs' <- [DBranch x y]
brs
                 = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (\(OverlappingBranches Depth
_ Shade x
_ (DBranch x y
br'':|[DBranch x y]
brs''))
                         -> forall x y.
Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
OverlappingBranches Depth
n Shade x
extend forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ DBranch x y
brforall a. a -> [a] -> NonEmpty a
:|DBranch x y
br''forall a. a -> [a] -> [a]
:[DBranch x y]
brs'')
                    forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> forall x y (f :: * -> *).
Functor f =>
Depth -> (y -> f y) -> Shaded x y -> Either Depth (f (Shaded x y))
treeLeaf (Depth
iforall a. Num a => a -> a -> a
-Depth
ntforall a. Num a => a -> a -> a
-Depth
nb) y -> f y
f (forall x y.
Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
OverlappingBranches Depth
n Shade x
extend forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ DBranch x y
br'forall a. a -> [a] -> NonEmpty a
:|[DBranch x y]
brs')
    | Bool
otherwise  = forall a b. a -> Either a b
Left forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Depth
i forall a. Num a => a -> a -> a
- Depth
nt forall a. Num a => a -> a -> a
- Depth
nb
 where [Depth
nt,Depth
nb] = forall x a. Shaded x a -> Depth
nLeavesforall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>[Shaded x y
t,Shaded x y
b]


-- | “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 y . (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.
        -> (x`Shaded`y)      -- ^ The tree to index into
        -> x                 -- ^ Position to look up
        -> Maybe (Int, ([x`Shaded`y], (x,y)))
                   -- ^ 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+info of the found node.
positionIndex :: forall x y.
(WithField ℝ Manifold x, SimpleSpace (Needle x)) =>
Maybe (Metric x)
-> Shaded x y -> x -> Maybe (Depth, ([Shaded x y], (x, y)))
positionIndex (Just Metric x
m) sh :: Shaded x y
sh@(PlainLeaves [(x, y)]
lvs) x
x
        = case forall a. [Maybe a] -> [a]
catMaybes [ ((Depth
i,(x, y)
p),) forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall v. LSpace v => Seminorm v -> v -> Scalar v
normSq Metric x
m forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst (x, y)
pforall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
x
                            | (Depth
i,(x, y)
p) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Depth
0..] [(x, y)]
lvs] of
           [] -> forall (f :: * -> *) a. Alternative f => f a
empty
           [((Depth, (x, y)), Scalar (Needle x))]
l | ((Depth
i,(x, y)
p),Scalar (Needle x)
_) <- forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd) [((Depth, (x, y)), Scalar (Needle x))]
l
              -> forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a.
(Applicative f r t, Object r a, Object t (f a)) =>
t a (f a)
pure (Depth
i, ([Shaded x y
sh], (x, y)
p))
positionIndex Maybe (Metric x)
m (DisjointBranches Depth
_ NonEmpty (Shaded x y)
brs) x
x
        = forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\case
                          (q :: Maybe (Depth, ([Shaded x y], (x, y)))
q@(Just (Depth, ([Shaded x y], (x, y)))
_), Depth
i₀) -> forall (a :: * -> * -> *) b x.
(WellPointed a, Object a b, ObjectPoint a x) =>
x -> a b x
const (Maybe (Depth, ([Shaded x y], (x, y)))
q, Depth
i₀)
                          (Maybe (Depth, ([Shaded x y], (x, y)))
_, Depth
i₀) -> \Shaded x y
t' -> ( forall (a :: * -> * -> *) b d c.
(Morphism a, ObjectPair a b d, ObjectPair a c d) =>
a b c -> a (b, d) (c, d)
first (forall a. Num a => a -> a -> a
+Depth
i₀) forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> forall x y.
(WithField ℝ Manifold x, SimpleSpace (Needle x)) =>
Maybe (Metric x)
-> Shaded x y -> x -> Maybe (Depth, ([Shaded x y], (x, y)))
positionIndex Maybe (Metric x)
m Shaded x y
t' x
x
                                            , Depth
i₀forall a. Num a => a -> a -> a
+forall x a. Shaded x a -> Depth
nLeaves Shaded x y
t' ) )
                       (forall (f :: * -> *) a. Alternative f => f a
empty, Depth
0)
              forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$        NonEmpty (Shaded x y)
brs
positionIndex Maybe (Metric x)
_ sh :: Shaded x y
sh@(OverlappingBranches Depth
n (Shade x
c Metric' x
ce) NonEmpty (DBranch x y)
brs) x
x
   | PseudoAffineWitness SemimanifoldWitness x
SemimanifoldWitness
               <- forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness :: PseudoAffineWitness x
   , Just Needle x
vx <- x
xforall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
c
        = let (ℝ
_,(Depth
i₀,Shaded x y
t')) = forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst)
                       [ (ℝ
σforall a. Num a => a -> a -> a
*Scalar (Needle x)
ω, (Depth, Shaded x y)
t')
                       | DBranch Needle' x
d (Hourglass (Depth, Shaded x y)
t'u (Depth, Shaded x y)
t'd) <- forall a. NonEmpty a -> [a]
NE.toList forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall x y.
NonEmpty (DBranch x y) -> NonEmpty (DBranch' x (Depth, Shaded x y))
indexDBranches NonEmpty (DBranch x y)
brs
                       , let ω :: Scalar (Needle x)
ω = Needle' x
dforall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^Needle x
vx
                       , ((Depth, Shaded x y)
t',ℝ
σ) <- [((Depth, Shaded x y)
t'u, ℝ
1), ((Depth, Shaded x y)
t'd, -ℝ
1)] ]
          in ((forall a. Num a => a -> a -> a
+Depth
i₀) forall (a :: * -> * -> *) b b' c c'.
(Morphism a, ObjectPair a b b', ObjectPair a c c') =>
a b c -> a b' c' -> a (b, b') (c, c')
*** forall (a :: * -> * -> *) b d c.
(Morphism a, ObjectPair a b d, ObjectPair a c d) =>
a b c -> a (b, d) (c, d)
first (Shaded x y
shforall a. a -> [a] -> [a]
:))
                 forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> forall x y.
(WithField ℝ Manifold x, SimpleSpace (Needle x)) =>
Maybe (Metric x)
-> Shaded x y -> x -> Maybe (Depth, ([Shaded x y], (x, y)))
positionIndex (forall (m :: * -> *) a. Monad m (->) => a -> m a
return forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall v. SimpleSpace v => Variance v -> Norm v
dualNorm' Metric' x
ce) Shaded x y
t' x
x
positionIndex Maybe (Metric x)
_ Shaded x y
_ x
_ = forall (f :: * -> *) a. Alternative f => f a
empty




fromLeafPoints' :: ∀ x y. (WithField ℝ Manifold x, SimpleSpace (Needle x)) =>
    (Shade x -> [(x,y)] -> NonEmpty (DBranch' x [(x,y)])) -> [(x,y)] -> x`Shaded`y
fromLeafPoints' :: forall x y.
(WithField ℝ Manifold x, SimpleSpace (Needle x)) =>
(Shade x -> [(x, y)] -> NonEmpty (DBranch' x [(x, y)]))
-> [(x, y)] -> Shaded x y
fromLeafPoints' Shade x -> [(x, y)] -> NonEmpty (DBranch' x [(x, y)])
sShIdPart = Norm (DualVector (Needle x)) -> [(x, y)] -> Shaded x y
go forall a. Monoid a => a
mempty
 where go :: Metric' x -> [(x,y)] -> x`Shaded`y
       go :: Norm (DualVector (Needle x)) -> [(x, y)] -> Shaded x y
go Norm (DualVector (Needle x))
preShExpa
            = \[(x, y)]
xs -> case forall x y.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
Metric' x -> [(x, y)] -> [([(x, y)], Shade x)]
pointsShades' (forall v. LSpace v => Scalar v -> Norm v -> Norm v
scaleNorm (ℝ
1forall a. Fractional a => a -> a -> a
/ℝ
3) Norm (DualVector (Needle x))
preShExpa) [(x, y)]
xs of
                     [] -> forall x y. [(x, y)] -> Shaded x y
PlainLeaves []
                     [([(x, y)]
_,Shade x
rShade)] -> let trials :: NonEmpty (DBranch' x [(x, y)])
trials = Shade x -> [(x, y)] -> NonEmpty (DBranch' x [(x, y)])
sShIdPart Shade x
rShade [(x, y)]
xs
                                     in case Shade x
-> NonEmpty (DBranch' x [(x, y)])
-> Maybe (NonEmpty (DBranch' x [(x, y)]))
reduce Shade x
rShade NonEmpty (DBranch' x [(x, y)])
trials of
                                         Just NonEmpty (DBranch' x [(x, y)])
redBrchs
                                           -> forall x y.
Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
OverlappingBranches
                                                  (forall (t :: * -> *) a. Foldable t => t a -> Depth
length [(x, y)]
xs) Shade x
rShade
                                                  (Norm (DualVector (Needle x))
-> NonEmpty (DBranch' x [(x, y)])
-> NonEmpty (DBranch' x (Shaded x y))
branchProc (forall x. Shade x -> Metric' x
_shadeExpanse Shade x
rShade) NonEmpty (DBranch' x [(x, y)])
redBrchs)
                                         Maybe (NonEmpty (DBranch' x [(x, y)]))
_ -> forall x y. [(x, y)] -> Shaded x y
PlainLeaves [(x, y)]
xs
                     [([(x, y)], Shade x)]
partitions -> forall x y. Depth -> NonEmpty (Shaded x y) -> Shaded x y
DisjointBranches (forall (t :: * -> *) a. Foldable t => t a -> Depth
length [(x, y)]
xs)
                                   forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall a. [a] -> NonEmpty a
NE.fromList
                                    forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\([(x, y)]
xs',Shade x
pShade) -> Norm (DualVector (Needle x)) -> [(x, y)] -> Shaded x y
go forall a. Monoid a => a
mempty [(x, y)]
xs') [([(x, y)], Shade x)]
partitions
        where 
              branchProc :: Norm (DualVector (Needle x))
-> NonEmpty (DBranch' x [(x, y)])
-> NonEmpty (DBranch' x (Shaded x y))
branchProc Norm (DualVector (Needle x))
redSh = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Norm (DualVector (Needle x)) -> [(x, y)] -> Shaded x y
go Norm (DualVector (Needle x))
redSh)
                                 
              reduce :: Shade x -> NonEmpty (DBranch' x [(x,y)])
                                      -> Maybe (NonEmpty (DBranch' x [(x,y)]))
              reduce :: Shade x
-> NonEmpty (DBranch' x [(x, y)])
-> Maybe (NonEmpty (DBranch' x [(x, y)]))
reduce sh :: Shade x
sh@(Shade x
c Norm (DualVector (Needle x))
_) NonEmpty (DBranch' x [(x, y)])
brCandidates
                        = case forall a. (a -> Bool) -> [a] -> Maybe Depth
findIndex Hourglass Depth -> Bool
deficient [Hourglass Depth]
cards of
                            Just Depth
i | (DBranch DualVector (Needle x)
_ Hourglass [(x, y)]
reBr, DBranch' x [(x, y)]
o:[DBranch' x [(x, y)]]
ok)
                                             <- forall a. Depth -> [a] -> (a, [a])
amputateId Depth
i (forall a. NonEmpty a -> [a]
NE.toList NonEmpty (DBranch' x [(x, y)])
brCandidates)
                                           -> Shade x
-> NonEmpty (DBranch' x [(x, y)])
-> Maybe (NonEmpty (DBranch' x [(x, y)]))
reduce Shade x
sh
                                                forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall x y.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
x
-> [(x, y)]
-> NonEmpty (DBranch' x [(x, y)])
-> NonEmpty (DBranch' x [(x, y)])
sShIdPartition' x
c (forall (t :: * -> *) (k :: * -> * -> *) m.
(Foldable t k k, Monoid m, Semigroup m, Object k m,
 Object k (t m)) =>
k (t m) m
fold Hourglass [(x, y)]
reBr) (DBranch' x [(x, y)]
oforall a. a -> [a] -> NonEmpty a
:|[DBranch' x [(x, y)]]
ok)
                                   | Bool
otherwise -> forall a. Maybe a
Nothing
                            Maybe Depth
_ -> forall a. a -> Maybe a
Just NonEmpty (DBranch' x [(x, y)])
brCandidates
               where ([Hourglass Depth]
cards, Depth
maxCard) = (forall a. NonEmpty a -> [a]
NE.toList forall (a :: * -> * -> *) b c c'.
(PreArrow a, Object a b, ObjectPair a c c') =>
a b c -> a b c' -> a b (c, c')
&&& NonEmpty (Hourglass Depth) -> Depth
maximum')
                                forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap forall (t :: * -> *) a. Foldable t => t a -> Depth
length forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall x c. DBranch' x c -> Hourglass c
boughContents) NonEmpty (DBranch' x [(x, y)])
brCandidates
                     deficient :: Hourglass Depth -> Bool
deficient (Hourglass Depth
u Depth
l) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Depth
c -> Depth
cforall a. Num a => a -> Depth -> a
^Depth
2 forall a. Ord a => a -> a -> Bool
<= Depth
maxCard forall a. Num a => a -> a -> a
+ Depth
1) [Depth
u,Depth
l]
                     maximum' :: NonEmpty (Hourglass Depth) -> Depth
maximum' = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall a. NonEmpty a -> [a]
NE.toList forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (\(Hourglass Depth
u Depth
l) -> forall a. Ord a => a -> a -> a
max Depth
u Depth
l)


sShIdPartition' :: (WithField ℝ PseudoAffine x, SimpleSpace (Needle x))
        => x -> [(x,y)] -> NonEmpty (DBranch' x [(x,y)])
                                 -> NonEmpty (DBranch' x [(x,y)])
sShIdPartition' :: forall x y.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
x
-> [(x, y)]
-> NonEmpty (DBranch' x [(x, y)])
-> NonEmpty (DBranch' x [(x, y)])
sShIdPartition' x
c [(x, y)]
xs NonEmpty (DBranch' x [(x, y)])
st
           = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(x
p,y
y) -> let (Depth
i,HourglassBulb
h) = x -> (Depth, HourglassBulb)
ssi x
p
                          in forall a b. ([a] -> [b]) -> NonEmpty a -> NonEmpty b
asList forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. (a -> a) -> Depth -> [a] -> [a]
update_nth (\(DBranch DualVector (Needle x)
d Hourglass [(x, y)]
c)
                                                    -> forall x c. Needle' x -> Hourglass c -> DBranch' x c
DBranch DualVector (Needle x)
d (forall a. HourglassBulb -> (a -> a) -> Hourglass a -> Hourglass a
oneBulb HourglassBulb
h ((x
p,y
y)forall a. a -> [a] -> [a]
:) Hourglass [(x, y)]
c))
                                      Depth
i )
                   NonEmpty (DBranch' x [(x, y)])
st [(x, y)]
xs
 where ssi :: x -> (Depth, HourglassBulb)
ssi = forall x.
(WithField ℝ PseudoAffine x, LinearSpace (Needle x)) =>
x -> NonEmpty (Needle' x) -> x -> (Depth, HourglassBulb)
subshadeId' x
c (forall x c. DBranch' x c -> Needle' x
boughDirectionforall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>NonEmpty (DBranch' x [(x, y)])
st)
sShIdPartition :: (WithField ℝ PseudoAffine x, SimpleSpace (Needle x))
                    => Shade x -> [(x,y)] -> NonEmpty (DBranch' x [(x,y)])
sShIdPartition :: forall x y.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
Shade x -> [(x, y)] -> NonEmpty (DBranch' x [(x, y)])
sShIdPartition (Shade x
c Metric' x
expa) [(x, y)]
xs
 | DBranch' x [(x, y)]
b:[DBranch' x [(x, y)]]
bs <- [forall x c. Needle' x -> Hourglass c -> DBranch' x c
DBranch Needle' x
v forall a. Monoid a => a
mempty | Needle' x
v <- forall v.
(FiniteDimensional v, IEEE (Scalar v)) =>
Seminorm v -> [v]
normSpanningSystem' Metric' x
expa]
    = forall x y.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
x
-> [(x, y)]
-> NonEmpty (DBranch' x [(x, y)])
-> NonEmpty (DBranch' x [(x, y)])
sShIdPartition' x
c [(x, y)]
xs forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ DBranch' x [(x, y)]
bforall a. a -> [a] -> NonEmpty a
:|[DBranch' x [(x, y)]]
bs
                                           

asList :: ([a]->[b]) -> NonEmpty a->NonEmpty b
asList :: forall a b. ([a] -> [b]) -> NonEmpty a -> NonEmpty b
asList [a] -> [b]
f = forall a. [a] -> NonEmpty a
NE.fromList forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. [a] -> [b]
f forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall a. NonEmpty a -> [a]
NE.toList

update_nth :: (a->a) -> Int -> [a] -> [a]
update_nth :: forall a. (a -> a) -> Depth -> [a] -> [a]
update_nth a -> a
_ Depth
n [a]
l | Depth
nforall a. Ord a => a -> a -> Bool
<Depth
0 = [a]
l
update_nth a -> a
f Depth
0 (a
c:[a]
r) = a -> a
f a
c forall a. a -> [a] -> [a]
: [a]
r
update_nth a -> a
f Depth
n [] = []
update_nth a -> a
f Depth
n (a
l:[a]
r) = a
l forall a. a -> [a] -> [a]
: forall a. (a -> a) -> Depth -> [a] -> [a]
update_nth a -> a
f (Depth
nforall a. Num a => a -> a -> a
-Depth
1) [a]
r


amputateId :: Int -> [a] -> (a,[a])
amputateId :: forall a. Depth -> [a] -> (a, [a])
amputateId Depth
i [a]
l = let ([a
a],[a]
bs) = forall a. [Depth] -> [a] -> ([a], [a])
amputateIds [Depth
i] [a]
l in (a
a, [a]
bs)

deleteIds :: [Int] -> [a] -> [a]
deleteIds :: forall a. [Depth] -> [a] -> [a]
deleteIds [Depth]
kids = forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall a. [Depth] -> [a] -> ([a], [a])
amputateIds [Depth]
kids

amputateIds :: [Int]     -- ^ Sorted list of non-negative indices to extract
            -> [a]       -- ^ Input list
            -> ([a],[a]) -- ^ (Extracted elements, remaining elements)
amputateIds :: forall a. [Depth] -> [a] -> ([a], [a])
amputateIds = forall {t} {a}. (Eq t, Num t) => t -> [t] -> [a] -> ([a], [a])
go Depth
0
 where go :: t -> [t] -> [a] -> ([a], [a])
go t
_ [t]
_ [] = ([],[])
       go t
_ [] [a]
l = ([],[a]
l)
       go t
i (t
k:[t]
ks) (a
x:[a]
xs)
         | t
iforall a. Eq a => a -> a -> Bool
==t
k       = forall (a :: * -> * -> *) b d c.
(Morphism a, ObjectPair a b d, ObjectPair a c d) =>
a b c -> a (b, d) (c, d)
first  (a
xforall a. a -> [a] -> [a]
:) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ t -> [t] -> [a] -> ([a], [a])
go (t
iforall a. Num a => a -> a -> a
+t
1)    [t]
ks  [a]
xs
         | Bool
otherwise  = forall (a :: * -> * -> *) d b c.
(Morphism a, ObjectPair a d b, ObjectPair a d c) =>
a b c -> a (d, b) (d, c)
second (a
xforall a. a -> [a] -> [a]
:) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ t -> [t] -> [a] -> ([a], [a])
go (t
iforall a. Num a => a -> a -> a
+t
1) (t
kforall a. a -> [a] -> [a]
:[t]
ks) [a]
xs




sortByKey :: Ord a => [(a,b)] -> [b]
sortByKey :: forall a b. Ord a => [(a, b)] -> [b]
sortByKey = forall a b. (a -> b) -> [a] -> [b]
map forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst)


trunks :: ∀ x y . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x))
                  => x`Shaded`y -> [Shade x]
trunks :: forall x y.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
Shaded x y -> [Shade x]
trunks Shaded x y
t = case (forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness :: PseudoAffineWitness x, Shaded x y
t) of
  (PseudoAffineWitness SemimanifoldWitness x
SemimanifoldWitness, PlainLeaves [(x, y)]
lvs)
                                    -> forall x.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
[x] -> [Shade x]
pointsCovers forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fstforall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>[(x, y)]
lvs
  (PseudoAffineWitness x
_, DisjointBranches Depth
_ NonEmpty (Shaded x y)
brs)       -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Hask.foldMap forall x y.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
Shaded x y -> [Shade x]
trunks NonEmpty (Shaded x y)
brs
  (PseudoAffineWitness x
_, OverlappingBranches Depth
_ Shade x
sh NonEmpty (DBranch x y)
_)   -> [Shade x
sh]


nLeaves :: x`Shaded`y -> Int
nLeaves :: forall x a. Shaded x a -> Depth
nLeaves (PlainLeaves [(x, y)]
lvs) = forall (t :: * -> *) a. Foldable t => t a -> Depth
length [(x, y)]
lvs
nLeaves (DisjointBranches Depth
n NonEmpty (Shaded x y)
_) = Depth
n
nLeaves (OverlappingBranches Depth
n Shade x
_ NonEmpty (DBranch x y)
_) = Depth
n

treeDepth :: x`Shaded`y -> Int
treeDepth :: forall x a. Shaded x a -> Depth
treeDepth (PlainLeaves [(x, y)]
lvs) = Depth
0
treeDepth (DisjointBranches Depth
_ NonEmpty (Shaded x y)
brs) = Depth
1 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall x a. Shaded x a -> Depth
treeDepthforall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>NonEmpty (Shaded x y)
brs)
treeDepth (OverlappingBranches Depth
_ Shade x
_ NonEmpty (DBranch' x (Shaded x y))
brs)
     = Depth
1 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap forall x a. Shaded x a -> Depth
treeDepthforall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>NonEmpty (DBranch' x (Shaded x y))
brs)





overlappingBranches :: Shade x -> NonEmpty (DBranch x y) -> x`Shaded`y
overlappingBranches :: forall x y. Shade x -> NonEmpty (DBranch x y) -> Shaded x y
overlappingBranches Shade x
shx NonEmpty (DBranch' x (Shaded x y))
brs = forall x y.
Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
OverlappingBranches Depth
n Shade x
shx NonEmpty (DBranch' x (Shaded x y))
brs
 where n :: Depth
n = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap forall x a. Shaded x a -> Depth
nLeaves) NonEmpty (DBranch' x (Shaded x y))
brs

unsafeFmapLeaves_ :: (x -> x) -> x`Shaded`y -> x`Shaded`y
unsafeFmapLeaves_ :: forall x y. (x -> x) -> Shaded x y -> Shaded x y
unsafeFmapLeaves_ = forall x y y'. ((x, y) -> (x, y')) -> Shaded x y -> Shaded x y'
unsafeFmapLeaves forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall (a :: * -> * -> *) b d c.
(Morphism a, ObjectPair a b d, ObjectPair a c d) =>
a b c -> a (b, d) (c, d)
first

unsafeFmapLeaves :: ((x,y) -> (x,y')) -> x`Shaded`y -> x`Shaded`y'
unsafeFmapLeaves :: forall x y y'. ((x, y) -> (x, y')) -> Shaded x y -> Shaded x y'
unsafeFmapLeaves (x, y) -> (x, y')
f (PlainLeaves [(x, y)]
lvs) = forall x y. [(x, y)] -> Shaded x y
PlainLeaves forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (x, y) -> (x, y')
f [(x, y)]
lvs
unsafeFmapLeaves (x, y) -> (x, y')
f (DisjointBranches Depth
n NonEmpty (Shaded x y)
brs)
                 = forall x y. Depth -> NonEmpty (Shaded x y) -> Shaded x y
DisjointBranches Depth
n forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall x y y'. ((x, y) -> (x, y')) -> Shaded x y -> Shaded x y'
unsafeFmapLeaves (x, y) -> (x, y')
f forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> NonEmpty (Shaded x y)
brs
unsafeFmapLeaves (x, y) -> (x, y')
f (OverlappingBranches Depth
n Shade x
sh NonEmpty (DBranch' x (Shaded x y))
brs)
                  = forall x y.
Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
OverlappingBranches Depth
n Shade x
sh forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (forall x y y'. ((x, y) -> (x, y')) -> Shaded x y -> Shaded x y'
unsafeFmapLeaves (x, y) -> (x, y')
f) forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> NonEmpty (DBranch' x (Shaded x y))
brs

unsafeFmapTree :: (NonEmpty (x,y) -> NonEmpty (ξ,υ))
               -> (Needle' x -> Needle' ξ)
               -> (Shade x -> Shade ξ)
               -> x`Shaded`y -> ξ`Shaded`υ
unsafeFmapTree :: forall x y ξ υ.
(NonEmpty (x, y) -> NonEmpty (ξ, υ))
-> (Needle' x -> Needle' ξ)
-> (Shade x -> Shade ξ)
-> Shaded x y
-> Shaded ξ υ
unsafeFmapTree NonEmpty (x, y) -> NonEmpty (ξ, υ)
_ Needle' x -> Needle' ξ
_ Shade x -> Shade ξ
_ (PlainLeaves []) = forall x y. [(x, y)] -> Shaded x y
PlainLeaves []
unsafeFmapTree NonEmpty (x, y) -> NonEmpty (ξ, υ)
f Needle' x -> Needle' ξ
_ Shade x -> Shade ξ
_ (PlainLeaves [(x, y)]
lvs) = forall x y. [(x, y)] -> Shaded x y
PlainLeaves forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. NonEmpty (x, y) -> NonEmpty (ξ, υ)
f forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. [a] -> NonEmpty a
NE.fromList [(x, y)]
lvs
unsafeFmapTree NonEmpty (x, y) -> NonEmpty (ξ, υ)
f Needle' x -> Needle' ξ
fn Shade x -> Shade ξ
fs (DisjointBranches Depth
n NonEmpty (Shaded x y)
brs)
    = let brs' :: NonEmpty (Shaded ξ υ)
brs' = forall x y ξ υ.
(NonEmpty (x, y) -> NonEmpty (ξ, υ))
-> (Needle' x -> Needle' ξ)
-> (Shade x -> Shade ξ)
-> Shaded x y
-> Shaded ξ υ
unsafeFmapTree NonEmpty (x, y) -> NonEmpty (ξ, υ)
f Needle' x -> Needle' ξ
fn Shade x -> Shade ξ
fs forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> NonEmpty (Shaded x y)
brs
      in forall x y. Depth -> NonEmpty (Shaded x y) -> Shaded x y
DisjointBranches (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall x a. Shaded x a -> Depth
nLeavesforall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>NonEmpty (Shaded ξ υ)
brs') NonEmpty (Shaded ξ υ)
brs'
unsafeFmapTree NonEmpty (x, y) -> NonEmpty (ξ, υ)
f Needle' x -> Needle' ξ
fn Shade x -> Shade ξ
fs (OverlappingBranches Depth
n Shade x
sh NonEmpty (DBranch x y)
brs)
    = let brs' :: NonEmpty (DBranch ξ υ)
brs' = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (\(DBranch Needle' x
dir Hourglass (Shaded x y)
br)
                      -> forall x c. Needle' x -> Hourglass c -> DBranch' x c
DBranch (Needle' x -> Needle' ξ
fn Needle' x
dir) (forall x y ξ υ.
(NonEmpty (x, y) -> NonEmpty (ξ, υ))
-> (Needle' x -> Needle' ξ)
-> (Shade x -> Shade ξ)
-> Shaded x y
-> Shaded ξ υ
unsafeFmapTree NonEmpty (x, y) -> NonEmpty (ξ, υ)
f Needle' x -> Needle' ξ
fn Shade x -> Shade ξ
fsforall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>Hourglass (Shaded x y)
br)
                      ) NonEmpty (DBranch x y)
brs
      in forall x y. Shade x -> NonEmpty (DBranch x y) -> Shaded x y
overlappingBranches (Shade x -> Shade ξ
fs Shade x
sh) NonEmpty (DBranch ξ υ)
brs'




type Twig x y = (Int, x`Shaded`y)
type TwigEnviron x y = [Twig x y]

allTwigs :: ∀ x y . WithField ℝ PseudoAffine x => x`Shaded`y -> [Twig x y]
allTwigs :: forall x y. WithField ℝ PseudoAffine x => Shaded x y -> [Twig x y]
allTwigs Shaded x y
tree = forall {x} {y}.
Depth
-> Shaded x y -> [(Depth, Shaded x y)] -> [(Depth, Shaded x y)]
go Depth
0 Shaded x y
tree []
 where go :: Depth
-> Shaded x y -> [(Depth, Shaded x y)] -> [(Depth, Shaded x y)]
go Depth
n₀ (DisjointBranches Depth
_ NonEmpty (Shaded x y)
dp)
         = forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\(Depth
n₀',[(Depth, Shaded x y)] -> [(Depth, Shaded x y)]
prev) Shaded x y
br -> (Depth
n₀'forall a. Num a => a -> a -> a
+forall x a. Shaded x a -> Depth
nLeaves Shaded x y
br, [(Depth, Shaded x y)] -> [(Depth, Shaded x y)]
prev forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. Depth
-> Shaded x y -> [(Depth, Shaded x y)] -> [(Depth, Shaded x y)]
go Depth
n₀' Shaded x y
br)) (Depth
n₀,forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id) NonEmpty (Shaded x y)
dp)
       go Depth
n₀ (OverlappingBranches Depth
_ Shade x
_ NonEmpty (DBranch x y)
dp)
         = forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\(Depth
n₀',[(Depth, Shaded x y)] -> [(Depth, Shaded x y)]
prev) (DBranch Needle' x
_ (Hourglass Shaded x y
top Shaded x y
bot))
                          -> ( Depth
n₀'forall a. Num a => a -> a -> a
+forall x a. Shaded x a -> Depth
nLeaves Shaded x y
topforall a. Num a => a -> a -> a
+forall x a. Shaded x a -> Depth
nLeaves Shaded x y
bot
                             , [(Depth, Shaded x y)] -> [(Depth, Shaded x y)]
prev forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. Depth
-> Shaded x y -> [(Depth, Shaded x y)] -> [(Depth, Shaded x y)]
go Depth
n₀' Shaded x y
top forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. Depth
-> Shaded x y -> [(Depth, Shaded x y)] -> [(Depth, Shaded x y)]
go (Depth
n₀'forall a. Num a => a -> a -> a
+forall x a. Shaded x a -> Depth
nLeaves Shaded x y
top) Shaded x y
bot) )
                        (Depth
n₀,forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList NonEmpty (DBranch x y)
dp)
       go Depth
n₀ Shaded x y
twig = ((Depth
n₀,Shaded x y
twig)forall a. a -> [a] -> [a]
:)

-- 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 y. (WithField ℝ Manifold x, SimpleSpace (Needle x))
    => x`Shaded`y -> [(Twig x y, TwigEnviron x y)]
twigsWithEnvirons :: forall x y.
(WithField ℝ Manifold x, SimpleSpace (Needle x)) =>
Shaded x y -> [(Twig x y, TwigEnviron x y)]
twigsWithEnvirons = forall w a. Writer w a -> w
execWriter forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall x y (f :: * -> *).
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x),
 Applicative f) =>
((Twig x y, TwigEnviron x y) -> f (Shaded x y))
-> Shaded x y -> f (Shaded x y)
traverseTwigsWithEnvirons (forall (m :: * -> *) a w. Monad m => (a, w) -> WriterT w m a
writer forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. (forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
sndforall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
.forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fstforall (a :: * -> * -> *) b c c'.
(PreArrow a, Object a b, ObjectPair a c c') =>
a b c -> a b c' -> a b (c, c')
&&&forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a.
(Applicative f r t, Object r a, Object t (f a)) =>
t a (f a)
pure))

traverseTwigsWithEnvirons :: ∀ x y f .
            (WithField ℝ PseudoAffine x, SimpleSpace (Needle x), Hask.Applicative f)
    => ( (Twig x y, TwigEnviron x y) -> f (x`Shaded`y) ) -> x`Shaded`y -> f (x`Shaded`y)
traverseTwigsWithEnvirons :: forall x y (f :: * -> *).
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x),
 Applicative f) =>
((Twig x y, TwigEnviron x y) -> f (Shaded x y))
-> Shaded x y -> f (Shaded x y)
traverseTwigsWithEnvirons (Twig x y, TwigEnviron x y) -> f (Shaded x y)
f = forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. PseudoAffineWitness x
-> TwigEnviron x y -> Twig x y -> (f (Shaded x y), Bool)
go forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness [] forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. (Depth
0,)
 where go :: PseudoAffineWitness x -> TwigEnviron x y -> Twig x y -> (f (x`Shaded`y), Bool)
       go :: PseudoAffineWitness x
-> TwigEnviron x y -> Twig x y -> (f (Shaded x y), Bool)
go PseudoAffineWitness x
sw TwigEnviron x y
_ (Depth
i₀, DisjointBranches Depth
nlvs NonEmpty (Shaded x y)
djbs) = ( forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (forall x y. Depth -> NonEmpty (Shaded x y) -> Shaded x y
DisjointBranches Depth
nlvs)
                                                   forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
Hask.traverse (forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. PseudoAffineWitness x
-> TwigEnviron x y -> Twig x y -> (f (Shaded x y), Bool)
go PseudoAffineWitness x
sw [])
                                                   forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
NE.zip NonEmpty Depth
ioffs NonEmpty (Shaded x y)
djbs
                                               , Bool
False )
        where ioffs :: NonEmpty Depth
ioffs = forall (f :: * -> *) b a.
Foldable f =>
(b -> a -> b) -> b -> f a -> NonEmpty b
NE.scanl (\Depth
i -> (forall a. Num a => a -> a -> a
+Depth
i) forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall x a. Shaded x a -> Depth
nLeaves) Depth
i₀ NonEmpty (Shaded x y)
djbs
       go sw :: PseudoAffineWitness x
sw@(PseudoAffineWitness SemimanifoldWitness x
SemimanifoldWitness) TwigEnviron x y
envi
           ct :: Twig x y
ct@(Depth
i₀, (OverlappingBranches Depth
nlvs rob :: Shade x
rob@(Shade x
robc Metric' x
_) NonEmpty (DBranch x y)
brs))
                = ( case OuterMaybeT f [DBranch x y]
descentResult of
                     OuterMaybeT f [DBranch x y]
OuterNothing -> (Twig x y, TwigEnviron x y) -> f (Shaded x y)
f
                         forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (Twig x y, TwigEnviron x y) -> (Twig x y, TwigEnviron x y)
purgeRemotes
                            (Twig x y
ct, forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Hask.foldMap (\(Depth
io,Shaded x y
te)
                                         -> forall (a :: * -> * -> *) b d c.
(Morphism a, ObjectPair a b d, ObjectPair a c d) =>
a b c -> a (b, d) (c, d)
first (forall a. Num a => a -> a -> a
+Depth
io) forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> PseudoAffineWitness x -> x -> Shaded x y -> TwigEnviron x y
twigProximæ PseudoAffineWitness x
sw x
robc Shaded x y
te) TwigEnviron x y
envi)
                     OuterJust f [DBranch x y]
dR -> forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (forall x y.
Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
OverlappingBranches Depth
nlvs Shade x
rob forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall a. [a] -> NonEmpty a
NE.fromList) f [DBranch x y]
dR
                  , Bool
False )
        where descentResult :: OuterMaybeT f [DBranch x y]
descentResult = forall x (f :: * -> *) y z.
(AdditiveGroup (Needle' x), Applicative f) =>
((Depth, (Needle' x, Shaded x y))
 -> [(Depth, (Needle' x, Shaded x y))] -> f (Shaded x z))
-> [DBranch x y] -> f [DBranch x z]
traverseDirectionChoices (Depth, (Needle' x, Shaded x y))
-> [(Depth, (Needle' x, Shaded x y))] -> OuterMaybeT f (Shaded x y)
tdc forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList NonEmpty (DBranch x y)
brs
              tdc :: (Depth, (Needle' x, Shaded x y))
-> [(Depth, (Needle' x, Shaded x y))] -> OuterMaybeT f (Shaded x y)
tdc (Depth
io, (Needle' x
vy, Shaded x y
ty)) [(Depth, (Needle' x, Shaded x y))]
alts = case PseudoAffineWitness x
-> TwigEnviron x y -> Twig x y -> (f (Shaded x y), Bool)
go PseudoAffineWitness x
sw TwigEnviron x y
envi'' (Depth
i₀forall a. Num a => a -> a -> a
+Depth
io, Shaded x y
ty) of
                                   (f (Shaded x y)
_, Bool
True) -> forall (f :: * -> *) a. OuterMaybeT f a
OuterNothing
                                   (f (Shaded x y)
down, Bool
_) -> forall (f :: * -> *) a. f a -> OuterMaybeT f a
OuterJust f (Shaded x y)
down
               where envi'' :: TwigEnviron x y
envi'' = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a.
(SumToProduct f r t, Object r a, Object r Bool, Object t (f a)) =>
r a Bool -> t (f a) (f a)
filter (forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd forall (k :: * -> * -> *) a b c.
(Category k, Object k a, Object k b, Object k c) =>
k a b -> k b c -> k a c
>>> forall x y.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
Shaded x y -> [Shade x]
trunks forall (k :: * -> * -> *) a b c.
(Category k, Object k a, Object k b, Object k c) =>
k a b -> k b c -> k a c
>>> \(Shade x
ce Metric' x
_:[Shade x]
_)
                                         -> let Just Needle x
δyenv = x
ceforall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
robc
                                                qq :: Scalar (Needle x)
qq = Needle' x
vyforall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^Needle x
δyenv
                                            in Scalar (Needle x)
qq forall a. Ord a => a -> a -> Bool
> -ℝ
1
                                       ) TwigEnviron x y
envi'
                              forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map ((forall a. Num a => a -> a -> a
+Depth
i₀)forall (a :: * -> * -> *) b b' c c'.
(Morphism a, ObjectPair a b b', ObjectPair a c c') =>
a b c -> a b' c' -> a (b, b') (c, c')
***forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd) [(Depth, (Needle' x, Shaded x y))]
alts
              envi' :: TwigEnviron x y
envi' = Twig x y -> TwigEnviron x y
approach forall (m :: * -> *) (k :: * -> * -> *) a b.
(Monad m k, Object k a, Object k b, Object k (m a), Object k (m b),
 Object k (m (m b))) =>
k a (m b) -> k (m a) (m b)
=<< TwigEnviron x y
envi
              approach :: Twig x y -> TwigEnviron x y
approach (Depth
i₀e, apt :: Shaded x y
apt@(OverlappingBranches Depth
_ (Shade x
envc Metric' x
_) NonEmpty (DBranch x y)
_))
                  = forall (a :: * -> * -> *) b d c.
(Morphism a, ObjectPair a b d, ObjectPair a c d) =>
a b c -> a (b, d) (c, d)
first (forall a. Num a => a -> a -> a
+Depth
i₀e) forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> (DBranch x y -> TwigEnviron x y) -> Shaded x y -> TwigEnviron x y
twigsaveTrim DBranch x y -> TwigEnviron x y
hither Shaded x y
apt
               where Just Needle x
δxenv = x
robc forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~. x
envc
                     hither :: DBranch x y -> TwigEnviron x y
hither (DBranch Needle' x
bdir (Hourglass Shaded x y
bdc₁ Shaded x y
bdc₂))
                       =  [(Depth
0           , Shaded x y
bdc₁) | Scalar (Needle x)
overlap forall a. Ord a => a -> a -> Bool
> -ℝ
1]
                       forall a. [a] -> [a] -> [a]
++ [(forall x a. Shaded x a -> Depth
nLeaves Shaded x y
bdc₁, Shaded x y
bdc₂) | Scalar (Needle x)
overlap forall a. Ord a => a -> a -> Bool
< ℝ
1]
                      where overlap :: Scalar (Needle x)
overlap = Needle' x
bdirforall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^Needle x
δxenv
              approach Twig x y
q = [Twig x y
q]
       go (PseudoAffineWitness SemimanifoldWitness x
SemimanifoldWitness) TwigEnviron x y
envi plvs :: Twig x y
plvs@(Depth
i₀, (PlainLeaves [(x, y)]
_))
                         = ((Twig x y, TwigEnviron x y) -> f (Shaded x y)
f forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (Twig x y, TwigEnviron x y) -> (Twig x y, TwigEnviron x y)
purgeRemotes (Twig x y
plvs, TwigEnviron x y
envi), Bool
True)
       
       twigProximæ :: PseudoAffineWitness x -> x -> x`Shaded`y -> TwigEnviron x y
       twigProximæ :: PseudoAffineWitness x -> x -> Shaded x y -> TwigEnviron x y
twigProximæ PseudoAffineWitness x
sw x
x₀ (DisjointBranches Depth
_ NonEmpty (Shaded x y)
djbs)
               = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Hask.foldMap (\(Depth
i₀,Shaded x y
st) -> forall (a :: * -> * -> *) b d c.
(Morphism a, ObjectPair a b d, ObjectPair a c d) =>
a b c -> a (b, d) (c, d)
first (forall a. Num a => a -> a -> a
+Depth
i₀) forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> PseudoAffineWitness x -> x -> Shaded x y -> TwigEnviron x y
twigProximæ PseudoAffineWitness x
sw x
x₀ Shaded x y
st)
                    forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
NE.zip NonEmpty Depth
ioffs NonEmpty (Shaded x y)
djbs
        where ioffs :: NonEmpty Depth
ioffs = forall (f :: * -> *) b a.
Foldable f =>
(b -> a -> b) -> b -> f a -> NonEmpty b
NE.scanl (\Depth
i -> (forall a. Num a => a -> a -> a
+Depth
i) forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall x a. Shaded x a -> Depth
nLeaves) Depth
0 NonEmpty (Shaded x y)
djbs
       twigProximæ sw :: PseudoAffineWitness x
sw@(PseudoAffineWitness SemimanifoldWitness x
SemimanifoldWitness)
                          x
x₀ ct :: Shaded x y
ct@(OverlappingBranches Depth
_ (Shade x
xb Metric' x
qb) NonEmpty (DBranch x y)
brs)
                   = (DBranch x y -> TwigEnviron x y) -> Shaded x y -> TwigEnviron x y
twigsaveTrim DBranch x y -> TwigEnviron x y
hither Shaded x y
ct
        where Just Needle x
δxb = x
x₀ forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~. x
xb
              hither :: DBranch x y -> TwigEnviron x y
hither (DBranch Needle' x
bdir (Hourglass Shaded x y
bdc₁ Shaded x y
bdc₂))
                =  ((forall (m :: * -> *) (k :: * -> * -> *).
(MonadPlus m k, Arrow k (->), Function k, UnitObject k ~ (),
 Object k Bool) =>
k Bool (m ())
guard (Scalar (Needle x)
overlap forall a. Ord a => a -> a -> Bool
> -ℝ
1)) forall (k :: * -> * -> *) (m :: * -> *) b a.
(WellPointed k, Monad m k, ObjectPair k b (UnitObject k),
 ObjectPair k (m b) (UnitObject k),
 ObjectPair k (UnitObject k) (m b), ObjectPair k b a,
 ObjectPair k a b, Object k (m (a, b)), ObjectPair k (m a) (m b),
 ObjectPoint k (m a)) =>
m a -> k (m b) (m b)
>> PseudoAffineWitness x -> x -> Shaded x y -> TwigEnviron x y
twigProximæ PseudoAffineWitness x
sw x
x₀ Shaded x y
bdc₁)
                forall a. [a] -> [a] -> [a]
++ ((forall (m :: * -> *) (k :: * -> * -> *).
(MonadPlus m k, Arrow k (->), Function k, UnitObject k ~ (),
 Object k Bool) =>
k Bool (m ())
guard (Scalar (Needle x)
overlap forall a. Ord a => a -> a -> Bool
< ℝ
1)) forall (k :: * -> * -> *) (m :: * -> *) b a.
(WellPointed k, Monad m k, ObjectPair k b (UnitObject k),
 ObjectPair k (m b) (UnitObject k),
 ObjectPair k (UnitObject k) (m b), ObjectPair k b a,
 ObjectPair k a b, Object k (m (a, b)), ObjectPair k (m a) (m b),
 ObjectPoint k (m a)) =>
m a -> k (m b) (m b)
>> forall (a :: * -> * -> *) b d c.
(Morphism a, ObjectPair a b d, ObjectPair a c d) =>
a b c -> a (b, d) (c, d)
first (forall a. Num a => a -> a -> a
+forall x a. Shaded x a -> Depth
nLeaves Shaded x y
bdc₁)forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>PseudoAffineWitness x -> x -> Shaded x y -> TwigEnviron x y
twigProximæ PseudoAffineWitness x
sw x
x₀ Shaded x y
bdc₂)
               where overlap :: Scalar (Needle x)
overlap = Needle' x
bdirforall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^Needle x
δxb
       twigProximæ PseudoAffineWitness x
_ x
_ Shaded x y
plainLeaves = [(Depth
0, Shaded x y
plainLeaves)]
       
       twigsaveTrim :: (DBranch x y -> TwigEnviron x y) -> x`Shaded`y -> TwigEnviron x y
       twigsaveTrim :: (DBranch x y -> TwigEnviron x y) -> Shaded x y -> TwigEnviron x y
twigsaveTrim DBranch x y -> TwigEnviron x y
f ct :: Shaded x y
ct@(OverlappingBranches Depth
_ Shade x
_ NonEmpty (DBranch x y)
dbs)
                 = case forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
Hask.mapM (\(Depth
i₀,DBranch x y
dbr) -> forall {f :: * -> *} {a} {x} {y}.
Alternative f =>
[(a, Shaded x y)] -> f [(a, Shaded x y)]
noLeaf forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (a :: * -> * -> *) b d c.
(Morphism a, ObjectPair a b d, ObjectPair a c d) =>
a b c -> a (b, d) (c, d)
first(forall a. Num a => a -> a -> a
+Depth
i₀)forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>DBranch x y -> TwigEnviron x y
f DBranch x y
dbr)
                                 forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
NE.zip NonEmpty Depth
ioffs NonEmpty (DBranch x y)
dbs of
                      Just NonEmpty (TwigEnviron x y)
pqe -> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
Hask.fold NonEmpty (TwigEnviron x y)
pqe
                      Maybe (NonEmpty (TwigEnviron x y))
_        -> [(Depth
0,Shaded x y
ct)]
        where noLeaf :: [(a, Shaded x y)] -> f [(a, Shaded x y)]
noLeaf [(a
_,PlainLeaves [(x, y)]
_)] = forall (f :: * -> *) a. Alternative f => f a
empty
              noLeaf [(a, Shaded x y)]
bqs = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a.
(Applicative f r t, Object r a, Object t (f a)) =>
t a (f a)
pure [(a, Shaded x y)]
bqs
              ioffs :: NonEmpty Depth
ioffs = forall (f :: * -> *) b a.
Foldable f =>
(b -> a -> b) -> b -> f a -> NonEmpty b
NE.scanl (\Depth
i -> (forall a. Num a => a -> a -> a
+Depth
i) forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap forall x a. Shaded x a -> Depth
nLeaves forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList) Depth
0 NonEmpty (DBranch x y)
dbs
       
       purgeRemotes :: (Twig x y, TwigEnviron x y) -> (Twig x y, TwigEnviron x y)
       purgeRemotes :: (Twig x y, TwigEnviron x y) -> (Twig x y, TwigEnviron x y)
purgeRemotes = forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
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 :: forall x y.
(WithField ℝ PseudoAffine x, WithField ℝ PseudoAffine y,
 SimpleSpace (Needle x), SimpleSpace (Needle y)) =>
Shaded x y -> [Shade' (x, y)]
completeTopShading (PlainLeaves [(x, y)]
plvs) = case ( forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualNeedleWitness x
                                             , forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualNeedleWitness y ) of
       (DualSpaceWitness (Needle x)
DualSpaceWitness, DualSpaceWitness (Needle y)
DualSpaceWitness)
          -> forall x.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
[x] -> [Shade' x]
pointsShade's [(x, y)]
plvs
completeTopShading (DisjointBranches Depth
_ NonEmpty (Shaded x y)
bqs)
                     = forall a. Depth -> [a] -> [a]
take Depth
1 forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall x y.
(WithField ℝ PseudoAffine x, WithField ℝ PseudoAffine y,
 SimpleSpace (Needle x), SimpleSpace (Needle y)) =>
Shaded x y -> [Shade' (x, y)]
completeTopShading forall (m :: * -> *) (k :: * -> * -> *) a b.
(Monad m k, Object k a, Object k b, Object k (m a), Object k (m b),
 Object k (m (m b))) =>
k a (m b) -> k (m a) (m b)
=<< forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Shaded x y)
bqs
completeTopShading Shaded x y
t = case ( forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualNeedleWitness x
                            , forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualNeedleWitness y ) of
       (DualSpaceWitness (Needle x)
DualSpaceWitness, DualSpaceWitness (Needle y)
DualSpaceWitness)
          -> forall x.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
[x] -> [Shade' x]
pointsCover's forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall x y. WithField ℝ PseudoAffine x => Shaded x y -> [(x, y)]
onlyLeaves Shaded x y
t


transferAsNormsDo :: ∀ v . LSpace v => Norm v -> Variance v -> v-+>v
transferAsNormsDo :: forall v. LSpace v => Norm v -> Variance v -> v -+> v
transferAsNormsDo = case forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualSpaceWitness v of
                      DualSpaceWitness v
DualSpaceWitness -> \(Norm v -+> DualVector v
m) (Norm DualVector v -+> DualVector (DualVector v)
n) -> DualVector v -+> DualVector (DualVector v)
n forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. v -+> DualVector v
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 :: forall x y (f :: * -> *).
(WithField ℝ Manifold x, WithField ℝ Manifold y,
 SimpleSpace (Needle x), SimpleSpace (Needle y),
 Applicative f (->) (->)) =>
(Shade' (x, y) -> f (x, (Shade' y, LocalLinear x y)))
-> Shaded x y -> f (Shaded x y)
flexTopShading Shade' (x, y) -> f (x, (Shade' y, LocalLinear x y))
f Shaded x y
tr = seq :: forall a b. a -> b -> b
seq (Shaded x y -> ()
assert_onlyToplevDisjoint Shaded x y
tr)
                    forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (DualSpaceWitness (Needle x), DualSpaceWitness (Needle y),
 PseudoAffineWitness y)
-> [Shade' (x, y)] -> Shaded x y -> f (Shaded x y)
recst (forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness::DualNeedleWitness x
                            ,forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness::DualNeedleWitness y
                            ,forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness::PseudoAffineWitness y)
                            (forall x y.
(WithField ℝ PseudoAffine x, WithField ℝ PseudoAffine y,
 SimpleSpace (Needle x), SimpleSpace (Needle y)) =>
Shaded x y -> [Shade' (x, y)]
completeTopShading Shaded x y
tr) Shaded x y
tr
 where recst :: (DualSpaceWitness (Needle x), DualSpaceWitness (Needle y),
 PseudoAffineWitness y)
-> [Shade' (x, y)] -> Shaded x y -> f (Shaded x y)
recst (DualSpaceWitness (Needle x), DualSpaceWitness (Needle y),
 PseudoAffineWitness y)
_ qsh :: [Shade' (x, y)]
qsh@(Shade' (x, y)
_:[Shade' (x, y)]
_) (DisjointBranches Depth
n NonEmpty (Shaded x y)
bqs)
          = forall a. HasCallStack => a
undefined -- DisjointBranches n $ NE.zipWith (recst . (:[])) (NE.fromList qsh) bqs
       recst (DualSpaceWitness (Needle x)
DualSpaceWitness,DualSpaceWitness (Needle y)
DualSpaceWitness,PseudoAffineWitness SemimanifoldWitness y
SemimanifoldWitness)
               [sha :: Shade' (x, y)
sha@(Shade' (x
_,y
yc₀) Metric (x, y)
expa₀)] Shaded x y
t = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (x, (Shade' y, LinearMap ℝ (Needle x) (Needle y))) -> Shaded x y
fts forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Shade' (x, y) -> f (x, (Shade' y, LocalLinear x y))
f Shade' (x, y)
sha
        where expa'₀ :: Variance (Needle x, Needle y)
expa'₀ = forall v. SimpleSpace v => Norm v -> Variance v
dualNorm Metric (x, y)
expa₀
              j₀ :: LocalLinear x y
              j₀ :: LocalLinear x y
j₀ = forall u v.
(SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v) =>
Variance (u, v) -> u +> v
dependence Variance (Needle x, Needle y)
expa'₀
              (Norm (Needle x)
_,Norm (Needle y)
expay₀) = forall u v.
(SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v) =>
Norm (u, v) -> (Norm u, Norm v)
summandSpaceNorms Metric (x, y)
expa₀
              fts :: (x, (Shade' y, LinearMap ℝ (Needle x) (Needle y))) -> Shaded x y
fts (x
xc, (Shade' y
yc Norm (Needle y)
expay, LinearMap ℝ (Needle x) (Needle y)
jtg)) = forall x y y'. ((x, y) -> (x, y')) -> Shaded x y -> Shaded x y'
unsafeFmapLeaves (x, y) -> (x, y)
applδj Shaded x y
t
               where Just Needle y
δyc = y
ycforall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.y
yc₀
                     tfm :: Needle y -+> Needle y
tfm = forall v. LSpace v => Norm v -> Variance v -> v -+> v
transferAsNormsDo Norm (Needle y)
expay₀ (forall v. SimpleSpace v => Norm v -> Variance v
dualNorm Norm (Needle y)
expay)
                     applδj :: (x, y) -> (x, y)
applδj (x
x,y
y)
                           = (x
x, y
yc₀ forall x. Semimanifold x => x -> Needle x -> x
.+~^ ((Needle y -+> Needle y
tfm forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Needle y
δy) forall v. AdditiveGroup v => v -> v -> v
^+^ (LinearMap ℝ (Needle x) (Needle y)
jtg forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Needle x
δx) forall v. AdditiveGroup v => v -> v -> v
^+^ Needle y
δyc))
                      where Just Needle x
δx = x
xforall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
xc
                            Just Needle y
δy = y
yforall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.(y
yc₀forall x. Semimanifold x => x -> Needle x -> x
.+~^(LocalLinear x y
j₀ forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Needle x
δx))
       
       assert_onlyToplevDisjoint, assert_connected :: x`Shaded`y -> ()
       assert_onlyToplevDisjoint :: Shaded x y -> ()
assert_onlyToplevDisjoint (DisjointBranches Depth
_ NonEmpty (Shaded x y)
dp) = forall a. NFData a => a -> ()
rnf (Shaded x y -> ()
assert_connectedforall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>NonEmpty (Shaded x y)
dp)
       assert_onlyToplevDisjoint Shaded x y
t = Shaded x y -> ()
assert_connected Shaded x y
t
       assert_connected :: Shaded x y -> ()
assert_connected (OverlappingBranches Depth
_ Shade x
_ NonEmpty (DBranch x y)
dp)
           = forall a. NFData a => a -> ()
rnf (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Hask.foldMap Shaded x y -> ()
assert_connectedforall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>NonEmpty (DBranch x y)
dp)
       assert_connected (PlainLeaves [(x, y)]
_) = ()

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 :: forall x y (f :: * -> *).
(WithField ℝ Manifold x, WithField ℝ Manifold y,
 SimpleSpace (Needle x), SimpleSpace (Needle y), Applicative f) =>
(Shade' (x, y) -> f (x, (Shade' y, LocalLinear x y)))
-> Shaded x y -> f (Shaded x y)
flexTwigsShading Shade' (x, y) -> f (x, (Shade' y, LocalLinear x y))
f = forall x y (f :: * -> *).
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x),
 Applicative f) =>
((Twig x y, TwigEnviron x y) -> f (Shaded x y))
-> Shaded x y -> f (Shaded x y)
traverseTwigsWithEnvirons forall μ. ((Depth, Shaded x y), μ) -> f (Shaded x y)
locFlex
 where locFlex :: ∀ μ . ((Int, x`Shaded`y), μ) -> f (x`Shaded`y)
       locFlex :: forall μ. ((Depth, Shaded x y), μ) -> f (Shaded x y)
locFlex ((Depth
_,Shaded x y
lsh), μ
_) = forall x y (f :: * -> *).
(WithField ℝ Manifold x, WithField ℝ Manifold y,
 SimpleSpace (Needle x), SimpleSpace (Needle y),
 Applicative f (->) (->)) =>
(Shade' (x, y) -> f (x, (Shade' y, LocalLinear x y)))
-> Shaded x y -> f (Shaded x y)
flexTopShading Shade' (x, y) -> f (x, (Shade' y, LocalLinear x y))
f Shaded x y
lsh
                


seekPotentialNeighbours :: ∀ x y . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x))
                => x`Shaded`y -> x`Shaded`(y,[Int])
seekPotentialNeighbours :: forall x y.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
Shaded x y -> Shaded x (y, [Depth])
seekPotentialNeighbours Shaded x y
tree = forall x w y. Shaded x w -> NonEmpty y -> Shaded x (w, y)
zipTreeWithList Shaded x y
tree
                     forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ case forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
sndforall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>forall x y.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
Shaded x y -> [((x, y), [Depth])]
leavesWithPotentialNeighbours Shaded x y
tree of
                         ([Depth]
n:[[Depth]]
ns) -> [Depth]
nforall a. a -> [a] -> NonEmpty a
:|[[Depth]]
ns

leavesWithPotentialNeighbours :: ∀ x y
            . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x))
                => x`Shaded`y -> [((x,y), [Int])]
leavesWithPotentialNeighbours :: forall x y.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
Shaded x y -> [((x, y), [Depth])]
leavesWithPotentialNeighbours = forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) d b c.
(Morphism a, ObjectPair a d b, ObjectPair a d c) =>
a b c -> a (d, b) (d, c)
second forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd) forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. PseudoAffineWitness x
-> Depth
-> Depth
-> [Wall x]
-> Shaded x y
-> [((x, y), ([Wall x], [Depth]))]
go forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness Depth
0 Depth
0 []
 where go :: PseudoAffineWitness x -> Depth -> Int -> [Wall x] -> x`Shaded`y
                -> [((x,y), ([Wall x], [Int]))]
       go :: PseudoAffineWitness x
-> Depth
-> Depth
-> [Wall x]
-> Shaded x y
-> [((x, y), ([Wall x], [Depth]))]
go (PseudoAffineWitness SemimanifoldWitness x
SemimanifoldWitness) Depth
depth Depth
n₀ [Wall x]
walls (PlainLeaves [(x, y)]
lvs)
               = [ ((x
x,y
y), ( [ Wall x
wall forall a b. a -> (a -> b) -> b
& forall x. Lens' (Wall x) (Scalar (Needle x))
wallDistance forall s t a b. ASetter s t a b -> b -> s -> t
.~ Scalar (Needle x)
d
                         | Wall x
wall <- [Wall x]
walls
                         , Just Needle x
vw <- [x
xforall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.Wall x
wallforall s a. s -> Getting a s a -> a
^.forall x. Lens' (Wall x) x
wallAnchor]
                         , let d :: Scalar (Needle x)
d = (Wall x
wallforall s a. s -> Getting a s a -> a
^.forall x. Lens' (Wall x) (Needle' x)
wallNormal)forall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^Needle x
vw
                         , Scalar (Needle x)
d forall a. Ord a => a -> a -> Bool
< Wall x
wallforall s a. s -> Getting a s a -> a
^.forall x. Lens' (Wall x) (Scalar (Needle x))
wallDistance ]
                       , [] ))
                 | (x
x,y
y) <- [(x, y)]
lvs ]
       go PseudoAffineWitness x
pw Depth
depth Depth
n₀ [Wall x]
walls (DisjointBranches Depth
_ NonEmpty (Shaded x y)
dp)
         = forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\(Depth
n₀',[((x, y), ([Wall x], [Depth]))] -> [((x, y), ([Wall x], [Depth]))]
prev) Shaded x y
br -> ( Depth
n₀'forall a. Num a => a -> a -> a
+forall x a. Shaded x a -> Depth
nLeaves Shaded x y
br
                                          , [((x, y), ([Wall x], [Depth]))] -> [((x, y), ([Wall x], [Depth]))]
prev forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. (PseudoAffineWitness x
-> Depth
-> Depth
-> [Wall x]
-> Shaded x y
-> [((x, y), ([Wall x], [Depth]))]
go PseudoAffineWitness x
pw Depth
depth Depth
n₀' [Wall x]
walls Shaded x y
brforall a. [a] -> [a] -> [a]
++)))
                        (Depth
n₀,forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id) NonEmpty (Shaded x y)
dp) []
       go pw :: PseudoAffineWitness x
pw@(PseudoAffineWitness SemimanifoldWitness x
SemimanifoldWitness)
               Depth
depth Depth
n₀ [Wall x]
walls (OverlappingBranches Depth
_ (Shade x
brCtr Metric' x
_) NonEmpty (DBranch x y)
dp)
         = [((x, y), ([Wall x], [Depth]))] -> [((x, y), ([Wall x], [Depth]))]
reassemble forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd
             (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Depth,
 [((x, y), ([Wall x], [Depth]))] -> [((x, y), ([Wall x], [Depth]))])
-> ((Depth, (Needle' x, Shaded x y)),
    [(Depth, (Needle' x, Shaded x y))])
-> (Depth,
    [((x, y), ([Wall x], [Depth]))] -> [((x, y), ([Wall x], [Depth]))])
assignWalls (Depth
n₀,forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id) forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall x y.
(WithField ℝ PseudoAffine x, AdditiveGroup (Needle' x)) =>
Depth
-> [DBranch x y]
-> [((Depth, (Needle' x, Shaded x y)),
     [(Depth, (Needle' x, Shaded x y))])]
directionIChoices Depth
0 forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList NonEmpty (DBranch x y)
dp) []
        where assignWalls :: (Int, DList ((x,y), ([Wall x],[Int])))
                     -> ((Int,(Needle' x, x`Shaded`y)), [(Int,(Needle' x, x`Shaded`y))])
                     -> (Int, DList ((x,y), ([Wall x], [Int])))
              assignWalls :: (Depth,
 [((x, y), ([Wall x], [Depth]))] -> [((x, y), ([Wall x], [Depth]))])
-> ((Depth, (Needle' x, Shaded x y)),
    [(Depth, (Needle' x, Shaded x y))])
-> (Depth,
    [((x, y), ([Wall x], [Depth]))] -> [((x, y), ([Wall x], [Depth]))])
assignWalls (Depth
n₀',[((x, y), ([Wall x], [Depth]))] -> [((x, y), ([Wall x], [Depth]))]
prev) ((Depth
iDir,(Needle' x
thisDir,Shaded x y
br)),[(Depth, (Needle' x, Shaded x y))]
otherDirs)
                    = ( Depth
n₀'forall a. Num a => a -> a -> a
+forall x a. Shaded x a -> Depth
nLeaves Shaded x y
br
                      , [((x, y), ([Wall x], [Depth]))] -> [((x, y), ([Wall x], [Depth]))]
prev forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. (PseudoAffineWitness x
-> Depth
-> Depth
-> [Wall x]
-> Shaded x y
-> [((x, y), ([Wall x], [Depth]))]
go PseudoAffineWitness x
pw (Depth
depthforall a. Num a => a -> a -> a
+Depth
1) Depth
n₀'
                                   ([Wall x]
newWalls forall a. [a] -> [a] -> [a]
++ (Wall x -> Wall x
updWallforall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>[Wall x]
walls))
                                   Shaded x y
br forall a. [a] -> [a] -> [a]
++) )
               where newWalls :: [Wall x]
newWalls = [ forall x.
(Depth, (Depth, Depth))
-> x -> Needle' x -> Scalar (Needle x) -> Wall x
Wall (Depth
depth,(Depth
iDir,Depth
iDir'))
                                       x
brCtr
                                       (Needle' x
thisDirforall v. AdditiveGroup v => v -> v -> v
^-^Needle' x
otherDir)
                                       (ℝ
1forall a. Fractional a => a -> a -> a
/ℝ
0)
                                | (Depth
iDir',(Needle' x
otherDir,Shaded x y
_)) <- [(Depth, (Needle' x, Shaded x y))]
otherDirs ]
                     updWall :: Wall x -> Wall x
updWall Wall x
wall = Wall x
wall forall a b. a -> (a -> b) -> b
& forall x. Lens' (Wall x) (Scalar (Needle x))
wallDistance forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> a -> a
min Scalar (Needle x)
bcDist
                      where Just Needle x
vbw = x
brCtrforall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.Wall x
wallforall s a. s -> Getting a s a -> a
^.forall x. Lens' (Wall x) x
wallAnchor
                            bcDist :: Scalar (Needle x)
bcDist = (Wall x
wallforall s a. s -> Getting a s a -> a
^.forall x. Lens' (Wall x) (Needle' x)
wallNormal)forall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^Needle x
vbw
              reassemble :: [((x,y), ([Wall x],[Int]))] -> [((x,y), ([Wall x],[Int]))]
              reassemble :: [((x, y), ([Wall x], [Depth]))] -> [((x, y), ([Wall x], [Depth]))]
reassemble [((x, y), ([Wall x], [Depth]))]
pts = [ ((x, y)
x, ([Wall x]
higherWalls, [Depth]
newGroupsforall a. [a] -> [a] -> [a]
++[Depth]
deeperGroups))
                               | ((x, y)
x, ([Wall x]
allWalls, [Depth]
deeperGroups)) <- [((x, y), ([Wall x], [Depth]))]
pts
                               , let ([Wall x]
levelWalls,[Wall x]
higherWalls)
                                      = forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((forall a. Ord a => a -> a -> Bool
<Depth
depth) forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall x. Wall x -> (Depth, (Depth, Depth))
_wallID) [Wall x]
allWalls
                                     newGroups :: [Depth]
newGroups = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                                         [ forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault []
                                              (Wall x
wallforall s a. s -> Getting a s a -> a
^.forall x. Lens' (Wall x) (Depth, (Depth, Depth))
wallIDforall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
.forall s t a b. Field2 s t a b => Lens s t a b
_2forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
.forall (p :: * -> * -> *) a b c d.
Swap p =>
Iso (p a b) (p c d) (p b a) (p d c)
swapped) Map (Depth, Depth) [Depth]
groups
                                         | Wall x
wall <- [Wall x]
levelWalls ]
                               ]
               where groups :: Map (Depth, Depth) [Depth]
groups = (forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ []) forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
(.)
                               [ (Wall x
wallforall s a. s -> Getting a s a -> a
^.forall x. Lens' (Wall x) (Depth, (Depth, Depth))
wallIDforall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
.forall s t a b. Field2 s t a b => Lens s t a b
_2, (Depth
iforall a. a -> [a] -> [a]
:))
                               | (Depth
i,((x, y)
_, ([Wall x]
gsc,[Depth]
_))) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Depth
n₀..] [((x, y), ([Wall x], [Depth]))]
pts
                               , Wall x
wall <- forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((forall a. Eq a => a -> a -> Bool
==Depth
depth) forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall x. Wall x -> (Depth, (Depth, Depth))
_wallID) [Wall x]
gsc ]









-- |
-- @
-- '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 []

type LeafyTree x y = GenericTree [] (ListT (Either y)) x
    
newtype GenericTree c b x = GenericTree { forall (c :: * -> *) (b :: * -> *) x.
GenericTree c b x -> c (x, GenericTree b b x)
treeBranches :: c (x,GenericTree b b x) }
 deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (c :: * -> *) (b :: * -> *) x x.
Rep (GenericTree c b x) x -> GenericTree c b x
forall (c :: * -> *) (b :: * -> *) x x.
GenericTree c b x -> Rep (GenericTree c b x) x
$cto :: forall (c :: * -> *) (b :: * -> *) x x.
Rep (GenericTree c b x) x -> GenericTree c b x
$cfrom :: forall (c :: * -> *) (b :: * -> *) x x.
GenericTree c b x -> Rep (GenericTree c b x) x
Generic, forall a b. a -> GenericTree c b b -> GenericTree c b a
forall a b. (a -> b) -> GenericTree c b a -> GenericTree c b b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (c :: * -> *) (b :: * -> *) a b.
(Functor c, Functor b) =>
a -> GenericTree c b b -> GenericTree c b a
forall (c :: * -> *) (b :: * -> *) a b.
(Functor c, Functor b) =>
(a -> b) -> GenericTree c b a -> GenericTree c b b
<$ :: forall a b. a -> GenericTree c b b -> GenericTree c b a
$c<$ :: forall (c :: * -> *) (b :: * -> *) a b.
(Functor c, Functor b) =>
a -> GenericTree c b b -> GenericTree c b a
fmap :: forall a b. (a -> b) -> GenericTree c b a -> GenericTree c b b
$cfmap :: forall (c :: * -> *) (b :: * -> *) a b.
(Functor c, Functor b) =>
(a -> b) -> GenericTree c b a -> GenericTree c b b
Hask.Functor, forall a. GenericTree c b a -> Bool
forall m a. Monoid m => (a -> m) -> GenericTree c b a -> m
forall a b. (a -> b -> b) -> b -> GenericTree c b a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Depth)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
forall (c :: * -> *) (b :: * -> *) a.
(Foldable c, Foldable b, Eq a) =>
a -> GenericTree c b a -> Bool
forall (c :: * -> *) (b :: * -> *) a.
(Foldable c, Foldable b, Num a) =>
GenericTree c b a -> a
forall (c :: * -> *) (b :: * -> *) a.
(Foldable c, Foldable b, Ord a) =>
GenericTree c b a -> a
forall (c :: * -> *) (b :: * -> *) m.
(Foldable c, Foldable b, Monoid m) =>
GenericTree c b m -> m
forall (c :: * -> *) (b :: * -> *) a.
(Foldable c, Foldable b) =>
GenericTree c b a -> Bool
forall (c :: * -> *) (b :: * -> *) a.
(Foldable c, Foldable b) =>
GenericTree c b a -> Depth
forall (c :: * -> *) (b :: * -> *) a.
(Foldable c, Foldable b) =>
GenericTree c b a -> [a]
forall (c :: * -> *) (b :: * -> *) a.
(Foldable c, Foldable b) =>
(a -> a -> a) -> GenericTree c b a -> a
forall (c :: * -> *) (b :: * -> *) m a.
(Foldable c, Foldable b, Monoid m) =>
(a -> m) -> GenericTree c b a -> m
forall (c :: * -> *) (b :: * -> *) b a.
(Foldable c, Foldable b) =>
(b -> a -> b) -> b -> GenericTree c b a -> b
forall (c :: * -> *) (b :: * -> *) a b.
(Foldable c, Foldable b) =>
(a -> b -> b) -> b -> GenericTree c b a -> b
product :: forall a. Num a => GenericTree c b a -> a
$cproduct :: forall (c :: * -> *) (b :: * -> *) a.
(Foldable c, Foldable b, Num a) =>
GenericTree c b a -> a
sum :: forall a. Num a => GenericTree c b a -> a
$csum :: forall (c :: * -> *) (b :: * -> *) a.
(Foldable c, Foldable b, Num a) =>
GenericTree c b a -> a
minimum :: forall a. Ord a => GenericTree c b a -> a
$cminimum :: forall (c :: * -> *) (b :: * -> *) a.
(Foldable c, Foldable b, Ord a) =>
GenericTree c b a -> a
maximum :: forall a. Ord a => GenericTree c b a -> a
$cmaximum :: forall (c :: * -> *) (b :: * -> *) a.
(Foldable c, Foldable b, Ord a) =>
GenericTree c b a -> a
elem :: forall a. Eq a => a -> GenericTree c b a -> Bool
$celem :: forall (c :: * -> *) (b :: * -> *) a.
(Foldable c, Foldable b, Eq a) =>
a -> GenericTree c b a -> Bool
length :: forall a. GenericTree c b a -> Depth
$clength :: forall (c :: * -> *) (b :: * -> *) a.
(Foldable c, Foldable b) =>
GenericTree c b a -> Depth
null :: forall a. GenericTree c b a -> Bool
$cnull :: forall (c :: * -> *) (b :: * -> *) a.
(Foldable c, Foldable b) =>
GenericTree c b a -> Bool
toList :: forall a. GenericTree c b a -> [a]
$ctoList :: forall (c :: * -> *) (b :: * -> *) a.
(Foldable c, Foldable b) =>
GenericTree c b a -> [a]
foldl1 :: forall a. (a -> a -> a) -> GenericTree c b a -> a
$cfoldl1 :: forall (c :: * -> *) (b :: * -> *) a.
(Foldable c, Foldable b) =>
(a -> a -> a) -> GenericTree c b a -> a
foldr1 :: forall a. (a -> a -> a) -> GenericTree c b a -> a
$cfoldr1 :: forall (c :: * -> *) (b :: * -> *) a.
(Foldable c, Foldable b) =>
(a -> a -> a) -> GenericTree c b a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> GenericTree c b a -> b
$cfoldl' :: forall (c :: * -> *) (b :: * -> *) b a.
(Foldable c, Foldable b) =>
(b -> a -> b) -> b -> GenericTree c b a -> b
foldl :: forall b a. (b -> a -> b) -> b -> GenericTree c b a -> b
$cfoldl :: forall (c :: * -> *) (b :: * -> *) b a.
(Foldable c, Foldable b) =>
(b -> a -> b) -> b -> GenericTree c b a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> GenericTree c b a -> b
$cfoldr' :: forall (c :: * -> *) (b :: * -> *) a b.
(Foldable c, Foldable b) =>
(a -> b -> b) -> b -> GenericTree c b a -> b
foldr :: forall a b. (a -> b -> b) -> b -> GenericTree c b a -> b
$cfoldr :: forall (c :: * -> *) (b :: * -> *) a b.
(Foldable c, Foldable b) =>
(a -> b -> b) -> b -> GenericTree c b a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> GenericTree c b a -> m
$cfoldMap' :: forall (c :: * -> *) (b :: * -> *) m a.
(Foldable c, Foldable b, Monoid m) =>
(a -> m) -> GenericTree c b a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> GenericTree c b a -> m
$cfoldMap :: forall (c :: * -> *) (b :: * -> *) m a.
(Foldable c, Foldable b, Monoid m) =>
(a -> m) -> GenericTree c b a -> m
fold :: forall m. Monoid m => GenericTree c b m -> m
$cfold :: forall (c :: * -> *) (b :: * -> *) m.
(Foldable c, Foldable b, Monoid m) =>
GenericTree c b m -> m
Hask.Foldable, forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GenericTree c b a -> f (GenericTree c b b)
forall {c :: * -> *} {b :: * -> *}.
(Traversable c, Traversable b) =>
Functor (GenericTree c b)
forall {c :: * -> *} {b :: * -> *}.
(Traversable c, Traversable b) =>
Foldable (GenericTree c b)
forall (c :: * -> *) (b :: * -> *) (m :: * -> *) a.
(Traversable c, Traversable b, Monad m) =>
GenericTree c b (m a) -> m (GenericTree c b a)
forall (c :: * -> *) (b :: * -> *) (f :: * -> *) a.
(Traversable c, Traversable b, Applicative f) =>
GenericTree c b (f a) -> f (GenericTree c b a)
forall (c :: * -> *) (b :: * -> *) (m :: * -> *) a b.
(Traversable c, Traversable b, Monad m) =>
(a -> m b) -> GenericTree c b a -> m (GenericTree c b b)
forall (c :: * -> *) (b :: * -> *) (f :: * -> *) a b.
(Traversable c, Traversable b, Applicative f) =>
(a -> f b) -> GenericTree c b a -> f (GenericTree c b b)
sequence :: forall (m :: * -> *) a.
Monad m =>
GenericTree c b (m a) -> m (GenericTree c b a)
$csequence :: forall (c :: * -> *) (b :: * -> *) (m :: * -> *) a.
(Traversable c, Traversable b, Monad m) =>
GenericTree c b (m a) -> m (GenericTree c b a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> GenericTree c b a -> m (GenericTree c b b)
$cmapM :: forall (c :: * -> *) (b :: * -> *) (m :: * -> *) a b.
(Traversable c, Traversable b, Monad m) =>
(a -> m b) -> GenericTree c b a -> m (GenericTree c b b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
GenericTree c b (f a) -> f (GenericTree c b a)
$csequenceA :: forall (c :: * -> *) (b :: * -> *) (f :: * -> *) a.
(Traversable c, Traversable b, Applicative f) =>
GenericTree c b (f a) -> f (GenericTree c b a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GenericTree c b a -> f (GenericTree c b b)
$ctraverse :: forall (c :: * -> *) (b :: * -> *) (f :: * -> *) a b.
(Traversable c, Traversable b, Applicative f) =>
(a -> f b) -> GenericTree c b a -> f (GenericTree c b b)
Hask.Traversable)
instance (NFData x, Hask.Foldable c, Hask.Foldable b) => NFData (GenericTree c b x) where
  rnf :: GenericTree c b x -> ()
rnf (GenericTree c (x, GenericTree b b x)
t) = forall a. NFData a => a -> ()
rnf forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList c (x, GenericTree b b x)
t
instance (Hask.MonadPlus c) => Semigroup (GenericTree c b x) where
  GenericTree c (x, GenericTree b b x)
b1 <> :: GenericTree c b x -> GenericTree c b x -> GenericTree c b x
<> GenericTree c (x, GenericTree b b x)
b2 = forall (c :: * -> *) (b :: * -> *) x.
c (x, GenericTree b b x) -> GenericTree c b x
GenericTree forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
Hask.mplus c (x, GenericTree b b x)
b1 c (x, GenericTree b b x)
b2
instance (Hask.MonadPlus c) => Monoid (GenericTree c b x) where
  mempty :: GenericTree c b x
mempty = forall (c :: * -> *) (b :: * -> *) x.
c (x, GenericTree b b x) -> GenericTree c b x
GenericTree forall (m :: * -> *) a. MonadPlus m => m a
Hask.mzero
  mappend :: GenericTree c b x -> GenericTree c b x -> GenericTree c b x
mappend = forall a. Semigroup a => a -> a -> a
(<>)
instance Show (c (x, GenericTree b b x)) => Show (GenericTree c b x) where
  showsPrec :: Depth -> GenericTree c b x -> ShowS
showsPrec Depth
p (GenericTree c (x, GenericTree b b x)
t) = Bool -> ShowS -> ShowS
showParen (Depth
pforall a. Ord a => a -> a -> Bool
>Depth
9) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (Char
'朳'forall a. a -> [a] -> [a]
:) forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall a. Show a => Depth -> a -> ShowS
showsPrec Depth
10 c (x, GenericTree b b x)
t
deriving instance Eq (c (x, GenericTree b b x)) => Eq (GenericTree c b x)

-- | @U+6733 CJK UNIFIED IDEOGRAPH tree@.
--  The main purpose of this is to give 'GenericTree' a more concise 'Show' instance.
朳 :: c (x, GenericTree b b x) -> GenericTree c b x
朳 :: forall (c :: * -> *) x (b :: * -> *).
c (x, GenericTree b b x) -> GenericTree c b x
朳 = forall (c :: * -> *) (b :: * -> *) x.
c (x, GenericTree b b x) -> GenericTree c b x
GenericTree

-- | Imitate the specialised 'ShadeTree' structure with a simpler, generic tree.
onlyNodes :: ∀ x . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x))
                => ShadeTree x -> Trees x
onlyNodes :: forall x.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
ShadeTree x -> Trees x
onlyNodes (PlainLeaves []) = forall (c :: * -> *) (b :: * -> *) x.
c (x, GenericTree b b x) -> GenericTree c b x
GenericTree []
onlyNodes (PlainLeaves [(x, ())]
ps) = let (x
ctr,([(x, ())], [(x, ())])
_) = forall x y (p :: * -> *).
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x), Functor p) =>
p x -> NonEmpty (x, y) -> (x, ([(x, y)], [(x, y)]))
pseudoECM ([]::[x]) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. [a] -> NonEmpty a
NE.fromList [(x, ())]
ps
                             in forall (c :: * -> *) (b :: * -> *) x.
c (x, GenericTree b b x) -> GenericTree c b x
GenericTree [ (x
ctr, forall (c :: * -> *) (b :: * -> *) x.
c (x, GenericTree b b x) -> GenericTree c b x
GenericTree forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (,forall a. Monoid a => a
mempty)forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
.forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> [(x, ())]
ps) ]
onlyNodes (DisjointBranches Depth
_ NonEmpty (Shaded x ())
brs) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Hask.foldMap forall x.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
ShadeTree x -> Trees x
onlyNodes NonEmpty (Shaded x ())
brs
onlyNodes (OverlappingBranches Depth
_ (Shade x
ctr Metric' x
_) NonEmpty (DBranch x ())
brs)
              = forall (c :: * -> *) (b :: * -> *) x.
c (x, GenericTree b b x) -> GenericTree c b x
GenericTree [ ( x
ctr
                              , forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Hask.foldMap (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Hask.foldMap forall x.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
ShadeTree x -> Trees x
onlyNodes) NonEmpty (DBranch x ())
brs ) ]

entireTree :: ∀ x y . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x))
              => x`Shaded`y -> LeafyTree x y
entireTree :: forall x y.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
Shaded x y -> LeafyTree x y
entireTree (PlainLeaves [(x, y)]
lvs)
    = let (x
ctr,([(x, y)], [(x, y)])
_) = forall x y (p :: * -> *).
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x), Functor p) =>
p x -> NonEmpty (x, y) -> (x, ([(x, y)], [(x, y)]))
pseudoECM ([]::[x]) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. [a] -> NonEmpty a
NE.fromList [(x, y)]
lvs
      in  forall (c :: * -> *) (b :: * -> *) x.
c (x, GenericTree b b x) -> GenericTree c b x
GenericTree [ (x
ctr, forall (c :: * -> *) (b :: * -> *) x.
c (x, GenericTree b b x) -> GenericTree c b x
GenericTree forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Foldable f) =>
f a -> ListT m a
ListT.fromFoldable
                                [ (x
x, forall (c :: * -> *) (b :: * -> *) x.
c (x, GenericTree b b x) -> GenericTree c b x
GenericTree forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a b. a -> Either a b
Left y
y)
                                | (x
x,y
y)<-[(x, y)]
lvs ] )
                      ]
entireTree (DisjointBranches Depth
_ NonEmpty (Shaded x y)
brs)
    = forall (c :: * -> *) (b :: * -> *) x.
c (x, GenericTree b b x) -> GenericTree c b x
GenericTree [ (x
x, forall (c :: * -> *) (b :: * -> *) x.
c (x, GenericTree b b x) -> GenericTree c b x
GenericTree ListT
  (Either y) (x, GenericTree (ListT (Either y)) (ListT (Either y)) x)
subt)
                  | GenericTree [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)]
sub <- forall a. NonEmpty a -> [a]
NE.toList forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap forall x y.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
Shaded x y -> LeafyTree x y
entireTree NonEmpty (Shaded x y)
brs
                  , (x
x, GenericTree ListT
  (Either y) (x, GenericTree (ListT (Either y)) (ListT (Either y)) x)
subt) <- [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)]
sub ]
entireTree (OverlappingBranches Depth
_ (Shade x
ctr Metric' x
_) NonEmpty (DBranch x y)
brs)
    = forall (c :: * -> *) (b :: * -> *) x.
c (x, GenericTree b b x) -> GenericTree c b x
GenericTree [ ( x
ctr
                    , forall (c :: * -> *) (b :: * -> *) x.
c (x, GenericTree b b x) -> GenericTree c b x
GenericTree forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Foldable f) =>
f a -> ListT m a
ListT.fromFoldable
                       forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Hask.foldMap (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Hask.foldMap forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (c :: * -> *) (b :: * -> *) x.
GenericTree c b x -> c (x, GenericTree b b x)
treeBranches forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall x y.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
Shaded x y -> LeafyTree x y
entireTree) NonEmpty (DBranch x y)
brs ) ]


-- | Left (and, typically, also right) inverse of 'fromLeafNodes'.
onlyLeaves_ :: WithField ℝ PseudoAffine x => ShadeTree x -> [x]
onlyLeaves_ :: forall x. WithField ℝ PseudoAffine x => ShadeTree x -> [x]
onlyLeaves_ = forall a b. (a -> b) -> [a] -> [b]
map forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall x y. WithField ℝ PseudoAffine x => Shaded x y -> [(x, y)]
onlyLeaves

onlyLeaves :: WithField ℝ PseudoAffine x => x`Shaded`y -> [(x,y)]
onlyLeaves :: forall x y. WithField ℝ PseudoAffine x => Shaded x y -> [(x, y)]
onlyLeaves Shaded x y
tree = forall {x} {y}. Shaded x y -> [(x, y)] -> [(x, y)]
dismantle Shaded x y
tree []
 where dismantle :: Shaded x y -> [(x, y)] -> [(x, y)]
dismantle (PlainLeaves [(x, y)]
xs) = ([(x, y)]
xsforall a. [a] -> [a] -> [a]
++)
       dismantle (OverlappingBranches Depth
_ Shade x
_ NonEmpty (DBranch x y)
brs)
              = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
(.) forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. Shaded x y -> [(x, y)] -> [(x, y)]
dismantle) forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Hask.foldMap (forall (t :: * -> *) a. Foldable t => t a -> [a]
Hask.toList) NonEmpty (DBranch x y)
brs
       dismantle (DisjointBranches Depth
_ NonEmpty (Shaded x y)
brs) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
(.) forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. Shaded x y -> [(x, y)] -> [(x, y)]
dismantle) forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Shaded x y)
brs








data Sawbones x = Sawbones { forall x. Sawbones x -> [x] -> [x]
sawnTrunk1, forall x. Sawbones x -> [x] -> [x]
sawnTrunk2 :: [x]->[x]
                           , forall x. Sawbones x -> [x]
sawdust1,   forall x. Sawbones x -> [x]
sawdust2   :: [x]      }
instance Semigroup (Sawbones x) where
  Sawbones [x] -> [x]
st11 [x] -> [x]
st12 [x]
sd11 [x]
sd12 <> :: Sawbones x -> Sawbones x -> Sawbones x
<> Sawbones [x] -> [x]
st21 [x] -> [x]
st22 [x]
sd21 [x]
sd22
     = forall x. ([x] -> [x]) -> ([x] -> [x]) -> [x] -> [x] -> Sawbones x
Sawbones ([x] -> [x]
st11forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
.[x] -> [x]
st21) ([x] -> [x]
st12forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
.[x] -> [x]
st22) ([x]
sd11forall a. Semigroup a => a -> a -> a
<>[x]
sd21) ([x]
sd12forall a. Semigroup a => a -> a -> a
<>[x]
sd22)
instance Monoid (Sawbones x) where
  mempty :: Sawbones x
mempty = forall x. ([x] -> [x]) -> ([x] -> [x]) -> [x] -> [x] -> Sawbones x
Sawbones forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id [] []
  mappend :: Sawbones x -> Sawbones x -> Sawbones x
mappend = forall a. Semigroup a => a -> a -> a
(<>)



type DList x = [x]->[x]
    
data DustyEdges x = DustyEdges { forall x. DustyEdges x -> DList x
sawChunk :: DList x, forall x. DustyEdges x -> DBranches' x [x]
chunkDust :: DBranches' x [x] }
instance Semigroup (DustyEdges x) where
  DustyEdges DList x
c1 DBranches' x [x]
d1 <> :: DustyEdges x -> DustyEdges x -> DustyEdges x
<> DustyEdges DList x
c2 DBranches' x [x]
d2 = forall x. DList x -> DBranches' x [x] -> DustyEdges x
DustyEdges (DList x
c1forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
.DList x
c2) (DBranches' x [x]
d1forall a. Semigroup a => a -> a -> a
<>DBranches' x [x]
d2)

data Sawboneses x = SingleCut (Sawbones x)
                  | Sawboneses (DBranches' x (DustyEdges x))
    deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall x x. Rep (Sawboneses x) x -> Sawboneses x
forall x x. Sawboneses x -> Rep (Sawboneses x) x
$cto :: forall x x. Rep (Sawboneses x) x -> Sawboneses x
$cfrom :: forall x x. Sawboneses x -> Rep (Sawboneses x) x
Generic)
instance Semigroup (Sawboneses x) where
  SingleCut Sawbones x
c <> :: Sawboneses x -> Sawboneses x -> Sawboneses x
<> SingleCut Sawbones x
d = forall x. Sawbones x -> Sawboneses x
SingleCut forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Sawbones x
cforall a. Semigroup a => a -> a -> a
<>Sawbones x
d
  Sawboneses DBranches' x (DustyEdges x)
c <> Sawboneses DBranches' x (DustyEdges x)
d = forall x. DBranches' x (DustyEdges x) -> Sawboneses x
Sawboneses forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ DBranches' x (DustyEdges x)
cforall a. Semigroup a => a -> a -> a
<>DBranches' x (DustyEdges x)
d






constShaded :: y -> x`Shaded`y₀ -> x`Shaded`y
constShaded :: forall y x y₀. y -> Shaded x y₀ -> Shaded x y
constShaded y
y = forall x y ξ υ.
(NonEmpty (x, y) -> NonEmpty (ξ, υ))
-> (Needle' x -> Needle' ξ)
-> (Shade x -> Shade ξ)
-> Shaded x y
-> Shaded ξ υ
unsafeFmapTree (forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall (a :: * -> * -> *) d b c.
(Morphism a, ObjectPair a d b, ObjectPair a d c) =>
a b c -> a (d, b) (d, c)
second forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (a :: * -> * -> *) b x.
(WellPointed a, Object a b, ObjectPoint a x) =>
x -> a b x
const y
y) forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id

fmapShaded :: (Semimanifold x, SimpleSpace (Needle x))
                   => (y -> υ) -> (x`Shaded`y) -> (x`Shaded`υ)
fmapShaded :: forall x y υ.
(Semimanifold x, SimpleSpace (Needle x)) =>
(y -> υ) -> Shaded x y -> Shaded x υ
fmapShaded y -> υ
f = forall x y ξ υ.
(NonEmpty (x, y) -> NonEmpty (ξ, υ))
-> (Needle' x -> Needle' ξ)
-> (Shade x -> Shade ξ)
-> Shaded x y
-> Shaded ξ υ
unsafeFmapTree (forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (a :: * -> * -> *) d b c.
(Morphism a, ObjectPair a d b, ObjectPair a d c) =>
a b c -> a (d, b) (d, c)
second y -> υ
f) forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id

zipTreeWithList :: x`Shaded`w -> NonEmpty y -> (x`Shaded`(w,y))
zipTreeWithList :: forall x w y. Shaded x w -> NonEmpty y -> Shaded x (w, y)
zipTreeWithList Shaded x w
tree = forall {x} {y} {a}. Shaded x y -> [a] -> Shaded x (y, a)
go Shaded x w
tree forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall a. NonEmpty a -> [a]
NE.toList forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall a. NonEmpty a -> NonEmpty a
NE.cycle
 where go :: Shaded x y -> [a] -> Shaded x (y, a)
go (PlainLeaves [(x, y)]
lvs) [a]
ys = forall x y. [(x, y)] -> Shaded x y
PlainLeaves forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(x
x,y
w) a
y -> (x
x,(y
w,a
y))) [(x, y)]
lvs [a]
ys
       go (DisjointBranches Depth
n NonEmpty (Shaded x y)
brs) [a]
ys
             = forall x y. Depth -> NonEmpty (Shaded x y) -> Shaded x y
DisjointBranches Depth
n forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall a. [a] -> NonEmpty a
NE.fromList
                  forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\([a]
ys',[Shaded x (y, a)] -> [Shaded x (y, a)]
prev) Shaded x y
br -> 
                                    (forall a. Depth -> [a] -> [a]
drop (forall x a. Shaded x a -> Depth
nLeaves Shaded x y
br) [a]
ys', [Shaded x (y, a)] -> [Shaded x (y, a)]
prev forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. (Shaded x y -> [a] -> Shaded x (y, a)
go Shaded x y
br [a]
ys'forall a. a -> [a] -> [a]
:)) )
                           ([a]
ys,forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Shaded x y)
brs) []
       go (OverlappingBranches Depth
n Shade x
shx NonEmpty (DBranch x y)
brs) [a]
ys
             = forall x y.
Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
OverlappingBranches Depth
n Shade x
shx forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall a. [a] -> NonEmpty a
NE.fromList
                  forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\([a]
ys',[DBranch x (y, a)] -> [DBranch x (y, a)]
prev) (DBranch Needle' x
dir (Hourglass Shaded x y
top Shaded x y
bot))
                        -> case forall a. Depth -> [a] -> [a]
drop (forall x a. Shaded x a -> Depth
nLeaves Shaded x y
top) [a]
ys' of
                              [a]
ys'' -> ( forall a. Depth -> [a] -> [a]
drop (forall x a. Shaded x a -> Depth
nLeaves Shaded x y
bot) [a]
ys''
                                      , [DBranch x (y, a)] -> [DBranch x (y, a)]
prev forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. (forall x c. Needle' x -> Hourglass c -> DBranch' x c
DBranch Needle' x
dir (forall s. s -> s -> Hourglass s
Hourglass (Shaded x y -> [a] -> Shaded x (y, a)
go Shaded x y
top [a]
ys')
                                                                       (Shaded x y -> [a] -> Shaded x (y, a)
go Shaded x y
bot [a]
ys''))forall a. a -> [a] -> [a]
:)
                                      ) )
                           ([a]
ys,forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList NonEmpty (DBranch x y)
brs) []

stiWithDensity :: ∀ x y . ( WithField ℝ PseudoAffine x, LinearSpace y, Scalar y ~ ℝ
                          , SimpleSpace (Needle x) )
         => x`Shaded`y -> x -> Cℝay y
stiWithDensity :: forall x y.
(WithField ℝ PseudoAffine x, LinearSpace y, Scalar y ~ ℝ,
 SimpleSpace (Needle x)) =>
Shaded x y -> x -> Cℝay y
stiWithDensity (PlainLeaves [(x, y)]
lvs)
  | LinearManifoldWitness y
LinearManifoldWitness <- forall v. TensorSpace v => LinearManifoldWitness v
linearManifoldWitness @y
  , [Shade x
baryc Metric' x
expa :: Shade x] <- forall x.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
[x] -> [Shade x]
pointsShades forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> [(x, y)]
lvs
       = let nlvs :: ℝ
nlvs = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Depth
length [(x, y)]
lvs :: ℝ
             indiShapes :: [(Shade x, y)]
indiShapes = [(forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade x
p Metric' x
expa, y
y) | (x
p,y
y) <- [(x, y)]
lvs]
         in \x
x -> let lcCoeffs :: [ℝ]
lcCoeffs = [ forall (shade :: * -> *) x s.
(IsShade shade, PseudoAffine x, SimpleSpace (Needle x),
 s ~ Scalar (Needle x), RealFloat' s) =>
shade x -> x -> s
occlusion Shade x
psh x
x | (Shade x
psh, y
_) <- [(Shade x, y)]
indiShapes ]
                      dens :: ℝ
dens = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ℝ]
lcCoeffs
                  in forall v.
(AdditiveGroup v, Real (Scalar (Needle v))) =>
Scalar (Needle v) -> v -> Cℝay v
mkCone ℝ
dens forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall v. VectorSpace v => [(v, Scalar v)] -> v
linearCombo forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall a b. [a] -> [b] -> [(a, b)]
zip (forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
sndforall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>[(Shade x, y)]
indiShapes)
                       forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (forall a. Fractional a => a -> a -> a
/ℝ
dens)forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>[ℝ]
lcCoeffs
stiWithDensity (DisjointBranches Depth
_ NonEmpty (Shaded x y)
lvs)
           = case forall v. TensorSpace v => LinearManifoldWitness v
linearManifoldWitness @y of
          LinearManifoldWitness y
LinearManifoldWitness -> \x
x -> forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall {x}.
(Eq (Scalar (Needle x)), Num (Scalar (Needle x))) =>
Cℝay x -> Cℝay x -> Cℝay x
qGather forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (forall x y.
(WithField ℝ PseudoAffine x, LinearSpace y, Scalar y ~ ℝ,
 SimpleSpace (Needle x)) =>
Shaded x y -> x -> Cℝay y
`stiWithDensity`x
x)forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>NonEmpty (Shaded x y)
lvs
 where qGather :: Cℝay x -> Cℝay x -> Cℝay x
qGather (Cℝay Scalar (Needle x)
0 x
_) Cℝay x
o = Cℝay x
o
       qGather Cℝay x
o Cℝay x
_ = Cℝay x
o
stiWithDensity (OverlappingBranches Depth
n (Shade x
bc Metric' x
extend) NonEmpty (DBranch x y)
brs)
           = (DualNeedleWitness x, PseudoAffineWitness x,
 LinearManifoldWitness y)
-> x -> Cℝay y
ovbSWD (forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness, forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness, forall v. TensorSpace v => LinearManifoldWitness v
linearManifoldWitness)
 where ovbSWD :: (DualNeedleWitness x, PseudoAffineWitness x, LinearManifoldWitness y)
                     -> x -> Cℝay y
       ovbSWD :: (DualNeedleWitness x, PseudoAffineWitness x,
 LinearManifoldWitness y)
-> x -> Cℝay y
ovbSWD (DualNeedleWitness x
DualSpaceWitness
          , PseudoAffineWitness SemimanifoldWitness x
SemimanifoldWitness, LinearManifoldWitness y
LinearManifoldWitness) x
x
                     = case x
xforall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
bc of
           Just Needle x
v
             | Scalar (Needle x)
dist² <- forall v. LSpace v => Seminorm v -> v -> Scalar v
normSq Norm (Needle x)
ε Needle x
v
             , Scalar (Needle x)
dist² forall a. Ord a => a -> a -> Bool
< ℝ
9
             , ℝ
att <- forall a. Floating a => a -> a
exp(ℝ
1forall a. Fractional a => a -> a -> a
/(Scalar (Needle x)
dist²forall a. Num a => a -> a -> a
-ℝ
9)forall a. Num a => a -> a -> a
+ℝ
1forall a. Fractional a => a -> a -> a
/ℝ
9)
               -> forall {a}.
(Scalar (Needle a) ~ Scalar a, Real (Scalar (Needle a)),
 VectorSpace a, Fractional (Scalar (Needle a))) =>
Scalar (Needle a) -> NonEmpty (Cℝay a) -> Cℝay a
qGather ℝ
att forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ x
x) NonEmpty (x -> Cℝay y)
downPrepared
           Maybe (Needle x)
_ -> forall v. (AdditiveGroup v, Num (Scalar (Needle v))) => Cℝay v
coneTip
       ε :: Norm (Needle x)
ε = forall v. SimpleSpace v => Variance v -> Norm v
dualNorm' Metric' x
extend :: Norm (Needle x)
       downPrepared :: NonEmpty (x -> Cℝay y)
downPrepared = forall {y} {x} {x}.
(Scalar y ~ ℝ, Scalar (Needle x) ~ ℝ,
 Scalar (DualVector (Needle x)) ~ ℝ, FiniteDimensional (Needle x),
 FiniteDimensional (DualVector (Needle x)), SemiInner (Needle x),
 SemiInner (DualVector (Needle x)), IEEE (Scalar (Needle x)),
 InnerSpace (Scalar (Needle x)), LinearSpace y, PseudoAffine x) =>
DBranch' x (Shaded x y) -> NonEmpty (x -> Cℝay y)
dp forall (m :: * -> *) (k :: * -> * -> *) a b.
(Monad m k, Object k a, Object k b, Object k (m a), Object k (m b),
 Object k (m (m b))) =>
k a (m b) -> k (m a) (m b)
=<< NonEmpty (DBranch x y)
brs
        where dp :: DBranch' x (Shaded x y) -> NonEmpty (x -> Cℝay y)
dp (DBranch Needle' x
_ (Hourglass Shaded x y
up Shaded x y
dn))
                 = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap forall x y.
(WithField ℝ PseudoAffine x, LinearSpace y, Scalar y ~ ℝ,
 SimpleSpace (Needle x)) =>
Shaded x y -> x -> Cℝay y
stiWithDensity forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Shaded x y
upforall a. a -> [a] -> NonEmpty a
:|[Shaded x y
dn]
       qGather :: Scalar (Needle a) -> NonEmpty (Cℝay a) -> Cℝay a
qGather Scalar (Needle a)
att NonEmpty (Cℝay a)
contribs = forall v.
(AdditiveGroup v, Real (Scalar (Needle v))) =>
Scalar (Needle v) -> v -> Cℝay v
mkCone (Scalar (Needle a)
attforall a. Num a => a -> a -> a
*Scalar (Needle a)
dens)
                 forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall v. VectorSpace v => [(v, Scalar v)] -> v
linearCombo [(a
v, Scalar (Needle a)
dforall a. Fractional a => a -> a -> a
/Scalar (Needle a)
dens) | Cℝay Scalar (Needle a)
d a
v <- forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Cℝay a)
contribs]
        where dens :: Scalar (Needle a)
dens = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall x. Cℝay x -> Scalar (Needle x)
hParamCℝay forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> NonEmpty (Cℝay a)
contribs)

stiAsIntervalMapping :: (x ~ ℝ, y ~ ℝ)
            => x`Shaded`y -> [(x, ((y, Diff y), LinearMap ℝ x y))]
stiAsIntervalMapping :: forall x y.
(x ~ ℝ, y ~ ℝ) =>
Shaded x y -> [(x, ((y, Diff y), LinearMap ℝ x y))]
stiAsIntervalMapping = forall x y.
(WithField ℝ Manifold x, SimpleSpace (Needle x)) =>
Shaded x y -> [(Twig x y, TwigEnviron x y)]
twigsWithEnvirons forall (m :: * -> *) (k :: * -> * -> *) a b c.
(Monad m k, Object k a, Object k b, Object k c, Object k (m b),
 Object k (m c), Object k (m (m c))) =>
k a (m b) -> k b (m c) -> k a (m c)
>=> forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a.
(Applicative f r t, Object r a, Object t (f a)) =>
t a (f a)
pureforall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
.forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
sndforall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
.forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst forall (m :: * -> *) (k :: * -> * -> *) a b c.
(Monad m k, Object k a, Object k b, Object k c, Object k (m b),
 Object k (m c), Object k (m (m c))) =>
k a (m b) -> k b (m c) -> k a (m c)
>=> forall x y.
(WithField ℝ PseudoAffine x, WithField ℝ PseudoAffine y,
 SimpleSpace (Needle x), SimpleSpace (Needle y)) =>
Shaded x y -> [Shade' (x, y)]
completeTopShading forall (m :: * -> *) (k :: * -> * -> *) a b c.
(Monad m k, Object k a, Object k b, Object k c, Object k (m b),
 Object k (m c), Object k (m (m c))) =>
k a (m b) -> k b (m c) -> k a (m c)
>=> forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a.
(Applicative f r t, Object r a, Object t (f a)) =>
t a (f a)
pureforall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
.
             \(Shade' (ℝ
xloc, ℝ
yloc) Metric (ℝ, ℝ)
shd)
                 -> ( ℝ
xloc, ( (ℝ
yloc, forall a. Fractional a => a -> a
recip forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Metric (ℝ, ℝ)
shdforall v.
(LSpace v, Floating (Scalar v)) =>
Seminorm v -> v -> Scalar v
|$|(Needle ℝ
0,Needle ℝ
1))
                            , forall u v.
(SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v) =>
Variance (u, v) -> u +> v
dependence (forall v. SimpleSpace v => Norm v -> Variance v
dualNorm Metric (ℝ, ℝ)
shd) ) )


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 :: forall x y.
(WithField ℝ Manifold x, WithField ℝ Manifold y,
 SimpleSpace (Needle x), SimpleSpace (Needle y)) =>
(Shade x -> Shade y) -> ShadeTree x -> Shaded x y
spanShading Shade x -> Shade y
f = forall x y ξ υ.
(NonEmpty (x, y) -> NonEmpty (ξ, υ))
-> (Needle' x -> Needle' ξ)
-> (Shade x -> Shade ξ)
-> Shaded x y
-> Shaded ξ υ
unsafeFmapTree (NonEmpty x -> NonEmpty (x, y)
addYs forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst) forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id
 where addYs :: NonEmpty x -> NonEmpty (x,y)
       addYs :: NonEmpty x -> NonEmpty (x, y)
addYs NonEmpty x
l = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. a -> NonEmpty a -> NonEmpty a
(NE.<|) (forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (,y
ymid) NonEmpty x
l     )
                               (forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (x
xmid,) [y]
yexamp)
          where [xsh :: Shade x
xsh@(Shade x
xmid Metric' x
_)] = forall x.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
[x] -> [Shade x]
pointsCovers forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
                                           forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ NonEmpty x
l
                Shade y
ymid Metric' y
yexpa = Shade x -> Shade y
f Shade x
xsh
                yexamp :: [y]
yexamp = [ y
ymid forall x. Semimanifold x => x -> Needle x -> x
.+~^ Scalar (Needle y)
σforall v. VectorSpace v => Scalar v -> v -> v
*^Needle y
δy
                         | Needle y
δy <- forall v. SimpleSpace v => Variance v -> [v]
varianceSpanningSystem Metric' y
yexpa, Scalar (Needle y)
σ <- [-Scalar (Needle y)
1,Scalar (Needle y)
1] ]
                      


coneTip :: (AdditiveGroup v, Num (Scalar (Needle v))) => Cℝay v
coneTip :: forall v. (AdditiveGroup v, Num (Scalar (Needle v))) => Cℝay v
coneTip = forall x. Scalar (Needle x) -> x -> Cℝay x
Cℝay Scalar (Needle v)
0 forall v. AdditiveGroup v => v
zeroV

mkCone :: (AdditiveGroup v, Real (Scalar (Needle v))) => Scalar (Needle v) -> v -> Cℝay v
mkCone :: forall v.
(AdditiveGroup v, Real (Scalar (Needle v))) =>
Scalar (Needle v) -> v -> Cℝay v
mkCone Scalar (Needle v)
0 v
_ = forall v. (AdditiveGroup v, Num (Scalar (Needle v))) => Cℝay v
coneTip
mkCone Scalar (Needle v)
h v
v = forall x. Scalar (Needle x) -> x -> Cℝay x
Cℝay Scalar (Needle v)
h v
v


foci :: [a] -> [(a,[a])]
foci :: forall a. [a] -> [(a, [a])]
foci [] = []
foci (a
x:[a]
xs) = (a
x,[a]
xs) forall a. a -> [a] -> [a]
: forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (forall (a :: * -> * -> *) d b c.
(Morphism a, ObjectPair a d b, ObjectPair a d c) =>
a b c -> a (d, b) (d, c)
second (a
xforall a. a -> [a] -> [a]
:)) (forall a. [a] -> [(a, [a])]
foci [a]
xs)
       
fociNE :: NonEmpty a -> NonEmpty (a,[a])
fociNE :: forall a. NonEmpty a -> NonEmpty (a, [a])
fociNE (a
x:|[a]
xs) = (a
x,[a]
xs) forall a. a -> [a] -> NonEmpty a
:| forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (forall (a :: * -> * -> *) d b c.
(Morphism a, ObjectPair a d b, ObjectPair a d c) =>
a b c -> a (d, b) (d, c)
second (a
xforall a. a -> [a] -> [a]
:)) (forall a. [a] -> [(a, [a])]
foci [a]
xs)
       

(.:) :: (c->d) -> (a->b->c) -> a->b->d 
.: :: forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
(.:) = forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
(.) forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
(.)




class HasFlatView f where
  type FlatView f x
  flatView :: f x -> FlatView f x
  superFlatView :: f x -> [[x]]
      
instance HasFlatView Sawbones where
  type FlatView Sawbones x = [([x],[[x]])]
  flatView :: forall x. Sawbones x -> FlatView Sawbones x
flatView (Sawbones [x] -> [x]
t1 [x] -> [x]
t2 [x]
d1 [x]
d2) = [([x] -> [x]
t1[],[[x]
d1]), ([x] -> [x]
t2[],[[x]
d2])]
  superFlatView :: forall x. Sawbones x -> [[x]]
superFlatView = forall (t :: * -> *) (k :: * -> * -> *) (l :: * -> * -> *) a m.
(Foldable t k l, Object k a, Object l (t a), Semigroup m, Monoid m,
 Object k m, Object l m) =>
k a m -> l (t a) m
foldMap forall {a}. (a, [a]) -> [a]
go forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall (f :: * -> *) x. HasFlatView f => f x -> FlatView f x
flatView
   where go :: (a, [a]) -> [a]
go (a
t,[a]
ds) = a
t forall a. a -> [a] -> [a]
: [a]
ds

instance HasFlatView Sawboneses where
  type FlatView Sawboneses x = [([x],[[x]])]
  flatView :: forall x. Sawboneses x -> FlatView Sawboneses x
flatView (SingleCut (Sawbones [x] -> [x]
t1 [x] -> [x]
t2 [x]
d1 [x]
d2)) = [([x] -> [x]
t1[],[[x]
d1]), ([x] -> [x]
t2[],[[x]
d2])]
  flatView (Sawboneses (DBranches NonEmpty (DBranch' x (DustyEdges x))
bs)) = 
        [ ([x] -> [x]
m[], forall a. NonEmpty a -> [a]
NE.toList NonEmpty (DBranch' x [x])
ds forall (f :: * -> * -> *) (m :: * -> *) a b.
(Function f, Monad m f, Object f a, Object f b, Object f (m a),
 Object f (m b), Object f (m (m b))) =>
m a -> f a (m b) -> m b
>>= \(DBranch Needle' x
_ (Hourglass [x]
u' [x]
l')) -> [[x]
u',[x]
l'])
        | (DBranch Needle' x
_ (Hourglass DustyEdges x
u DustyEdges x
l)) <- forall a. NonEmpty a -> [a]
NE.toList NonEmpty (DBranch' x (DustyEdges x))
bs
        , (DustyEdges [x] -> [x]
m (DBranches NonEmpty (DBranch' x [x])
ds)) <- [DustyEdges x
u,DustyEdges x
l]
        ]
  superFlatView :: forall x. Sawboneses x -> [[x]]
superFlatView = forall (t :: * -> *) (k :: * -> * -> *) (l :: * -> * -> *) a m.
(Foldable t k l, Object k a, Object l (t a), Semigroup m, Monoid m,
 Object k m, Object l m) =>
k a m -> l (t a) m
foldMap forall {a}. (a, [a]) -> [a]
go forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall (f :: * -> *) x. HasFlatView f => f x -> FlatView f x
flatView
   where go :: (a, [a]) -> [a]
go (a
t,[a]
ds) = a
t forall a. a -> [a] -> [a]
: [a]
ds