-- |
-- 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 Control.Monad.Trans.List
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 { Wall x -> (Depth, (Depth, Depth))
_wallID :: (Depth,(Int,Int))
                   , Wall x -> x
_wallAnchor :: x
                   , Wall x -> Needle' x
_wallNormal :: Needle' 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' :: x -> NonEmpty (Needle' x) -> x -> (Depth, HourglassBulb)
subshadeId' x
c NonEmpty (Needle' x)
expvs x
x = case ( DualSpaceWitness (Needle x)
forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualNeedleWitness x
                             , x
x x -> x -> Maybe (Needle x)
forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~. x
c ) of
    (DualSpaceWitness (Needle x)
DualSpaceWitness, Just v)
                    -> let (Depth
iu,ℝ
vl) = ((Depth, ℝ) -> (Depth, ℝ) -> Ordering)
-> [(Depth, ℝ)] -> (Depth, ℝ)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (((Depth, ℝ) -> ℝ) -> (Depth, ℝ) -> (Depth, ℝ) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (((Depth, ℝ) -> ℝ) -> (Depth, ℝ) -> (Depth, ℝ) -> Ordering)
-> ((Depth, ℝ) -> ℝ) -> (Depth, ℝ) -> (Depth, ℝ) -> Ordering
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ ℝ -> ℝ
forall a. Num a => a -> a
abs (ℝ -> ℝ) -> ((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
. (Depth, ℝ) -> ℝ
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd)
                                      ([(Depth, ℝ)] -> (Depth, ℝ)) -> [(Depth, ℝ)] -> (Depth, ℝ)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ [Depth] -> [ℝ] -> [(Depth, ℝ)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Depth
0..] ((Needle' x -> ℝ) -> [Needle' x] -> [ℝ]
forall a b. (a -> b) -> [a] -> [b]
map (DualVector (Needle' x)
Needle x
v DualVector (Needle' x) -> Needle' x -> Scalar (Needle' x)
forall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^) ([Needle' x] -> [ℝ]) -> [Needle' x] -> [ℝ]
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ NonEmpty (Needle' x) -> [Needle' x]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Needle' x)
expvs)
                       in (Depth
iu, if ℝ
vlℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
>ℝ
0 then HourglassBulb
UpperBulb else HourglassBulb
LowerBulb)
    (DualSpaceWitness (Needle x), Maybe (Needle x))
_ -> (-Depth
1, [Char] -> HourglassBulb
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 :: Shade x -> x -> (Depth, HourglassBulb)
subshadeId (Shade x
c Metric' x
expa) = x
-> NonEmpty (DualVector (Needle x)) -> x -> (Depth, HourglassBulb)
forall x.
(WithField ℝ PseudoAffine x, LinearSpace (Needle x)) =>
x -> NonEmpty (Needle' x) -> x -> (Depth, HourglassBulb)
subshadeId' x
c
                              (NonEmpty (DualVector (Needle x)) -> x -> (Depth, HourglassBulb))
-> ([DualVector (Needle x)] -> NonEmpty (DualVector (Needle x)))
-> [DualVector (Needle x)]
-> x
-> (Depth, HourglassBulb)
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
. [DualVector (Needle x)] -> NonEmpty (DualVector (Needle x))
forall a. [a] -> NonEmpty a
NE.fromList ([DualVector (Needle x)] -> x -> (Depth, HourglassBulb))
-> [DualVector (Needle x)] -> x -> (Depth, HourglassBulb)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Metric' x -> [DualVector (Needle x)]
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 { Hourglass s -> s
upperBulb, Hourglass s -> s
lowerBulb :: !s }
            deriving ((forall x. Hourglass s -> Rep (Hourglass s) x)
-> (forall x. Rep (Hourglass s) x -> Hourglass s)
-> Generic (Hourglass s)
forall x. Rep (Hourglass s) x -> Hourglass s
forall x. Hourglass s -> Rep (Hourglass s) x
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, a -> Hourglass b -> Hourglass a
(a -> b) -> Hourglass a -> Hourglass b
(forall a b. (a -> b) -> Hourglass a -> Hourglass b)
-> (forall a b. a -> Hourglass b -> Hourglass a)
-> Functor Hourglass
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
<$ :: a -> Hourglass b -> Hourglass a
$c<$ :: forall a b. a -> Hourglass b -> Hourglass a
fmap :: (a -> b) -> Hourglass a -> Hourglass b
$cfmap :: forall a b. (a -> b) -> Hourglass a -> Hourglass b
Hask.Functor, Hourglass a -> Bool
(a -> m) -> Hourglass a -> m
(a -> b -> b) -> b -> Hourglass a -> b
(forall m. Monoid m => Hourglass m -> m)
-> (forall m a. Monoid m => (a -> m) -> Hourglass a -> m)
-> (forall m a. Monoid m => (a -> m) -> Hourglass a -> m)
-> (forall a b. (a -> b -> b) -> b -> Hourglass a -> b)
-> (forall a b. (a -> b -> b) -> b -> Hourglass a -> b)
-> (forall b a. (b -> a -> b) -> b -> Hourglass a -> b)
-> (forall b a. (b -> a -> b) -> b -> Hourglass a -> b)
-> (forall a. (a -> a -> a) -> Hourglass a -> a)
-> (forall a. (a -> a -> a) -> Hourglass a -> a)
-> (forall a. Hourglass a -> [a])
-> (forall a. Hourglass a -> Bool)
-> (forall a. Hourglass a -> Depth)
-> (forall a. Eq a => a -> Hourglass a -> Bool)
-> (forall a. Ord a => Hourglass a -> a)
-> (forall a. Ord a => Hourglass a -> a)
-> (forall a. Num a => Hourglass a -> a)
-> (forall a. Num a => Hourglass a -> a)
-> Foldable Hourglass
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 :: Hourglass a -> a
$cproduct :: forall a. Num a => Hourglass a -> a
sum :: Hourglass a -> a
$csum :: forall a. Num a => Hourglass a -> a
minimum :: Hourglass a -> a
$cminimum :: forall a. Ord a => Hourglass a -> a
maximum :: Hourglass a -> a
$cmaximum :: forall a. Ord a => Hourglass a -> a
elem :: a -> Hourglass a -> Bool
$celem :: forall a. Eq a => a -> Hourglass a -> Bool
length :: Hourglass a -> Depth
$clength :: forall a. Hourglass a -> Depth
null :: Hourglass a -> Bool
$cnull :: forall a. Hourglass a -> Bool
toList :: Hourglass a -> [a]
$ctoList :: forall a. Hourglass a -> [a]
foldl1 :: (a -> a -> a) -> Hourglass a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Hourglass a -> a
foldr1 :: (a -> a -> a) -> Hourglass a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Hourglass a -> a
foldl' :: (b -> a -> b) -> b -> Hourglass a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Hourglass a -> b
foldl :: (b -> a -> b) -> b -> Hourglass a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Hourglass a -> b
foldr' :: (a -> b -> b) -> b -> Hourglass a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Hourglass a -> b
foldr :: (a -> b -> b) -> b -> Hourglass a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Hourglass a -> b
foldMap' :: (a -> m) -> Hourglass a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Hourglass a -> m
foldMap :: (a -> m) -> Hourglass a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Hourglass a -> m
fold :: Hourglass m -> m
$cfold :: forall m. Monoid m => Hourglass m -> m
Hask.Foldable, Functor Hourglass
Foldable Hourglass
Functor Hourglass
-> Foldable Hourglass
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> Hourglass a -> f (Hourglass b))
-> (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 (m :: * -> *) a.
    Monad m =>
    Hourglass (m a) -> m (Hourglass a))
-> Traversable Hourglass
(a -> f b) -> Hourglass a -> f (Hourglass 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 (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 :: Hourglass (m a) -> m (Hourglass a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
Hourglass (m a) -> m (Hourglass a)
mapM :: (a -> m b) -> Hourglass a -> m (Hourglass b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Hourglass a -> m (Hourglass b)
sequenceA :: Hourglass (f a) -> f (Hourglass a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Hourglass (f a) -> f (Hourglass a)
traverse :: (a -> f b) -> Hourglass a -> f (Hourglass b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Hourglass a -> f (Hourglass b)
$cp2Traversable :: Foldable Hourglass
$cp1Traversable :: Functor Hourglass
Hask.Traversable, Depth -> Hourglass s -> ShowS
[Hourglass s] -> ShowS
Hourglass s -> [Char]
(Depth -> Hourglass s -> ShowS)
-> (Hourglass s -> [Char])
-> ([Hourglass s] -> ShowS)
-> Show (Hourglass s)
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' = s -> s -> Hourglass s
forall s. s -> s -> Hourglass s
Hourglass (s
us -> s -> s
forall a. Semigroup a => a -> a -> a
<>s
u') (s
ls -> s -> s
forall 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) = NonEmpty (s, s) -> (NonEmpty s, NonEmpty s)
forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
NE.unzip (NonEmpty (s, s) -> (NonEmpty s, NonEmpty s))
-> NonEmpty (s, s) -> (NonEmpty s, NonEmpty s)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (Hourglass s -> s
forall s. Hourglass s -> s
upperBulb(Hourglass s -> s) -> (Hourglass s -> s) -> Hourglass s -> (s, s)
forall (a :: * -> * -> *) b c c'.
(PreArrow a, Object a b, ObjectPair a c c') =>
a b c -> a b c' -> a b (c, c')
&&&Hourglass s -> s
forall s. Hourglass s -> s
lowerBulb) (Hourglass s -> (s, s))
-> NonEmpty (Hourglass s) -> NonEmpty (s, s)
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 s -> s -> Hourglass s
forall s. s -> s -> Hourglass s
Hourglass (NonEmpty s -> s
forall a. Semigroup a => NonEmpty a -> a
sconcat NonEmpty s
us) (NonEmpty s -> s
forall a. Semigroup a => NonEmpty a -> a
sconcat NonEmpty s
ls)
instance (Monoid s, Semigroup s) => Monoid (Hourglass s) where
  mempty :: Hourglass s
mempty = s -> s -> Hourglass s
forall s. s -> s -> Hourglass s
Hourglass s
forall a. Monoid a => a
mempty s
forall a. Monoid a => a
mempty; mappend :: Hourglass s -> Hourglass s -> Hourglass s
mappend = Hourglass s -> Hourglass s -> Hourglass s
forall a. Semigroup a => a -> a -> a
(<>)
  mconcat :: [Hourglass s] -> Hourglass s
mconcat [Hourglass s]
hgs = let ([s]
us,[s]
ls) = [(s, s)] -> ([s], [s])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(s, s)] -> ([s], [s])) -> [(s, s)] -> ([s], [s])
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (Hourglass s -> s
forall s. Hourglass s -> s
upperBulb(Hourglass s -> s) -> (Hourglass s -> s) -> Hourglass s -> (s, s)
forall (a :: * -> * -> *) b c c'.
(PreArrow a, Object a b, ObjectPair a c c') =>
a b c -> a b c' -> a b (c, c')
&&&Hourglass s -> s
forall s. Hourglass s -> s
lowerBulb) (Hourglass s -> (s, s)) -> [Hourglass s] -> [(s, s)]
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 s -> s -> Hourglass s
forall s. s -> s -> Hourglass s
Hourglass ([s] -> s
forall a. Monoid a => [a] -> a
mconcat [s]
us) ([s] -> s
forall a. Monoid a => [a] -> a
mconcat [s]
ls)
instance Hask.Applicative Hourglass where
  pure :: a -> Hourglass a
pure a
x = a -> a -> Hourglass a
forall s. s -> s -> Hourglass s
Hourglass a
x a
x
  Hourglass a -> b
f a -> b
g <*> :: Hourglass (a -> b) -> Hourglass a -> Hourglass b
<*> Hourglass a
x a
y = b -> b -> Hourglass b
forall s. s -> s -> Hourglass s
Hourglass (a -> b
f a
x) (a -> b
g a
y)
instance Foldable Hourglass (->) (->) where
  ffoldl :: ((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 :: (a -> m) -> Hourglass a -> m
foldMap a -> m
f (Hourglass a
a a
b) = a -> m
f a
a m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` a -> m
f a
b

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

data HourglassBulb = UpperBulb | LowerBulb
oneBulb :: HourglassBulb -> (a->a) -> Hourglass a->Hourglass a
oneBulb :: HourglassBulb -> (a -> a) -> Hourglass a -> Hourglass a
oneBulb HourglassBulb
UpperBulb a -> a
f (Hourglass a
u a
l) = a -> a -> Hourglass a
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) = a -> a -> Hourglass a
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 x. Shaded x y -> Rep (Shaded x y) x)
-> (forall x. Rep (Shaded x y) x -> Shaded x y)
-> Generic (Shaded x y)
forall x. Rep (Shaded x y) x -> Shaded x y
forall x. Shaded x y -> Rep (Shaded x y) x
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, a -> Shaded x b -> Shaded x a
(a -> b) -> Shaded x a -> Shaded x b
(forall a b. (a -> b) -> Shaded x a -> Shaded x b)
-> (forall a b. a -> Shaded x b -> Shaded x a)
-> Functor (Shaded x)
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
<$ :: a -> Shaded x b -> Shaded x a
$c<$ :: forall x a b. a -> Shaded x b -> Shaded x a
fmap :: (a -> b) -> Shaded x a -> Shaded x b
$cfmap :: forall x a b. (a -> b) -> Shaded x a -> Shaded x b
Hask.Functor, Shaded x a -> Bool
(a -> m) -> Shaded x a -> m
(a -> b -> b) -> b -> Shaded x a -> b
(forall m. Monoid m => Shaded x m -> m)
-> (forall m a. Monoid m => (a -> m) -> Shaded x a -> m)
-> (forall m a. Monoid m => (a -> m) -> Shaded x a -> m)
-> (forall a b. (a -> b -> b) -> b -> Shaded x a -> b)
-> (forall a b. (a -> b -> b) -> b -> Shaded x a -> b)
-> (forall b a. (b -> a -> b) -> b -> Shaded x a -> b)
-> (forall b a. (b -> a -> b) -> b -> Shaded x a -> b)
-> (forall a. (a -> a -> a) -> Shaded x a -> a)
-> (forall a. (a -> a -> a) -> Shaded x a -> a)
-> (forall a. Shaded x a -> [a])
-> (forall a. Shaded x a -> Bool)
-> (forall a. Shaded x a -> Depth)
-> (forall a. Eq a => a -> Shaded x a -> Bool)
-> (forall a. Ord a => Shaded x a -> a)
-> (forall a. Ord a => Shaded x a -> a)
-> (forall a. Num a => Shaded x a -> a)
-> (forall a. Num a => Shaded x a -> a)
-> Foldable (Shaded x)
forall a. Eq a => a -> Shaded x a -> Bool
forall a. Num a => Shaded x a -> a
forall a. Ord a => Shaded x a -> a
forall m. Monoid m => Shaded x m -> m
forall a. Shaded x a -> Bool
forall a. Shaded x a -> Depth
forall a. Shaded x a -> [a]
forall a. (a -> a -> a) -> Shaded x a -> a
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 b a. (b -> a -> b) -> b -> Shaded x a -> b
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 :: Shaded x a -> a
$cproduct :: forall x a. Num a => Shaded x a -> a
sum :: Shaded x a -> a
$csum :: forall x a. Num a => Shaded x a -> a
minimum :: Shaded x a -> a
$cminimum :: forall x a. Ord a => Shaded x a -> a
maximum :: Shaded x a -> a
$cmaximum :: forall x a. Ord a => Shaded x a -> a
elem :: a -> Shaded x a -> Bool
$celem :: forall x a. Eq a => a -> Shaded x a -> Bool
length :: Shaded x a -> Depth
$clength :: forall x a. Shaded x a -> Depth
null :: Shaded x a -> Bool
$cnull :: forall x a. Shaded x a -> Bool
toList :: Shaded x a -> [a]
$ctoList :: forall x a. Shaded x a -> [a]
foldl1 :: (a -> a -> a) -> Shaded x a -> a
$cfoldl1 :: forall x a. (a -> a -> a) -> Shaded x a -> a
foldr1 :: (a -> a -> a) -> Shaded x a -> a
$cfoldr1 :: forall x a. (a -> a -> a) -> Shaded x a -> a
foldl' :: (b -> a -> b) -> b -> Shaded x a -> b
$cfoldl' :: forall x b a. (b -> a -> b) -> b -> Shaded x a -> b
foldl :: (b -> a -> b) -> b -> Shaded x a -> b
$cfoldl :: forall x b a. (b -> a -> b) -> b -> Shaded x a -> b
foldr' :: (a -> b -> b) -> b -> Shaded x a -> b
$cfoldr' :: forall x a b. (a -> b -> b) -> b -> Shaded x a -> b
foldr :: (a -> b -> b) -> b -> Shaded x a -> b
$cfoldr :: forall x a b. (a -> b -> b) -> b -> Shaded x a -> b
foldMap' :: (a -> m) -> Shaded x a -> m
$cfoldMap' :: forall x m a. Monoid m => (a -> m) -> Shaded x a -> m
foldMap :: (a -> m) -> Shaded x a -> m
$cfoldMap :: forall x m a. Monoid m => (a -> m) -> Shaded x a -> m
fold :: Shaded x m -> m
$cfold :: forall x m. Monoid m => Shaded x m -> m
Hask.Foldable, Functor (Shaded x)
Foldable (Shaded x)
Functor (Shaded x)
-> Foldable (Shaded x)
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> Shaded x a -> f (Shaded x b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Shaded x (f a) -> f (Shaded x a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Shaded x a -> m (Shaded x b))
-> (forall (m :: * -> *) a.
    Monad m =>
    Shaded x (m a) -> m (Shaded x a))
-> Traversable (Shaded x)
(a -> f b) -> Shaded x a -> f (Shaded x b)
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 (m :: * -> *) a. Monad m => Shaded x (m a) -> m (Shaded x a)
forall (f :: * -> *) a.
Applicative f =>
Shaded x (f a) -> f (Shaded x a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Shaded x a -> m (Shaded x b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Shaded x a -> f (Shaded x b)
sequence :: Shaded x (m a) -> m (Shaded x a)
$csequence :: forall x (m :: * -> *) a.
Monad m =>
Shaded x (m a) -> m (Shaded x a)
mapM :: (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 :: Shaded x (f a) -> f (Shaded x a)
$csequenceA :: forall x (f :: * -> *) a.
Applicative f =>
Shaded x (f a) -> f (Shaded x a)
traverse :: (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)
$cp2Traversable :: forall x. Foldable (Shaded x)
$cp1Traversable :: forall x. Functor (Shaded x)
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 { DBranch' x c -> Needle' x
boughDirection :: !(Needle' x)
                            , DBranch' x c -> Hourglass c
boughContents :: !(Hourglass c) }
  deriving ((forall x. DBranch' x c -> Rep (DBranch' x c) x)
-> (forall x. Rep (DBranch' x c) x -> DBranch' x c)
-> Generic (DBranch' x c)
forall x. Rep (DBranch' x c) x -> DBranch' x c
forall x. DBranch' x c -> Rep (DBranch' x c) x
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, a -> DBranch' x b -> DBranch' x a
(a -> b) -> DBranch' x a -> DBranch' x b
(forall a b. (a -> b) -> DBranch' x a -> DBranch' x b)
-> (forall a b. a -> DBranch' x b -> DBranch' x a)
-> Functor (DBranch' x)
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
<$ :: a -> DBranch' x b -> DBranch' x a
$c<$ :: forall x a b. a -> DBranch' x b -> DBranch' x a
fmap :: (a -> b) -> DBranch' x a -> DBranch' x b
$cfmap :: forall x a b. (a -> b) -> DBranch' x a -> DBranch' x b
Hask.Functor, DBranch' x a -> Bool
(a -> m) -> DBranch' x a -> m
(a -> b -> b) -> b -> DBranch' x a -> b
(forall m. Monoid m => DBranch' x m -> m)
-> (forall m a. Monoid m => (a -> m) -> DBranch' x a -> m)
-> (forall m a. Monoid m => (a -> m) -> DBranch' x a -> m)
-> (forall a b. (a -> b -> b) -> b -> DBranch' x a -> b)
-> (forall a b. (a -> b -> b) -> b -> DBranch' x a -> b)
-> (forall b a. (b -> a -> b) -> b -> DBranch' x a -> b)
-> (forall b a. (b -> a -> b) -> b -> DBranch' x a -> b)
-> (forall a. (a -> a -> a) -> DBranch' x a -> a)
-> (forall a. (a -> a -> a) -> DBranch' x a -> a)
-> (forall a. DBranch' x a -> [a])
-> (forall a. DBranch' x a -> Bool)
-> (forall a. DBranch' x a -> Depth)
-> (forall a. Eq a => a -> DBranch' x a -> Bool)
-> (forall a. Ord a => DBranch' x a -> a)
-> (forall a. Ord a => DBranch' x a -> a)
-> (forall a. Num a => DBranch' x a -> a)
-> (forall a. Num a => DBranch' x a -> a)
-> Foldable (DBranch' x)
forall a. Eq a => a -> DBranch' x a -> Bool
forall a. Num a => DBranch' x a -> a
forall a. Ord a => DBranch' x a -> a
forall m. Monoid m => DBranch' x m -> m
forall a. DBranch' x a -> Bool
forall a. DBranch' x a -> Depth
forall a. DBranch' x a -> [a]
forall a. (a -> a -> a) -> DBranch' x a -> a
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 b a. (b -> a -> b) -> b -> DBranch' x a -> b
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 :: DBranch' x a -> a
$cproduct :: forall x a. Num a => DBranch' x a -> a
sum :: DBranch' x a -> a
$csum :: forall x a. Num a => DBranch' x a -> a
minimum :: DBranch' x a -> a
$cminimum :: forall x a. Ord a => DBranch' x a -> a
maximum :: DBranch' x a -> a
$cmaximum :: forall x a. Ord a => DBranch' x a -> a
elem :: a -> DBranch' x a -> Bool
$celem :: forall x a. Eq a => a -> DBranch' x a -> Bool
length :: DBranch' x a -> Depth
$clength :: forall x a. DBranch' x a -> Depth
null :: DBranch' x a -> Bool
$cnull :: forall x a. DBranch' x a -> Bool
toList :: DBranch' x a -> [a]
$ctoList :: forall x a. DBranch' x a -> [a]
foldl1 :: (a -> a -> a) -> DBranch' x a -> a
$cfoldl1 :: forall x a. (a -> a -> a) -> DBranch' x a -> a
foldr1 :: (a -> a -> a) -> DBranch' x a -> a
$cfoldr1 :: forall x a. (a -> a -> a) -> DBranch' x a -> a
foldl' :: (b -> a -> b) -> b -> DBranch' x a -> b
$cfoldl' :: forall x b a. (b -> a -> b) -> b -> DBranch' x a -> b
foldl :: (b -> a -> b) -> b -> DBranch' x a -> b
$cfoldl :: forall x b a. (b -> a -> b) -> b -> DBranch' x a -> b
foldr' :: (a -> b -> b) -> b -> DBranch' x a -> b
$cfoldr' :: forall x a b. (a -> b -> b) -> b -> DBranch' x a -> b
foldr :: (a -> b -> b) -> b -> DBranch' x a -> b
$cfoldr :: forall x a b. (a -> b -> b) -> b -> DBranch' x a -> b
foldMap' :: (a -> m) -> DBranch' x a -> m
$cfoldMap' :: forall x m a. Monoid m => (a -> m) -> DBranch' x a -> m
foldMap :: (a -> m) -> DBranch' x a -> m
$cfoldMap :: forall x m a. Monoid m => (a -> m) -> DBranch' x a -> m
fold :: DBranch' x m -> m
$cfold :: forall x m. Monoid m => DBranch' x m -> m
Hask.Foldable, Functor (DBranch' x)
Foldable (DBranch' x)
Functor (DBranch' x)
-> Foldable (DBranch' x)
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> DBranch' x a -> f (DBranch' x b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    DBranch' x (f a) -> f (DBranch' x a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> DBranch' x a -> m (DBranch' x b))
-> (forall (m :: * -> *) a.
    Monad m =>
    DBranch' x (m a) -> m (DBranch' x a))
-> Traversable (DBranch' x)
(a -> f b) -> DBranch' x a -> f (DBranch' x b)
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 (m :: * -> *) a.
Monad m =>
DBranch' x (m a) -> m (DBranch' x a)
forall (f :: * -> *) a.
Applicative f =>
DBranch' x (f a) -> f (DBranch' x a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> DBranch' x a -> m (DBranch' x b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> DBranch' x a -> f (DBranch' x b)
sequence :: DBranch' x (m a) -> m (DBranch' x a)
$csequence :: forall x (m :: * -> *) a.
Monad m =>
DBranch' x (m a) -> m (DBranch' x a)
mapM :: (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 :: DBranch' x (f a) -> f (DBranch' x a)
$csequenceA :: forall x (f :: * -> *) a.
Applicative f =>
DBranch' x (f a) -> f (DBranch' x a)
traverse :: (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)
$cp2Traversable :: forall x. Foldable (DBranch' x)
$cp1Traversable :: forall x. Functor (DBranch' x)
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 x. DBranches' x c -> Rep (DBranches' x c) x)
-> (forall x. Rep (DBranches' x c) x -> DBranches' x c)
-> Generic (DBranches' x c)
forall x. Rep (DBranches' x c) x -> DBranches' x c
forall x. DBranches' x c -> Rep (DBranches' x c) x
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, a -> DBranches' x b -> DBranches' x a
(a -> b) -> DBranches' x a -> DBranches' x b
(forall a b. (a -> b) -> DBranches' x a -> DBranches' x b)
-> (forall a b. a -> DBranches' x b -> DBranches' x a)
-> Functor (DBranches' x)
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
<$ :: a -> DBranches' x b -> DBranches' x a
$c<$ :: forall x a b. a -> DBranches' x b -> DBranches' x a
fmap :: (a -> b) -> DBranches' x a -> DBranches' x b
$cfmap :: forall x a b. (a -> b) -> DBranches' x a -> DBranches' x b
Hask.Functor, DBranches' x a -> Bool
(a -> m) -> DBranches' x a -> m
(a -> b -> b) -> b -> DBranches' x a -> b
(forall m. Monoid m => DBranches' x m -> m)
-> (forall m a. Monoid m => (a -> m) -> DBranches' x a -> m)
-> (forall m a. Monoid m => (a -> m) -> DBranches' x a -> m)
-> (forall a b. (a -> b -> b) -> b -> DBranches' x a -> b)
-> (forall a b. (a -> b -> b) -> b -> DBranches' x a -> b)
-> (forall b a. (b -> a -> b) -> b -> DBranches' x a -> b)
-> (forall b a. (b -> a -> b) -> b -> DBranches' x a -> b)
-> (forall a. (a -> a -> a) -> DBranches' x a -> a)
-> (forall a. (a -> a -> a) -> DBranches' x a -> a)
-> (forall a. DBranches' x a -> [a])
-> (forall a. DBranches' x a -> Bool)
-> (forall a. DBranches' x a -> Depth)
-> (forall a. Eq a => a -> DBranches' x a -> Bool)
-> (forall a. Ord a => DBranches' x a -> a)
-> (forall a. Ord a => DBranches' x a -> a)
-> (forall a. Num a => DBranches' x a -> a)
-> (forall a. Num a => DBranches' x a -> a)
-> Foldable (DBranches' x)
forall a. Eq a => a -> DBranches' x a -> Bool
forall a. Num a => DBranches' x a -> a
forall a. Ord a => DBranches' x a -> a
forall m. Monoid m => DBranches' x m -> m
forall a. DBranches' x a -> Bool
forall a. DBranches' x a -> Depth
forall a. DBranches' x a -> [a]
forall a. (a -> a -> a) -> DBranches' x a -> a
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 b a. (b -> a -> b) -> b -> DBranches' x a -> b
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 :: DBranches' x a -> a
$cproduct :: forall x a. Num a => DBranches' x a -> a
sum :: DBranches' x a -> a
$csum :: forall x a. Num a => DBranches' x a -> a
minimum :: DBranches' x a -> a
$cminimum :: forall x a. Ord a => DBranches' x a -> a
maximum :: DBranches' x a -> a
$cmaximum :: forall x a. Ord a => DBranches' x a -> a
elem :: a -> DBranches' x a -> Bool
$celem :: forall x a. Eq a => a -> DBranches' x a -> Bool
length :: DBranches' x a -> Depth
$clength :: forall x a. DBranches' x a -> Depth
null :: DBranches' x a -> Bool
$cnull :: forall x a. DBranches' x a -> Bool
toList :: DBranches' x a -> [a]
$ctoList :: forall x a. DBranches' x a -> [a]
foldl1 :: (a -> a -> a) -> DBranches' x a -> a
$cfoldl1 :: forall x a. (a -> a -> a) -> DBranches' x a -> a
foldr1 :: (a -> a -> a) -> DBranches' x a -> a
$cfoldr1 :: forall x a. (a -> a -> a) -> DBranches' x a -> a
foldl' :: (b -> a -> b) -> b -> DBranches' x a -> b
$cfoldl' :: forall x b a. (b -> a -> b) -> b -> DBranches' x a -> b
foldl :: (b -> a -> b) -> b -> DBranches' x a -> b
$cfoldl :: forall x b a. (b -> a -> b) -> b -> DBranches' x a -> b
foldr' :: (a -> b -> b) -> b -> DBranches' x a -> b
$cfoldr' :: forall x a b. (a -> b -> b) -> b -> DBranches' x a -> b
foldr :: (a -> b -> b) -> b -> DBranches' x a -> b
$cfoldr :: forall x a b. (a -> b -> b) -> b -> DBranches' x a -> b
foldMap' :: (a -> m) -> DBranches' x a -> m
$cfoldMap' :: forall x m a. Monoid m => (a -> m) -> DBranches' x a -> m
foldMap :: (a -> m) -> DBranches' x a -> m
$cfoldMap :: forall x m a. Monoid m => (a -> m) -> DBranches' x a -> m
fold :: DBranches' x m -> m
$cfold :: forall x m. Monoid m => DBranches' x m -> m
Hask.Foldable, Functor (DBranches' x)
Foldable (DBranches' x)
Functor (DBranches' x)
-> Foldable (DBranches' x)
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> DBranches' x a -> f (DBranches' x b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    DBranches' x (f a) -> f (DBranches' x a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> DBranches' x a -> m (DBranches' x b))
-> (forall (m :: * -> *) a.
    Monad m =>
    DBranches' x (m a) -> m (DBranches' x a))
-> Traversable (DBranches' x)
(a -> f b) -> DBranches' x a -> f (DBranches' x b)
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 (m :: * -> *) a.
Monad m =>
DBranches' x (m a) -> m (DBranches' x a)
forall (f :: * -> *) a.
Applicative f =>
DBranches' x (f a) -> f (DBranches' x a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> DBranches' x a -> m (DBranches' x b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> DBranches' x a -> f (DBranches' x b)
sequence :: DBranches' x (m a) -> m (DBranches' x a)
$csequence :: forall x (m :: * -> *) a.
Monad m =>
DBranches' x (m a) -> m (DBranches' x a)
mapM :: (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 :: DBranches' x (f a) -> f (DBranches' x a)
$csequenceA :: forall x (f :: * -> *) a.
Applicative f =>
DBranches' x (f a) -> f (DBranches' x a)
traverse :: (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)
$cp2Traversable :: forall x. Foldable (DBranches' x)
$cp1Traversable :: forall x. Functor (DBranches' x)
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 = NonEmpty (DBranch' x c) -> DBranches' x c
forall x c. NonEmpty (DBranch' x c) -> DBranches' x c
DBranches (NonEmpty (DBranch' x c) -> DBranches' x c)
-> NonEmpty (DBranch' x c) -> DBranches' x c
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (DBranch' x c -> DBranch' x c -> DBranch' x c)
-> NonEmpty (DBranch' x c)
-> NonEmpty (DBranch' x c)
-> NonEmpty (DBranch' x c)
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)
                                                              -> Needle' x -> Hourglass c -> DBranch' x c
forall x c. Needle' x -> Hourglass c -> DBranch' x c
DBranch Needle' x
d1 (Hourglass c -> DBranch' x c) -> Hourglass c -> DBranch' x c
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Hourglass c
c1Hourglass c -> Hourglass c -> Hourglass c
forall 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 :: Shaded x y -> NonEmpty (Depth, Shaded x y)
trunkBranches (OverlappingBranches Depth
_ Shade x
_ NonEmpty (DBranch x y)
brs)
        = (State Depth (NonEmpty (Depth, Shaded x y))
-> Depth -> NonEmpty (Depth, Shaded x y)
forall s a. State s a -> s -> a
`evalState`Depth
0)
            (State Depth (NonEmpty (Depth, Shaded x y))
 -> NonEmpty (Depth, Shaded x y))
-> ((Shaded x y -> StateT Depth Identity (Depth, Shaded x y))
    -> State Depth (NonEmpty (Depth, Shaded x y)))
-> (Shaded x y -> StateT Depth Identity (Depth, Shaded x y))
-> NonEmpty (Depth, 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
. NonEmpty (Shaded x y)
-> (Shaded x y -> StateT Depth Identity (Depth, Shaded x y))
-> State Depth (NonEmpty (Depth, Shaded x y))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (NonEmpty (DBranch x y)
brs NonEmpty (DBranch x y)
-> (DBranch x y -> NonEmpty (Shaded x y)) -> NonEmpty (Shaded x y)
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
tShaded x y -> [Shaded x y] -> NonEmpty (Shaded x y)
forall a. a -> [a] -> NonEmpty a
:|[Shaded x y
b]) ((Shaded x y -> StateT Depth Identity (Depth, Shaded x y))
 -> NonEmpty (Depth, Shaded x y))
-> (Shaded x y -> StateT Depth Identity (Depth, Shaded x y))
-> NonEmpty (Depth, Shaded x y)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \Shaded x y
st -> do
               Depth
i₀ <- StateT Depth Identity Depth
forall (m :: * -> *) s. Monad m => StateT s m s
get
               Depth -> StateT Depth Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Depth -> StateT Depth Identity ())
-> Depth -> StateT Depth Identity ()
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Depth
i₀ Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+ Shaded x y -> Depth
forall x a. Shaded x a -> Depth
nLeaves Shaded x y
st
               (Depth, Shaded x y) -> StateT Depth Identity (Depth, Shaded x y)
forall (m :: * -> *) a. Monad m (->) => a -> m a
return (Depth
i₀, Shaded x y
st)
trunkBranches (DisjointBranches Depth
_ NonEmpty (Shaded x y)
brs) = (State Depth (NonEmpty (Depth, Shaded x y))
-> Depth -> NonEmpty (Depth, Shaded x y)
forall s a. State s a -> s -> a
`evalState`Depth
0) (State Depth (NonEmpty (Depth, Shaded x y))
 -> NonEmpty (Depth, Shaded x y))
-> ((Shaded x y -> StateT Depth Identity (Depth, Shaded x y))
    -> State Depth (NonEmpty (Depth, Shaded x y)))
-> (Shaded x y -> StateT Depth Identity (Depth, Shaded x y))
-> NonEmpty (Depth, 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
. NonEmpty (Shaded x y)
-> (Shaded x y -> StateT Depth Identity (Depth, Shaded x y))
-> State Depth (NonEmpty (Depth, Shaded x y))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty (Shaded x y)
brs ((Shaded x y -> StateT Depth Identity (Depth, Shaded x y))
 -> NonEmpty (Depth, Shaded x y))
-> (Shaded x y -> StateT Depth Identity (Depth, Shaded x y))
-> NonEmpty (Depth, Shaded x y)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \Shaded x y
st -> do
               Depth
i₀ <- StateT Depth Identity Depth
forall (m :: * -> *) s. Monad m => StateT s m s
get
               Depth -> StateT Depth Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Depth -> StateT Depth Identity ())
-> Depth -> StateT Depth Identity ()
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Depth
i₀ Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+ Shaded x y -> Depth
forall x a. Shaded x a -> Depth
nLeaves Shaded x y
st
               (Depth, Shaded x y) -> StateT Depth Identity (Depth, Shaded x y)
forall (m :: * -> *) a. Monad m (->) => a -> m a
return (Depth
i₀, Shaded x y
st)
trunkBranches Shaded x y
t = (Depth, Shaded x y) -> NonEmpty (Depth, Shaded x y)
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 :: WithField ℝ Manifold x
               => [DBranch x y]
                 -> [ ( (Needle' x, x`Shaded`y)
                      ,[(Needle' x, x`Shaded`y)] ) ]
directionChoices :: [DBranch x y]
-> [((Needle' x, Shaded x y), [(Needle' x, Shaded x y)])]
directionChoices = (((Depth, (Needle' x, Shaded x y)),
  [(Depth, (Needle' x, Shaded x y))])
 -> ((Needle' x, Shaded x y), [(Needle' x, Shaded x y)]))
-> [((Depth, (Needle' x, Shaded x y)),
     [(Depth, (Needle' x, Shaded x y))])]
-> [((Needle' x, Shaded x y), [(Needle' x, Shaded x y)])]
forall a b. (a -> b) -> [a] -> [b]
map ((Depth, (Needle' x, Shaded x y)) -> (Needle' x, Shaded x y)
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd ((Depth, (Needle' x, Shaded x y)) -> (Needle' x, Shaded x y))
-> ([(Depth, (Needle' x, Shaded x y))]
    -> [(Needle' x, Shaded x y)])
-> ((Depth, (Needle' x, Shaded x y)),
    [(Depth, (Needle' x, Shaded x y))])
-> ((Needle' x, Shaded x y), [(Needle' x, Shaded x y)])
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')
*** ((Depth, (Needle' x, Shaded x y)) -> (Needle' x, Shaded x y))
-> [(Depth, (Needle' x, Shaded x y))] -> [(Needle' x, Shaded x y)]
forall a b. (a -> b) -> [a] -> [b]
map (Depth, (Needle' x, Shaded x y)) -> (Needle' x, Shaded x y)
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd) ([((Depth, (Needle' x, Shaded x y)),
   [(Depth, (Needle' x, Shaded x y))])]
 -> [((Needle' x, Shaded x y), [(Needle' x, Shaded x y)])])
-> ([DBranch x y]
    -> [((Depth, (Needle' x, Shaded x y)),
         [(Depth, (Needle' x, Shaded x y))])])
-> [DBranch x y]
-> [((Needle' x, Shaded x y), [(Needle' x, 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
. Depth
-> [DBranch x y]
-> [((Depth, (Needle' x, Shaded x y)),
     [(Depth, (Needle' x, Shaded x y))])]
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 :: 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 (Depth, (Needle' x, Shaded x y))
-> [(Depth, (Needle' x, Shaded x y))]
-> [(Depth, (Needle' x, Shaded x y))]
forall a. a -> [a] -> [a]
: (((Depth, (Needle' x, Shaded x y)),
  [(Depth, (Needle' x, Shaded x y))])
 -> (Depth, (Needle' x, Shaded x y)))
-> [((Depth, (Needle' x, Shaded x y)),
     [(Depth, (Needle' x, Shaded x y))])]
-> [(Depth, (Needle' x, Shaded x y))]
forall a b. (a -> b) -> [a] -> [b]
map ((Depth, (Needle' x, Shaded x y)),
 [(Depth, (Needle' x, Shaded x y))])
-> (Depth, (Needle' x, Shaded x y))
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 )
          ((Depth, (Needle' x, Shaded x y)),
 [(Depth, (Needle' x, Shaded x y))])
-> [((Depth, (Needle' x, Shaded x y)),
     [(Depth, (Needle' x, Shaded x y))])]
-> [((Depth, (Needle' x, Shaded x y)),
     [(Depth, (Needle' x, Shaded x y))])]
forall a. a -> [a] -> [a]
: ( (Depth, (Needle' x, Shaded x y))
bot, (Depth, (Needle' x, Shaded x y))
top (Depth, (Needle' x, Shaded x y))
-> [(Depth, (Needle' x, Shaded x y))]
-> [(Depth, (Needle' x, Shaded x y))]
forall a. a -> [a] -> [a]
: (((Depth, (Needle' x, Shaded x y)),
  [(Depth, (Needle' x, Shaded x y))])
 -> (Depth, (Needle' x, Shaded x y)))
-> [((Depth, (Needle' x, Shaded x y)),
     [(Depth, (Needle' x, Shaded x y))])]
-> [(Depth, (Needle' x, Shaded x y))]
forall a b. (a -> b) -> [a] -> [b]
map ((Depth, (Needle' x, Shaded x y)),
 [(Depth, (Needle' x, Shaded x y))])
-> (Depth, (Needle' x, Shaded x y))
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 )
          ((Depth, (Needle' x, Shaded x y)),
 [(Depth, (Needle' x, Shaded x y))])
-> [((Depth, (Needle' x, Shaded x y)),
     [(Depth, (Needle' x, Shaded x y))])]
-> [((Depth, (Needle' x, Shaded x y)),
     [(Depth, (Needle' x, Shaded x y))])]
forall a. a -> [a] -> [a]
: (((Depth, (Needle' x, Shaded x y)),
  [(Depth, (Needle' x, Shaded x y))])
 -> ((Depth, (Needle' x, Shaded x y)),
     [(Depth, (Needle' x, Shaded x y))]))
-> [((Depth, (Needle' x, Shaded x y)),
     [(Depth, (Needle' x, Shaded x y))])]
-> [((Depth, (Needle' x, Shaded x y)),
     [(Depth, (Needle' x, Shaded x y))])]
forall a b. (a -> b) -> [a] -> [b]
map (([(Depth, (Needle' x, Shaded x y))]
 -> [(Depth, (Needle' x, Shaded x y))])
-> ((Depth, (Needle' x, Shaded x y)),
    [(Depth, (Needle' x, Shaded x y))])
-> ((Depth, (Needle' x, Shaded x y)),
    [(Depth, (Needle' x, Shaded x y))])
forall (a :: * -> * -> *) d b c.
(Morphism a, ObjectPair a d b, ObjectPair a d c) =>
a b c -> a (d, b) (d, c)
second (([(Depth, (Needle' x, Shaded x y))]
  -> [(Depth, (Needle' x, Shaded x y))])
 -> ((Depth, (Needle' x, Shaded x y)),
     [(Depth, (Needle' x, Shaded x y))])
 -> ((Depth, (Needle' x, Shaded x y)),
     [(Depth, (Needle' x, Shaded x y))]))
-> ([(Depth, (Needle' x, Shaded x y))]
    -> [(Depth, (Needle' x, Shaded x y))])
-> ((Depth, (Needle' x, Shaded x y)),
    [(Depth, (Needle' x, Shaded x y))])
-> ((Depth, (Needle' x, Shaded x y)),
    [(Depth, (Needle' x, Shaded x y))])
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ ((Depth, (Needle' x, Shaded x y))
top(Depth, (Needle' x, Shaded x y))
-> [(Depth, (Needle' x, Shaded x y))]
-> [(Depth, (Needle' x, Shaded x y))]
forall a. a -> [a] -> [a]
:) ([(Depth, (Needle' x, Shaded x y))]
 -> [(Depth, (Needle' x, Shaded x y))])
-> ([(Depth, (Needle' x, Shaded x y))]
    -> [(Depth, (Needle' x, Shaded x y))])
-> [(Depth, (Needle' x, Shaded x y))]
-> [(Depth, (Needle' x, 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
. ((Depth, (Needle' x, Shaded x y))
bot(Depth, (Needle' x, Shaded x y))
-> [(Depth, (Needle' x, Shaded x y))]
-> [(Depth, (Needle' x, Shaded x y))]
forall 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₀Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+Depth
1,(Needle' x -> Needle' x
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 = Depth
-> [DBranch x y]
-> [((Depth, (Needle' x, Shaded x y)),
     [(Depth, (Needle' x, Shaded x y))])]
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₀Depth -> Depth -> Depth
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 :: ((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 z]
td [] ([(Depth, (Needle' x, Shaded x y))] -> f [DBranch x z])
-> ([(Needle' x, Shaded x y)]
    -> [(Depth, (Needle' x, Shaded x y))])
-> [(Needle' x, Shaded x y)]
-> f [DBranch x z]
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)] -> [(Depth, (Needle' x, Shaded x y))]
forall a x y.
Depth -> [(a, Shaded x y)] -> [(Depth, (a, Shaded x y))]
scanLeafNums Depth
0
               ([(Needle' x, Shaded x y)] -> f [DBranch x z])
-> [(Needle' x, Shaded x y)] -> f [DBranch x z]
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ [DBranch x y]
dbs [DBranch x y]
-> (DBranch x y -> [(Needle' x, Shaded x y)])
-> [(Needle' x, Shaded x y)]
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
τ), (Needle' x -> Needle' x
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 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)
         = (Shaded x z -> Shaded x z -> [DBranch x z] -> [DBranch x z])
-> f (Shaded x z)
-> f (Shaded x z)
-> f [DBranch x z]
-> f [DBranch x z]
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' -> (Needle' x -> Hourglass (Shaded x z) -> DBranch x z
forall x c. Needle' x -> Hourglass c -> DBranch' x c
DBranch Needle' x
ѧ (Shaded x z -> Shaded x z -> Hourglass (Shaded x z)
forall s. s -> s -> Hourglass s
Hourglass Shaded x z
t' Shaded x z
b') DBranch x z -> [DBranch x z] -> [DBranch x z]
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 ([(Depth, (Needle' x, Shaded x y))] -> f (Shaded x z))
-> [(Depth, (Needle' x, Shaded x y))] -> f (Shaded x z)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (Depth, (Needle' x, Shaded x y))
vb(Depth, (Needle' x, Shaded x y))
-> [(Depth, (Needle' x, Shaded x y))]
-> [(Depth, (Needle' x, Shaded x y))]
forall 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 ([(Depth, (Needle' x, Shaded x y))] -> f (Shaded x z))
-> [(Depth, (Needle' x, Shaded x y))] -> f (Shaded x z)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (Depth, (Needle' x, Shaded x y))
ѧt(Depth, (Needle' x, Shaded x y))
-> [(Depth, (Needle' x, Shaded x y))]
-> [(Depth, (Needle' x, Shaded x y))]
forall a. a -> [a] -> [a]
:[(Depth, (Needle' x, Shaded x y))]
uds)
             (f [DBranch x z] -> f [DBranch x z])
-> f [DBranch x z] -> f [DBranch x z]
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 z]
td ((Depth, (Needle' x, Shaded x y))
ѧt(Depth, (Needle' x, Shaded x y))
-> [(Depth, (Needle' x, Shaded x y))]
-> [(Depth, (Needle' x, Shaded x y))]
forall a. a -> [a] -> [a]
:(Depth, (Needle' x, Shaded x y))
vb(Depth, (Needle' x, Shaded x y))
-> [(Depth, (Needle' x, Shaded x y))]
-> [(Depth, (Needle' x, Shaded x y))]
forall 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 [(Depth, (Needle' x, Shaded x y))]
-> [(Depth, (Needle' x, Shaded x y))]
-> [(Depth, (Needle' x, Shaded x y))]
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))]
_ = [DBranch x z] -> f [DBranch x z]
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)) (Depth, (a, Shaded x y))
-> [(Depth, (a, Shaded x y))] -> [(Depth, (a, Shaded x y))]
forall a. a -> [a] -> [a]
: Depth -> [(a, Shaded x y)] -> [(Depth, (a, Shaded x y))]
scanLeafNums (Depth
i₀ Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+ Shaded x y -> Depth
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 :: ((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 y)
bs)
        = Depth -> Shade x -> NonEmpty (DBranch x z) -> Shaded x z
forall x y.
Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
OverlappingBranches Depth
n Shade x
sh (NonEmpty (DBranch x z) -> Shaded x z)
-> ([DBranch x z] -> NonEmpty (DBranch x z))
-> [DBranch x z]
-> Shaded x z
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 z] -> NonEmpty (DBranch x z)
forall a. [a] -> NonEmpty a
NE.fromList ([DBranch x z] -> Shaded x z) -> f [DBranch x z] -> f (Shaded x z)
forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> Depth
-> ([DBranch x y] -> [DBranch x y])
-> [DBranch x y]
-> f [DBranch x z]
go Depth
0 [DBranch x y] -> [DBranch x y]
forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id (NonEmpty (DBranch x y) -> [DBranch x y]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (DBranch x y)
bs)
 where go :: Depth
-> ([DBranch x y] -> [DBranch x y])
-> [DBranch x y]
-> f [DBranch x z]
go Depth
_ [DBranch x y] -> [DBranch x y]
_ [] = [DBranch x z] -> f [DBranch x z]
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 y] -> [DBranch x y]
prbs (tbs :: DBranch x y
tbs@(DBranch Needle' x
v (Hourglass Shaded x y
τ Shaded x y
β)) : [DBranch x y]
dbs)
        = (:) (DBranch x z -> [DBranch x z] -> [DBranch x z])
-> (Hourglass (Shaded x z) -> DBranch x z)
-> Hourglass (Shaded x z)
-> [DBranch x z]
-> [DBranch x z]
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. Needle' x -> Hourglass (Shaded x z) -> DBranch x z
forall x c. Needle' x -> Hourglass c -> DBranch' x c
DBranch Needle' x
v (Hourglass (Shaded x z) -> [DBranch x z] -> [DBranch x z])
-> f (Hourglass (Shaded x z)) -> f ([DBranch x z] -> [DBranch x z])
forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>
            (Shaded x z -> Shaded x z -> Hourglass (Shaded x z)
forall s. s -> s -> Hourglass s
Hourglass (Shaded x z -> Shaded x z -> Hourglass (Shaded x z))
-> f (Shaded x z) -> f (Shaded x z -> Hourglass (Shaded x z))
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
τ) (Shaded x y -> f (Shaded x z))
-> ([DBranch x y] -> Shaded x y) -> [DBranch x y] -> f (Shaded x z)
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 -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
forall x y.
Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
OverlappingBranches (Depth
nDepth -> Depth -> Depth
forall a. Num a => a -> a -> a
-Depth
nτ) Shade x
sh
                            (NonEmpty (DBranch x y) -> Shaded x y)
-> ([DBranch x y] -> NonEmpty (DBranch x y))
-> [DBranch x y]
-> 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
. [DBranch x y] -> NonEmpty (DBranch x y)
forall a. [a] -> NonEmpty a
NE.fromList ([DBranch x y] -> NonEmpty (DBranch x y))
-> ([DBranch x y] -> [DBranch x y])
-> [DBranch x y]
-> NonEmpty (DBranch 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
. [DBranch x y] -> [DBranch x y]
prbs ([DBranch x y] -> f (Shaded x z))
-> [DBranch x y] -> f (Shaded x z)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Needle' x -> Hourglass (Shaded x y) -> DBranch x y
forall x c. Needle' x -> Hourglass c -> DBranch' x c
DBranch Needle' x
v (Shaded x y -> Shaded x y -> Hourglass (Shaded x y)
forall s. s -> s -> Hourglass s
Hourglass Shaded x y
forall x y. Shaded x y
hole Shaded x y
β) DBranch x y -> [DBranch x y] -> [DBranch x y]
forall a. a -> [a] -> [a]
: [DBranch x y]
dbs)
                       f (Shaded x z -> Hourglass (Shaded x z))
-> f (Shaded x z) -> f (Hourglass (Shaded x z))
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₀Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+Depth
nτ, Shaded x y
β) (Shaded x y -> f (Shaded x z))
-> ([DBranch x y] -> Shaded x y) -> [DBranch x y] -> f (Shaded x z)
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 -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
forall x y.
Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
OverlappingBranches (Depth
nDepth -> Depth -> Depth
forall a. Num a => a -> a -> a
-Depth
nβ) Shade x
sh
                            (NonEmpty (DBranch x y) -> Shaded x y)
-> ([DBranch x y] -> NonEmpty (DBranch x y))
-> [DBranch x y]
-> 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
. [DBranch x y] -> NonEmpty (DBranch x y)
forall a. [a] -> NonEmpty a
NE.fromList ([DBranch x y] -> NonEmpty (DBranch x y))
-> ([DBranch x y] -> [DBranch x y])
-> [DBranch x y]
-> NonEmpty (DBranch 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
. [DBranch x y] -> [DBranch x y]
prbs ([DBranch x y] -> f (Shaded x z))
-> [DBranch x y] -> f (Shaded x z)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Needle' x -> Hourglass (Shaded x y) -> DBranch x y
forall x c. Needle' x -> Hourglass c -> DBranch' x c
DBranch Needle' x
v (Shaded x y -> Shaded x y -> Hourglass (Shaded x y)
forall s. s -> s -> Hourglass s
Hourglass Shaded x y
τ Shaded x y
forall x y. Shaded x y
hole) DBranch x y -> [DBranch x y] -> [DBranch x y]
forall a. a -> [a] -> [a]
: [DBranch x y]
dbs))
            f ([DBranch x z] -> [DBranch x z])
-> f [DBranch x z] -> f [DBranch x z]
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 y] -> [DBranch x y])
-> [DBranch x y]
-> f [DBranch x z]
go (Depth
i₀Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+Depth
nτDepth -> Depth -> Depth
forall a. Num a => a -> a -> a
+Depth
nβ) ([DBranch x y] -> [DBranch x y]
prbs ([DBranch x y] -> [DBranch x y])
-> ([DBranch x y] -> [DBranch x y])
-> [DBranch x y]
-> [DBranch 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
. (DBranch x y
tbsDBranch x y -> [DBranch x y] -> [DBranch x y]
forall a. a -> [a] -> [a]
:)) [DBranch x y]
dbs
        where [Depth
nτ, Depth
nβ] = Shaded x y -> Depth
forall x a. Shaded x a -> Depth
nLeaves(Shaded x y -> Depth) -> [Shaded x y] -> [Depth]
forall (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 = [(x, y)] -> Shaded x y
forall x y. [(x, y)] -> Shaded x y
PlainLeaves []


indexDBranches :: NonEmpty (DBranch x y) -> NonEmpty (DBranch' x (Int, x`Shaded`y))
indexDBranches :: NonEmpty (DBranch x y) -> NonEmpty (DBranch' x (Depth, Shaded x y))
indexDBranches (DBranch 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
              = Needle' x
-> Hourglass (Depth, Shaded x y) -> DBranch' x (Depth, Shaded x y)
forall x c. Needle' x -> Hourglass c -> DBranch' x c
DBranch Needle' x
d ((Depth, Shaded x y)
-> (Depth, Shaded x y) -> Hourglass (Depth, Shaded x y)
forall s. s -> s -> Hourglass s
Hourglass (Depth
0,Shaded x y
t) (Depth
nt,Shaded x y
b)) DBranch' x (Depth, Shaded x y)
-> [DBranch' x (Depth, Shaded x y)]
-> NonEmpty (DBranch' x (Depth, Shaded x y))
forall a. a -> [a] -> NonEmpty a
:| Depth -> [DBranch x y] -> [DBranch' x (Depth, Shaded x y)]
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 Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+ Depth
nb) [DBranch x y]
l
 where nt :: Depth
nt = Shaded x y -> Depth
forall x a. Shaded x a -> Depth
nLeaves Shaded x y
t; nb :: Depth
nb = Shaded x y -> Depth
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)
               = DualVector (Needle x)
-> Hourglass (Depth, Shaded x y) -> DBranch' x (Depth, Shaded x y)
forall x c. Needle' x -> Hourglass c -> DBranch' x c
DBranch DualVector (Needle x)
DualVector (Needle x)
δ ((Depth, Shaded x y)
-> (Depth, Shaded x y) -> Hourglass (Depth, Shaded x y)
forall s. s -> s -> Hourglass s
Hourglass (Depth
i₀,Shaded x y
τ) (Depth
i₀Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+Depth
nτ,Shaded x y
β)) DBranch' x (Depth, Shaded x y)
-> [DBranch' x (Depth, Shaded x y)]
-> [DBranch' x (Depth, Shaded x y)]
forall a. a -> [a] -> [a]
: Depth
-> [DBranch' x (Shaded x y)] -> [DBranch' x (Depth, Shaded x y)]
ixDBs (Depth
i₀ Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+ Depth
nτ Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+ Depth
nβ) [DBranch' x (Shaded x y)]
l
        where nτ :: Depth
nτ = Shaded x y -> Depth
forall x a. Shaded x a -> Depth
nLeaves Shaded x y
τ; nβ :: Depth
nβ = Shaded x y -> Depth
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) = [(x, y)] -> ()
forall a. NFData a => a -> ()
rnf [(x, y)]
xs
  rnf (DisjointBranches Depth
n NonEmpty (Shaded x y)
bs) = Depth
n Depth -> () -> ()
`seq` [Shaded x y] -> ()
forall a. NFData a => a -> ()
rnf (NonEmpty (Shaded x y) -> [Shaded x y]
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 Depth -> () -> ()
`seq` Shade x
sh Shade x -> () -> ()
`seq` [DBranch x y] -> ()
forall a. NFData a => a -> ()
rnf (NonEmpty (DBranch x y) -> [DBranch x y]
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 = [x] -> ShadeTree x
forall x.
(WithField ℝ Manifold x, SimpleSpace (Needle x)) =>
[x] -> ShadeTree x
fromLeafPoints ([x] -> ShadeTree x) -> [x] -> ShadeTree x
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ ShadeTree x -> [x]
forall x. WithField ℝ PseudoAffine x => ShadeTree x -> [x]
onlyLeaves_ ShadeTree x
t [x] -> [x] -> [x]
forall a. [a] -> [a] -> [a]
++ ShadeTree x -> [x]
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 = [ShadeTree x] -> ShadeTree x
forall a. Monoid a => [a] -> a
mconcat ([ShadeTree x] -> ShadeTree x)
-> (NonEmpty (ShadeTree x) -> [ShadeTree x])
-> NonEmpty (ShadeTree x)
-> ShadeTree x
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. NonEmpty (ShadeTree x) -> [ShadeTree x]
forall a. NonEmpty a -> [a]
NE.toList
instance (WithField ℝ Manifold x, SimpleSpace (Needle x)) => Monoid (ShadeTree x) where
  mempty :: ShadeTree x
mempty = [(x, ())] -> ShadeTree x
forall x y. [(x, y)] -> Shaded x y
PlainLeaves []
  mappend :: ShadeTree x -> ShadeTree x -> ShadeTree x
mappend = ShadeTree x -> ShadeTree x -> ShadeTree x
forall a. Semigroup a => a -> a -> a
(<>)
  mconcat :: [ShadeTree x] -> ShadeTree x
mconcat [ShadeTree x]
l = case (ShadeTree x -> Bool) -> [ShadeTree x] -> [ShadeTree x]
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 ShadeTree x -> Bool
forall x a. Shaded x a -> Bool
ne [ShadeTree x]
l of
               [] -> ShadeTree x
forall a. Monoid a => a
mempty
               [ShadeTree x
t] -> ShadeTree x
t
               [ShadeTree x]
l' -> [x] -> ShadeTree x
forall x.
(WithField ℝ Manifold x, SimpleSpace (Needle x)) =>
[x] -> ShadeTree x
fromLeafPoints ([x] -> ShadeTree x) -> [x] -> ShadeTree x
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ ShadeTree x -> [x]
forall x. WithField ℝ PseudoAffine x => ShadeTree x -> [x]
onlyLeaves_ (ShadeTree x -> [x]) -> [ShadeTree x] -> [x]
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 :: [x] -> ShadeTree x
fromLeafPoints = [(x, ())] -> ShadeTree x
forall x y.
(WithField ℝ Manifold x, SimpleSpace (Needle x)) =>
[(x, y)] -> Shaded x y
fromLeafPoints_ ([(x, ())] -> ShadeTree x)
-> ([x] -> [(x, ())]) -> [x] -> ShadeTree x
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. (x -> (x, ())) -> [x] -> [(x, ())]
forall a b. (a -> b) -> [a] -> [b]
map (,())

fromLeafPoints_ :: ∀ x y. (WithField ℝ Manifold x, SimpleSpace (Needle x))
                        => [(x,y)] -> x`Shaded`y
fromLeafPoints_ :: [(x, y)] -> Shaded x y
fromLeafPoints_ = (Shade x -> [(x, y)] -> NonEmpty (DBranch' x [(x, y)]))
-> [(x, y)] -> Shaded x y
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)])
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 :: Shaded x y -> Depth -> Either Depth ([Shaded x y], (x, y))
indexShadeTree Shaded x y
_ Depth
i
    | Depth
iDepth -> Depth -> Bool
forall a. Ord a => a -> a -> Bool
<Depth
0        = Depth -> Either Depth ([Shaded x y], (x, y))
forall a b. a -> Either a b
Left Depth
i
indexShadeTree sh :: Shaded x y
sh@(PlainLeaves [(x, y)]
lvs) Depth
i = case [(x, y)] -> Depth
forall (t :: * -> *) a. Foldable t => t a -> Depth
length [(x, y)]
lvs of
  Depth
n | Depth
iDepth -> Depth -> Bool
forall a. Ord a => a -> a -> Bool
<Depth
n       -> ([Shaded x y], (x, y)) -> Either Depth ([Shaded x y], (x, y))
forall a b. b -> Either a b
Right ([Shaded x y
sh], [(x, y)]
lvs[(x, y)] -> Depth -> (x, y)
forall a. [a] -> Depth -> a
!!Depth
i)
    | Bool
otherwise -> Depth -> Either Depth ([Shaded x y], (x, y))
forall a b. a -> Either a b
Left (Depth -> Either Depth ([Shaded x y], (x, y)))
-> Depth -> Either Depth ([Shaded x y], (x, y))
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Depth
iDepth -> Depth -> Depth
forall a. Num a => a -> a -> a
-Depth
n
indexShadeTree (DisjointBranches Depth
n NonEmpty (Shaded x y)
brs) Depth
i
    | Depth
iDepth -> Depth -> Bool
forall a. Ord a => a -> a -> Bool
<Depth
n        = (Either Depth ([Shaded x y], (x, y))
 -> Shaded x y -> Either Depth ([Shaded x y], (x, y)))
-> Either Depth ([Shaded x y], (x, y))
-> NonEmpty (Shaded x y)
-> Either Depth ([Shaded x y], (x, y))
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\case 
                             Left Depth
i' -> (Shaded x y -> Depth -> Either Depth ([Shaded x y], (x, y))
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  -> Either Depth ([Shaded x y], (x, y))
-> Shaded x y -> Either Depth ([Shaded x y], (x, y))
forall (m :: * -> *) a. Monad m (->) => a -> m a
return Either Depth ([Shaded x y], (x, y))
result
                         ) (Depth -> Either Depth ([Shaded x y], (x, y))
forall a b. a -> Either a b
Left Depth
i) NonEmpty (Shaded x y)
brs
    | Bool
otherwise  = Depth -> Either Depth ([Shaded x y], (x, y))
forall a b. a -> Either a b
Left (Depth -> Either Depth ([Shaded x y], (x, y)))
-> Depth -> Either Depth ([Shaded x y], (x, y))
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Depth
iDepth -> Depth -> Depth
forall 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
iDepth -> Depth -> Bool
forall a. Ord a => a -> a -> Bool
<Depth
n        = ([Shaded x y] -> [Shaded x y])
-> ([Shaded x y], (x, y)) -> ([Shaded x y], (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 (Shaded x y
shShaded x y -> [Shaded x y] -> [Shaded x y]
forall a. a -> [a] -> [a]
:) (([Shaded x y], (x, y)) -> ([Shaded x y], (x, y)))
-> Either Depth ([Shaded x y], (x, y))
-> Either Depth ([Shaded x y], (x, y))
forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> (Either Depth ([Shaded x y], (x, y))
 -> Shaded x y -> Either Depth ([Shaded x y], (x, y)))
-> Either Depth ([Shaded x y], (x, y))
-> [Shaded x y]
-> Either Depth ([Shaded x y], (x, y))
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\case 
                             Left Depth
i' -> (Shaded x y -> Depth -> Either Depth ([Shaded x y], (x, y))
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  -> Either Depth ([Shaded x y], (x, y))
-> Shaded x y -> Either Depth ([Shaded x y], (x, y))
forall (m :: * -> *) a. Monad m (->) => a -> m a
return Either Depth ([Shaded x y], (x, y))
result
                         ) (Depth -> Either Depth ([Shaded x y], (x, y))
forall a b. a -> Either a b
Left Depth
i) (NonEmpty (DBranch x y) -> [DBranch x y]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (DBranch x y)
brs[DBranch x y] -> (DBranch x y -> [Shaded x y]) -> [Shaded x y]
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 x y -> [Shaded x y]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList)
    | Bool
otherwise  = Depth -> Either Depth ([Shaded x y], (x, y))
forall a b. a -> Either a b
Left (Depth -> Either Depth ([Shaded x y], (x, y)))
-> Depth -> Either Depth ([Shaded x y], (x, y))
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Depth
iDepth -> Depth -> Depth
forall 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 :: Depth -> (y -> f y) -> Shaded x y -> Either Depth (f (Shaded x y))
treeLeaf Depth
i y -> f y
_ Shaded x y
_
    | Depth
iDepth -> Depth -> Bool
forall a. Ord a => a -> a -> Bool
<Depth
0        = Depth -> Either Depth (f (Shaded x y))
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 [(x, y)] -> Depth
forall (t :: * -> *) a. Foldable t => t a -> Depth
length [(x, y)]
lvs of
  Depth
n | Depth
iDepth -> Depth -> Bool
forall a. Ord a => a -> a -> Bool
<Depth
n
    , ([(x, y)]
pre, (x
x,y
node):[(x, y)]
post) <- Depth -> [(x, y)] -> ([(x, y)], [(x, y)])
forall a. Depth -> [a] -> ([a], [a])
splitAt Depth
i [(x, y)]
lvs
              -> f (Shaded x y) -> Either Depth (f (Shaded x y))
forall a b. b -> Either a b
Right (f (Shaded x y) -> Either Depth (f (Shaded x y)))
-> (f y -> f (Shaded x y)) -> f y -> Either Depth (f (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
. (y -> Shaded x y) -> f y -> f (Shaded x y)
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)] -> Shaded x y
forall x y. [(x, y)] -> Shaded x y
PlainLeaves ([(x, y)] -> Shaded x y) -> (y -> [(x, y)]) -> y -> 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
. ([(x, y)]
pre[(x, y)] -> [(x, y)] -> [(x, y)]
forall a. [a] -> [a] -> [a]
++) ([(x, y)] -> [(x, y)]) -> (y -> [(x, y)]) -> y -> [(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
. ((x, y) -> [(x, y)] -> [(x, y)]
forall a. a -> [a] -> [a]
:[(x, y)]
post) ((x, y) -> [(x, y)]) -> (y -> (x, y)) -> y -> [(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
. (x
x,)) (f y -> Either Depth (f (Shaded x y)))
-> f y -> Either Depth (f (Shaded x y))
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 -> Depth -> Either Depth (f (Shaded x y))
forall a b. a -> Either a b
Left (Depth -> Either Depth (f (Shaded x y)))
-> Depth -> Either Depth (f (Shaded x y))
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Depth
iDepth -> Depth -> Depth
forall a. Num a => a -> a -> a
-Depth
n
treeLeaf Depth
i y -> f y
f (DisjointBranches Depth
n NonEmpty (Shaded x y)
_)
    | Depth
iDepth -> Depth -> Bool
forall a. Ord a => a -> a -> Bool
>=Depth
n   = Depth -> Either Depth (f (Shaded x y))
forall a b. a -> Either a b
Left (Depth -> Either Depth (f (Shaded x y)))
-> Depth -> Either Depth (f (Shaded x y))
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Depth
iDepth -> Depth -> Depth
forall a. Num a => a -> a -> a
-Depth
n
treeLeaf Depth
i y -> f y
f (DisjointBranches Depth
n (Shaded x y
br:|[]))
        = (Shaded x y -> Shaded x y) -> f (Shaded x y) -> f (Shaded x y)
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 (Depth -> NonEmpty (Shaded x y) -> Shaded x y
forall x y. Depth -> NonEmpty (Shaded x y) -> Shaded x y
DisjointBranches Depth
n (NonEmpty (Shaded x y) -> Shaded x y)
-> (Shaded x y -> NonEmpty (Shaded x y))
-> Shaded x y
-> 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
. Shaded x y -> NonEmpty (Shaded x y)
forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a.
(Applicative f r t, Object r a, Object t (f a)) =>
t a (f a)
pure) (f (Shaded x y) -> f (Shaded x y))
-> Either Depth (f (Shaded x y)) -> Either Depth (f (Shaded x y))
forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> Depth -> (y -> f y) -> Shaded x y -> Either Depth (f (Shaded x y))
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 Depth -> (y -> f y) -> Shaded x y -> Either Depth (f (Shaded x y))
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 -> (Shaded x y -> Shaded x y) -> f (Shaded x y) -> f (Shaded x y)
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'))
                                   -> Depth -> NonEmpty (Shaded x y) -> Shaded x y
forall x y. Depth -> NonEmpty (Shaded x y) -> Shaded x y
DisjointBranches Depth
n (Shaded x y
brShaded x y -> [Shaded x y] -> NonEmpty (Shaded x y)
forall a. a -> [a] -> NonEmpty a
:|Shaded x y
br''Shaded x y -> [Shaded x y] -> [Shaded x y]
forall a. a -> [a] -> [a]
:[Shaded x y]
brs'))
                  (f (Shaded x y) -> f (Shaded x y))
-> Either Depth (f (Shaded x y)) -> Either Depth (f (Shaded x y))
forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> Depth -> (y -> f y) -> Shaded x y -> Either Depth (f (Shaded x y))
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
                     (Depth -> NonEmpty (Shaded x y) -> Shaded x y
forall x y. Depth -> NonEmpty (Shaded x y) -> Shaded x y
DisjointBranches (Depth
nDepth -> Depth -> Depth
forall a. Num a => a -> a -> a
-Shaded x y -> Depth
forall x a. Shaded x a -> Depth
nLeaves Shaded x y
br) (NonEmpty (Shaded x y) -> Shaded x y)
-> NonEmpty (Shaded x y) -> Shaded x y
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Shaded x y
br'Shaded x y -> [Shaded x y] -> NonEmpty (Shaded x y)
forall a. a -> [a] -> NonEmpty a
:|[Shaded x y]
brs)
            Right f (Shaded x y)
done -> f (Shaded x y) -> Either Depth (f (Shaded x y))
forall a b. b -> Either a b
Right (f (Shaded x y) -> Either Depth (f (Shaded x y)))
-> f (Shaded x y) -> Either Depth (f (Shaded x y))
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Depth -> NonEmpty (Shaded x y) -> Shaded x y
forall x y. Depth -> NonEmpty (Shaded x y) -> Shaded x y
DisjointBranches Depth
n (NonEmpty (Shaded x y) -> Shaded x y)
-> (Shaded x y -> NonEmpty (Shaded x y))
-> Shaded x y
-> 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
. (Shaded x y -> [Shaded x y] -> NonEmpty (Shaded x y)
forall a. a -> [a] -> NonEmpty a
:|Shaded x y
br'Shaded x y -> [Shaded x y] -> [Shaded x y]
forall a. a -> [a] -> [a]
:[Shaded x y]
brs) (Shaded x y -> Shaded x y) -> f (Shaded x y) -> f (Shaded x y)
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
iDepth -> Depth -> Bool
forall a. Ord a => a -> a -> Bool
<Depth
nt       = (Shaded x y -> Shaded x y) -> f (Shaded x y) -> f (Shaded x y)
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 (Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
forall x y.
Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
OverlappingBranches Depth
n Shade x
extend
                         (NonEmpty (DBranch x y) -> Shaded x y)
-> (Shaded x y -> NonEmpty (DBranch x y))
-> Shaded x y
-> 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
. (DBranch x y -> [DBranch x y] -> NonEmpty (DBranch x y)
forall a. a -> [a] -> NonEmpty a
:|[DBranch x y]
brs) (DBranch x y -> NonEmpty (DBranch x y))
-> (Shaded x y -> DBranch x y)
-> Shaded x y
-> NonEmpty (DBranch 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
. Needle' x -> Hourglass (Shaded x y) -> DBranch x y
forall x c. Needle' x -> Hourglass c -> DBranch' x c
DBranch Needle' x
dir (Hourglass (Shaded x y) -> DBranch x y)
-> (Shaded x y -> Hourglass (Shaded x y))
-> Shaded x y
-> DBranch 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
. (Shaded x y -> Shaded x y -> Hourglass (Shaded x y)
forall s. s -> s -> Hourglass s
`Hourglass`Shaded x y
b))
                    (f (Shaded x y) -> f (Shaded x y))
-> Either Depth (f (Shaded x y)) -> Either Depth (f (Shaded x y))
forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> Depth -> (y -> f y) -> Shaded x y -> Either Depth (f (Shaded x y))
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
iDepth -> Depth -> Bool
forall a. Ord a => a -> a -> Bool
<Depth
ntDepth -> Depth -> Depth
forall a. Num a => a -> a -> a
+Depth
nb    = (Shaded x y -> Shaded x y) -> f (Shaded x y) -> f (Shaded x y)
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 (Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
forall x y.
Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
OverlappingBranches Depth
n Shade x
extend
                         (NonEmpty (DBranch x y) -> Shaded x y)
-> (Shaded x y -> NonEmpty (DBranch x y))
-> Shaded x y
-> 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
. (DBranch x y -> [DBranch x y] -> NonEmpty (DBranch x y)
forall a. a -> [a] -> NonEmpty a
:|[DBranch x y]
brs) (DBranch x y -> NonEmpty (DBranch x y))
-> (Shaded x y -> DBranch x y)
-> Shaded x y
-> NonEmpty (DBranch 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
. Needle' x -> Hourglass (Shaded x y) -> DBranch x y
forall x c. Needle' x -> Hourglass c -> DBranch' x c
DBranch Needle' x
dir (Hourglass (Shaded x y) -> DBranch x y)
-> (Shaded x y -> Hourglass (Shaded x y))
-> Shaded x y
-> DBranch 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
. ( Shaded x y -> Shaded x y -> Hourglass (Shaded x y)
forall s. s -> s -> Hourglass s
Hourglass Shaded x y
t))
                    (f (Shaded x y) -> f (Shaded x y))
-> Either Depth (f (Shaded x y)) -> Either Depth (f (Shaded x y))
forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> Depth -> (y -> f y) -> Shaded x y -> Either Depth (f (Shaded x y))
forall x y (f :: * -> *).
Functor f =>
Depth -> (y -> f y) -> Shaded x y -> Either Depth (f (Shaded x y))
treeLeaf (Depth
iDepth -> Depth -> Depth
forall 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
                 = (Shaded x y -> Shaded x y) -> f (Shaded x y) -> f (Shaded x y)
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''))
                         -> Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
forall x y.
Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
OverlappingBranches Depth
n Shade x
extend (NonEmpty (DBranch x y) -> Shaded x y)
-> NonEmpty (DBranch x y) -> Shaded x y
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ DBranch x y
brDBranch x y -> [DBranch x y] -> NonEmpty (DBranch x y)
forall a. a -> [a] -> NonEmpty a
:|DBranch x y
br''DBranch x y -> [DBranch x y] -> [DBranch x y]
forall a. a -> [a] -> [a]
:[DBranch x y]
brs'')
                    (f (Shaded x y) -> f (Shaded x y))
-> Either Depth (f (Shaded x y)) -> Either Depth (f (Shaded x y))
forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> Depth -> (y -> f y) -> Shaded x y -> Either Depth (f (Shaded x y))
forall x y (f :: * -> *).
Functor f =>
Depth -> (y -> f y) -> Shaded x y -> Either Depth (f (Shaded x y))
treeLeaf (Depth
iDepth -> Depth -> Depth
forall a. Num a => a -> a -> a
-Depth
ntDepth -> Depth -> Depth
forall a. Num a => a -> a -> a
-Depth
nb) y -> f y
f (Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
forall x y.
Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
OverlappingBranches Depth
n Shade x
extend (NonEmpty (DBranch x y) -> Shaded x y)
-> NonEmpty (DBranch x y) -> Shaded x y
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ DBranch x y
br'DBranch x y -> [DBranch x y] -> NonEmpty (DBranch x y)
forall a. a -> [a] -> NonEmpty a
:|[DBranch x y]
brs')
    | Bool
otherwise  = Depth -> Either Depth (f (Shaded x y))
forall a b. a -> Either a b
Left (Depth -> Either Depth (f (Shaded x y)))
-> Depth -> Either Depth (f (Shaded x y))
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Depth
i Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
- Depth
nt Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
- Depth
nb
 where [Depth
nt,Depth
nb] = Shaded x y -> Depth
forall x a. Shaded x a -> Depth
nLeaves(Shaded x y -> Depth) -> [Shaded x y] -> [Depth]
forall (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 :: 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 [Maybe ((Depth, (x, y)), ℝ)] -> [((Depth, (x, y)), ℝ)]
forall a. [Maybe a] -> [a]
catMaybes [ ((Depth
i,(x, y)
p),) (ℝ -> ((Depth, (x, y)), ℝ))
-> (Needle x -> ℝ) -> Needle x -> ((Depth, (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
. Metric x -> Needle x -> Scalar (Needle x)
forall v. LSpace v => Seminorm v -> v -> Scalar v
normSq Metric x
m (Needle x -> ((Depth, (x, y)), ℝ))
-> Maybe (Needle x) -> Maybe ((Depth, (x, y)), ℝ)
forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> (x, y) -> x
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst (x, y)
px -> x -> Maybe (Needle x)
forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
x
                            | (Depth
i,(x, y)
p) <- [Depth] -> [(x, y)] -> [(Depth, (x, y))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Depth
0..] [(x, y)]
lvs] of
           [] -> Maybe (Depth, ([Shaded x y], (x, y)))
forall (f :: * -> *) a. Alternative f => f a
empty
           [((Depth, (x, y)), ℝ)]
l | ((Depth
i,(x, y)
p),ℝ
_) <- (((Depth, (x, y)), ℝ) -> ((Depth, (x, y)), ℝ) -> Ordering)
-> [((Depth, (x, y)), ℝ)] -> ((Depth, (x, y)), ℝ)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy ((((Depth, (x, y)), ℝ) -> ℝ)
-> ((Depth, (x, y)), ℝ) -> ((Depth, (x, y)), ℝ) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((Depth, (x, y)), ℝ) -> ℝ
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd) [((Depth, (x, y)), ℝ)]
l
              -> (Depth, ([Shaded x y], (x, y)))
-> Maybe (Depth, ([Shaded x y], (x, y)))
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
        = (Maybe (Depth, ([Shaded x y], (x, y))), Depth)
-> Maybe (Depth, ([Shaded x y], (x, y)))
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst ((Maybe (Depth, ([Shaded x y], (x, y))), Depth)
 -> Maybe (Depth, ([Shaded x y], (x, y))))
-> (NonEmpty (Shaded x y)
    -> (Maybe (Depth, ([Shaded x y], (x, y))), Depth))
-> NonEmpty (Shaded x y)
-> Maybe (Depth, ([Shaded x y], (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
. ((Maybe (Depth, ([Shaded x y], (x, y))), Depth)
 -> Shaded x y -> (Maybe (Depth, ([Shaded x y], (x, y))), Depth))
-> (Maybe (Depth, ([Shaded x y], (x, y))), Depth)
-> NonEmpty (Shaded x y)
-> (Maybe (Depth, ([Shaded x y], (x, y))), Depth)
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₀) -> (Maybe (Depth, ([Shaded x y], (x, y))), Depth)
-> Shaded x y -> (Maybe (Depth, ([Shaded x y], (x, y))), Depth)
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' -> ( (Depth -> Depth)
-> (Depth, ([Shaded x y], (x, y)))
-> (Depth, ([Shaded x y], (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 (Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+Depth
i₀) ((Depth, ([Shaded x y], (x, y)))
 -> (Depth, ([Shaded x y], (x, y))))
-> Maybe (Depth, ([Shaded x y], (x, y)))
-> Maybe (Depth, ([Shaded x y], (x, y)))
forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> Maybe (Metric x)
-> Shaded x y -> x -> Maybe (Depth, ([Shaded x y], (x, y)))
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₀Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+Shaded x y -> Depth
forall x a. Shaded x a -> Depth
nLeaves Shaded x y
t' ) )
                       (Maybe (Depth, ([Shaded x y], (x, y)))
forall (f :: * -> *) a. Alternative f => f a
empty, Depth
0)
              (NonEmpty (Shaded x y) -> Maybe (Depth, ([Shaded x y], (x, y))))
-> NonEmpty (Shaded x y) -> Maybe (Depth, ([Shaded x y], (x, y)))
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
               <- PseudoAffineWitness x
forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness :: PseudoAffineWitness x
   , Just Needle x
vx <- x
xx -> x -> Maybe (Needle x)
forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
c
        = let (ℝ
_,(Depth
i₀,Shaded x y
t')) = ((ℝ, (Depth, Shaded x y)) -> (ℝ, (Depth, Shaded x y)) -> Ordering)
-> [(ℝ, (Depth, Shaded x y))] -> (ℝ, (Depth, Shaded x y))
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (((ℝ, (Depth, Shaded x y)) -> ℝ)
-> (ℝ, (Depth, Shaded x y)) -> (ℝ, (Depth, Shaded x y)) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (ℝ, (Depth, Shaded x y)) -> ℝ
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) <- NonEmpty (DBranch' x (Depth, Shaded x y))
-> [DBranch' x (Depth, Shaded x y)]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty (DBranch' x (Depth, Shaded x y))
 -> [DBranch' x (Depth, Shaded x y)])
-> NonEmpty (DBranch' x (Depth, Shaded x y))
-> [DBranch' x (Depth, Shaded x y)]
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ NonEmpty (DBranch x y) -> NonEmpty (DBranch' x (Depth, Shaded x y))
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
dNeedle' x -> Needle x -> Scalar (Needle x)
forall 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 ((Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+Depth
i₀) (Depth -> Depth)
-> (([Shaded x y], (x, y)) -> ([Shaded x y], (x, y)))
-> (Depth, ([Shaded x y], (x, y)))
-> (Depth, ([Shaded x y], (x, y)))
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')
*** ([Shaded x y] -> [Shaded x y])
-> ([Shaded x y], (x, y)) -> ([Shaded x y], (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 (Shaded x y
shShaded x y -> [Shaded x y] -> [Shaded x y]
forall a. a -> [a] -> [a]
:))
                 ((Depth, ([Shaded x y], (x, y)))
 -> (Depth, ([Shaded x y], (x, y))))
-> Maybe (Depth, ([Shaded x y], (x, y)))
-> Maybe (Depth, ([Shaded x y], (x, y)))
forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> Maybe (Metric x)
-> Shaded x y -> x -> Maybe (Depth, ([Shaded x y], (x, y)))
forall x y.
(WithField ℝ Manifold x, SimpleSpace (Needle x)) =>
Maybe (Metric x)
-> Shaded x y -> x -> Maybe (Depth, ([Shaded x y], (x, y)))
positionIndex (Metric x -> Maybe (Metric x)
forall (m :: * -> *) a. Monad m (->) => a -> m a
return (Metric x -> Maybe (Metric x)) -> Metric x -> Maybe (Metric x)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Metric' x -> Metric x
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
_ = Maybe (Depth, ([Shaded x y], (x, y)))
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' :: (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 = Metric' x -> [(x, y)] -> Shaded x y
go Metric' x
forall a. Monoid a => a
mempty
 where go :: Metric' x -> [(x,y)] -> x`Shaded`y
       go :: Metric' x -> [(x, y)] -> Shaded x y
go Metric' x
preShExpa
            = \[(x, y)]
xs -> case Metric' x -> [(x, y)] -> [([(x, y)], Shade x)]
forall x y.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
Metric' x -> [(x, y)] -> [([(x, y)], Shade x)]
pointsShades' (Scalar (DualVector (Needle x)) -> Metric' x -> Metric' x
forall v. LSpace v => Scalar v -> Norm v -> Norm v
scaleNorm (ℝ
1ℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
3) Metric' x
preShExpa) [(x, y)]
xs of
                     [] -> [(x, y)] -> Shaded x y
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
                                           -> Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
forall x y.
Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
OverlappingBranches
                                                  ([(x, y)] -> Depth
forall (t :: * -> *) a. Foldable t => t a -> Depth
length [(x, y)]
xs) Shade x
rShade
                                                  (Metric' x
-> NonEmpty (DBranch' x [(x, y)]) -> NonEmpty (DBranch x y)
branchProc (Shade x -> Metric' x
forall x. Shade x -> Metric' x
_shadeExpanse Shade x
rShade) NonEmpty (DBranch' x [(x, y)])
redBrchs)
                                         Maybe (NonEmpty (DBranch' x [(x, y)]))
_ -> [(x, y)] -> Shaded x y
forall x y. [(x, y)] -> Shaded x y
PlainLeaves [(x, y)]
xs
                     [([(x, y)], Shade x)]
partitions -> Depth -> NonEmpty (Shaded x y) -> Shaded x y
forall x y. Depth -> NonEmpty (Shaded x y) -> Shaded x y
DisjointBranches ([(x, y)] -> Depth
forall (t :: * -> *) a. Foldable t => t a -> Depth
length [(x, y)]
xs)
                                   (NonEmpty (Shaded x y) -> Shaded x y)
-> ([Shaded x y] -> NonEmpty (Shaded x y))
-> [Shaded x y]
-> 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
. [Shaded x y] -> NonEmpty (Shaded x y)
forall a. [a] -> NonEmpty a
NE.fromList
                                    ([Shaded x y] -> Shaded x y) -> [Shaded x y] -> Shaded x y
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (([(x, y)], Shade x) -> Shaded x y)
-> [([(x, y)], Shade x)] -> [Shaded x y]
forall a b. (a -> b) -> [a] -> [b]
map (\([(x, y)]
xs',Shade x
pShade) -> Metric' x -> [(x, y)] -> Shaded x y
go Metric' x
forall a. Monoid a => a
mempty [(x, y)]
xs') [([(x, y)], Shade x)]
partitions
        where 
              branchProc :: Metric' x
-> NonEmpty (DBranch' x [(x, y)]) -> NonEmpty (DBranch x y)
branchProc Metric' x
redSh = (DBranch' x [(x, y)] -> DBranch x y)
-> NonEmpty (DBranch' x [(x, y)]) -> NonEmpty (DBranch x y)
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)] -> Shaded x y) -> DBranch' x [(x, y)] -> DBranch x y
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)] -> Shaded x y) -> DBranch' x [(x, y)] -> DBranch x y)
-> ([(x, y)] -> Shaded x y) -> DBranch' x [(x, y)] -> DBranch x y
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Metric' x -> [(x, y)] -> Shaded x y
go Metric' 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 Metric' x
_) NonEmpty (DBranch' x [(x, y)])
brCandidates
                        = case (Hourglass Depth -> Bool) -> [Hourglass Depth] -> Maybe Depth
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)
                                             <- Depth
-> [DBranch' x [(x, y)]]
-> (DBranch' x [(x, y)], [DBranch' x [(x, y)]])
forall a. Depth -> [a] -> (a, [a])
amputateId Depth
i (NonEmpty (DBranch' x [(x, y)]) -> [DBranch' x [(x, y)]]
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
                                                (NonEmpty (DBranch' x [(x, y)])
 -> Maybe (NonEmpty (DBranch' x [(x, y)])))
-> NonEmpty (DBranch' x [(x, y)])
-> Maybe (NonEmpty (DBranch' x [(x, y)]))
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ x
-> [(x, y)]
-> NonEmpty (DBranch' x [(x, y)])
-> NonEmpty (DBranch' x [(x, y)])
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 (Hourglass [(x, y)] -> [(x, y)]
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)]
oDBranch' x [(x, y)]
-> [DBranch' x [(x, y)]] -> NonEmpty (DBranch' x [(x, y)])
forall a. a -> [a] -> NonEmpty a
:|[DBranch' x [(x, y)]]
ok)
                                   | Bool
otherwise -> Maybe (NonEmpty (DBranch' x [(x, y)]))
forall a. Maybe a
Nothing
                            Maybe Depth
_ -> NonEmpty (DBranch' x [(x, y)])
-> Maybe (NonEmpty (DBranch' x [(x, y)]))
forall a. a -> Maybe a
Just NonEmpty (DBranch' x [(x, y)])
brCandidates
               where ([Hourglass Depth]
cards, Depth
maxCard) = (NonEmpty (Hourglass Depth) -> [Hourglass Depth]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty (Hourglass Depth) -> [Hourglass Depth])
-> (NonEmpty (Hourglass Depth) -> Depth)
-> NonEmpty (Hourglass Depth)
-> ([Hourglass Depth], Depth)
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')
                                (NonEmpty (Hourglass Depth) -> ([Hourglass Depth], Depth))
-> NonEmpty (Hourglass Depth) -> ([Hourglass Depth], Depth)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (DBranch' x [(x, y)] -> Hourglass Depth)
-> NonEmpty (DBranch' x [(x, y)]) -> NonEmpty (Hourglass Depth)
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)] -> Depth) -> Hourglass [(x, y)] -> Hourglass Depth
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)] -> Depth
forall (t :: * -> *) a. Foldable t => t a -> Depth
length (Hourglass [(x, y)] -> Hourglass Depth)
-> (DBranch' x [(x, y)] -> Hourglass [(x, y)])
-> DBranch' x [(x, y)]
-> Hourglass 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
. DBranch' x [(x, y)] -> Hourglass [(x, y)]
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) = (Depth -> Bool) -> [Depth] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Depth
c -> Depth
cDepth -> Depth -> Depth
forall a. Num a => a -> Depth -> a
^Depth
2 Depth -> Depth -> Bool
forall a. Ord a => a -> a -> Bool
<= Depth
maxCard Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+ Depth
1) [Depth
u,Depth
l]
                     maximum' :: NonEmpty (Hourglass Depth) -> Depth
maximum' = [Depth] -> Depth
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Depth] -> Depth)
-> (NonEmpty (Hourglass Depth) -> [Depth])
-> NonEmpty (Hourglass 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
. NonEmpty Depth -> [Depth]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty Depth -> [Depth])
-> (NonEmpty (Hourglass Depth) -> NonEmpty Depth)
-> NonEmpty (Hourglass 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
. (Hourglass Depth -> Depth)
-> NonEmpty (Hourglass Depth) -> NonEmpty Depth
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) -> Depth -> Depth -> Depth
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' :: 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
           = ((x, y)
 -> NonEmpty (DBranch' x [(x, y)])
 -> NonEmpty (DBranch' x [(x, y)]))
-> NonEmpty (DBranch' x [(x, y)])
-> [(x, y)]
-> NonEmpty (DBranch' x [(x, y)])
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 ([DBranch' x [(x, y)]] -> [DBranch' x [(x, y)]])
-> NonEmpty (DBranch' x [(x, y)]) -> NonEmpty (DBranch' x [(x, y)])
forall a b. ([a] -> [b]) -> NonEmpty a -> NonEmpty b
asList (([DBranch' x [(x, y)]] -> [DBranch' x [(x, y)]])
 -> NonEmpty (DBranch' x [(x, y)])
 -> NonEmpty (DBranch' x [(x, y)]))
-> ([DBranch' x [(x, y)]] -> [DBranch' x [(x, y)]])
-> NonEmpty (DBranch' x [(x, y)])
-> NonEmpty (DBranch' x [(x, y)])
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (DBranch' x [(x, y)] -> DBranch' x [(x, y)])
-> Depth -> [DBranch' x [(x, y)]] -> [DBranch' x [(x, y)]]
forall a. (a -> a) -> Depth -> [a] -> [a]
update_nth (\(DBranch Needle' x
d Hourglass [(x, y)]
c)
                                                    -> Needle' x -> Hourglass [(x, y)] -> DBranch' x [(x, y)]
forall x c. Needle' x -> Hourglass c -> DBranch' x c
DBranch Needle' x
d (HourglassBulb
-> ([(x, y)] -> [(x, y)])
-> Hourglass [(x, y)]
-> Hourglass [(x, y)]
forall a. HourglassBulb -> (a -> a) -> Hourglass a -> Hourglass a
oneBulb HourglassBulb
h ((x
p,y
y)(x, y) -> [(x, y)] -> [(x, 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 = x -> NonEmpty (Needle' x) -> x -> (Depth, HourglassBulb)
forall x.
(WithField ℝ PseudoAffine x, LinearSpace (Needle x)) =>
x -> NonEmpty (Needle' x) -> x -> (Depth, HourglassBulb)
subshadeId' x
c (DBranch' x [(x, y)] -> Needle' x
forall x c. DBranch' x c -> Needle' x
boughDirection(DBranch' x [(x, y)] -> Needle' x)
-> NonEmpty (DBranch' x [(x, y)]) -> NonEmpty (Needle' x)
forall (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 :: 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 <- [Needle' x -> Hourglass [(x, y)] -> DBranch' x [(x, y)]
forall x c. Needle' x -> Hourglass c -> DBranch' x c
DBranch Needle' x
v Hourglass [(x, y)]
forall a. Monoid a => a
mempty | Needle' x
v <- Metric' x -> [Needle' x]
forall v.
(FiniteDimensional v, IEEE (Scalar v)) =>
Seminorm v -> [v]
normSpanningSystem' Metric' x
expa]
    = x
-> [(x, y)]
-> NonEmpty (DBranch' x [(x, y)])
-> NonEmpty (DBranch' x [(x, y)])
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)]) -> NonEmpty (DBranch' x [(x, y)]))
-> NonEmpty (DBranch' x [(x, y)]) -> NonEmpty (DBranch' x [(x, y)])
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ DBranch' x [(x, y)]
bDBranch' x [(x, y)]
-> [DBranch' x [(x, y)]] -> NonEmpty (DBranch' x [(x, y)])
forall a. a -> [a] -> NonEmpty a
:|[DBranch' x [(x, y)]]
bs
                                           

asList :: ([a]->[b]) -> NonEmpty a->NonEmpty b
asList :: ([a] -> [b]) -> NonEmpty a -> NonEmpty b
asList [a] -> [b]
f = [b] -> NonEmpty b
forall a. [a] -> NonEmpty a
NE.fromList ([b] -> NonEmpty b)
-> (NonEmpty a -> [b]) -> NonEmpty a -> NonEmpty b
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 ([a] -> [b]) -> (NonEmpty a -> [a]) -> NonEmpty a -> [b]
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 a -> [a]
forall a. NonEmpty a -> [a]
NE.toList

update_nth :: (a->a) -> Int -> [a] -> [a]
update_nth :: (a -> a) -> Depth -> [a] -> [a]
update_nth a -> a
_ Depth
n [a]
l | Depth
nDepth -> Depth -> Bool
forall 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 a -> [a] -> [a]
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 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> a) -> Depth -> [a] -> [a]
forall a. (a -> a) -> Depth -> [a] -> [a]
update_nth a -> a
f (Depth
nDepth -> Depth -> Depth
forall a. Num a => a -> a -> a
-Depth
1) [a]
r


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

deleteIds :: [Int] -> [a] -> [a]
deleteIds :: [Depth] -> [a] -> [a]
deleteIds [Depth]
kids = ([a], [a]) -> [a]
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd (([a], [a]) -> [a]) -> ([a] -> ([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] -> [a] -> ([a], [a])
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 :: [Depth] -> [a] -> ([a], [a])
amputateIds = Depth -> [Depth] -> [a] -> ([a], [a])
forall a a. (Eq a, Num a) => a -> [a] -> [a] -> ([a], [a])
go Depth
0
 where go :: a -> [a] -> [a] -> ([a], [a])
go a
_ [a]
_ [] = ([],[])
       go a
_ [] [a]
l = ([],[a]
l)
       go a
i (a
k:[a]
ks) (a
x:[a]
xs)
         | a
ia -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
k       = ([a] -> [a]) -> ([a], [a]) -> ([a], [a])
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
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) (([a], [a]) -> ([a], [a])) -> ([a], [a]) -> ([a], [a])
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ a -> [a] -> [a] -> ([a], [a])
go (a
ia -> a -> a
forall a. Num a => a -> a -> a
+a
1)    [a]
ks  [a]
xs
         | Bool
otherwise  = ([a] -> [a]) -> ([a], [a]) -> ([a], [a])
forall (a :: * -> * -> *) d b c.
(Morphism a, ObjectPair a d b, ObjectPair a d c) =>
a b c -> a (d, b) (d, c)
second (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) (([a], [a]) -> ([a], [a])) -> ([a], [a]) -> ([a], [a])
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ a -> [a] -> [a] -> ([a], [a])
go (a
ia -> a -> a
forall a. Num a => a -> a -> a
+a
1) (a
ka -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ks) [a]
xs




sortByKey :: Ord a => [(a,b)] -> [b]
sortByKey :: [(a, b)] -> [b]
sortByKey = ((a, b) -> b) -> [(a, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> b
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd ([(a, b)] -> [b]) -> ([(a, b)] -> [(a, b)]) -> [(a, b)] -> [b]
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) -> (a, b) -> Ordering) -> [(a, b)] -> [(a, b)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((a, b) -> a) -> (a, b) -> (a, b) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (a, b) -> a
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 :: Shaded x y -> [Shade x]
trunks Shaded x y
t = case (PseudoAffineWitness x
forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness :: PseudoAffineWitness x, Shaded x y
t) of
  (PseudoAffineWitness SemimanifoldWitness x
SemimanifoldWitness, PlainLeaves [(x, y)]
lvs)
                                    -> [x] -> [Shade x]
forall x.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
[x] -> [Shade x]
pointsCovers ([x] -> [Shade x]) -> [x] -> [Shade x]
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (x, y) -> x
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst((x, y) -> x) -> [(x, y)] -> [x]
forall (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)       -> (Shaded x y -> [Shade x]) -> NonEmpty (Shaded x y) -> [Shade x]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Hask.foldMap Shaded x y -> [Shade x]
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 :: Shaded x y -> Depth
nLeaves (PlainLeaves [(x, y)]
lvs) = [(x, y)] -> Depth
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 :: Shaded x y -> Depth
treeDepth (PlainLeaves [(x, y)]
lvs) = Depth
0
treeDepth (DisjointBranches Depth
_ NonEmpty (Shaded x y)
brs) = Depth
1 Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+ NonEmpty Depth -> Depth
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Shaded x y -> Depth
forall x a. Shaded x a -> Depth
treeDepth(Shaded x y -> Depth) -> NonEmpty (Shaded x y) -> NonEmpty Depth
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)
treeDepth (OverlappingBranches Depth
_ Shade x
_ NonEmpty (DBranch x y)
brs)
     = Depth
1 Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+ NonEmpty Depth -> Depth
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (DBranch' x Depth -> Depth
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (DBranch' x Depth -> Depth)
-> (DBranch x y -> DBranch' x Depth) -> DBranch x y -> 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
. (Shaded x y -> Depth) -> DBranch x y -> DBranch' x Depth
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 Shaded x y -> Depth
forall x a. Shaded x a -> Depth
treeDepth(DBranch x y -> Depth) -> NonEmpty (DBranch x y) -> NonEmpty Depth
forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>NonEmpty (DBranch x y)
brs)





overlappingBranches :: Shade x -> NonEmpty (DBranch x y) -> x`Shaded`y
overlappingBranches :: Shade x -> NonEmpty (DBranch x y) -> Shaded x y
overlappingBranches Shade x
shx NonEmpty (DBranch x y)
brs = Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
forall x y.
Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
OverlappingBranches Depth
n Shade x
shx NonEmpty (DBranch x y)
brs
 where n :: Depth
n = NonEmpty Depth -> Depth
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (NonEmpty Depth -> Depth) -> NonEmpty Depth -> Depth
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (DBranch x y -> Depth) -> NonEmpty (DBranch x y) -> NonEmpty Depth
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' x Depth -> Depth
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (DBranch' x Depth -> Depth)
-> (DBranch x y -> DBranch' x Depth) -> DBranch x y -> 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
. (Shaded x y -> Depth) -> DBranch x y -> DBranch' x Depth
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 Shaded x y -> Depth
forall x a. Shaded x a -> Depth
nLeaves) NonEmpty (DBranch x y)
brs

unsafeFmapLeaves_ :: (x -> x) -> x`Shaded`y -> x`Shaded`y
unsafeFmapLeaves_ :: (x -> x) -> Shaded x y -> Shaded x y
unsafeFmapLeaves_ = ((x, y) -> (x, y)) -> Shaded x y -> Shaded x y
forall x y y'. ((x, y) -> (x, y')) -> Shaded x y -> Shaded x y'
unsafeFmapLeaves (((x, y) -> (x, y)) -> Shaded x y -> Shaded x y)
-> ((x -> x) -> (x, y) -> (x, y))
-> (x -> x)
-> Shaded x y
-> 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
. (x -> x) -> (x, y) -> (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

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

unsafeFmapTree :: (NonEmpty (x,y) -> NonEmpty (ξ,υ))
               -> (Needle' x -> Needle' ξ)
               -> (Shade x -> Shade ξ)
               -> x`Shaded`y -> ξ`Shaded`υ
unsafeFmapTree :: (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 []) = [(ξ, υ)] -> Shaded ξ υ
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) = [(ξ, υ)] -> Shaded ξ υ
forall x y. [(x, y)] -> Shaded x y
PlainLeaves ([(ξ, υ)] -> Shaded ξ υ)
-> (NonEmpty (x, y) -> [(ξ, υ)]) -> NonEmpty (x, y) -> Shaded ξ υ
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 (ξ, υ) -> [(ξ, υ)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty (ξ, υ) -> [(ξ, υ)])
-> (NonEmpty (x, y) -> NonEmpty (ξ, υ))
-> NonEmpty (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
. NonEmpty (x, y) -> NonEmpty (ξ, υ)
f (NonEmpty (x, y) -> Shaded ξ υ) -> NonEmpty (x, y) -> Shaded ξ υ
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ [(x, y)] -> NonEmpty (x, y)
forall a. [a] -> NonEmpty a
NE.fromList [(x, y)]
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' = (NonEmpty (x, y) -> NonEmpty (ξ, υ))
-> (Needle' x -> Needle' ξ)
-> (Shade x -> Shade ξ)
-> Shaded x y
-> Shaded ξ υ
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 (Shaded x y -> Shaded ξ υ)
-> NonEmpty (Shaded x y) -> NonEmpty (Shaded ξ υ)
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 Depth -> NonEmpty (Shaded ξ υ) -> Shaded ξ υ
forall x y. Depth -> NonEmpty (Shaded x y) -> Shaded x y
DisjointBranches (NonEmpty Depth -> Depth
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (NonEmpty Depth -> Depth) -> NonEmpty Depth -> Depth
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Shaded ξ υ -> Depth
forall x a. Shaded x a -> Depth
nLeaves(Shaded ξ υ -> Depth) -> NonEmpty (Shaded ξ υ) -> NonEmpty Depth
forall (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' = (DBranch x y -> DBranch ξ υ)
-> NonEmpty (DBranch x y) -> NonEmpty (DBranch ξ υ)
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)
                      -> Needle' ξ -> Hourglass (Shaded ξ υ) -> DBranch ξ υ
forall x c. Needle' x -> Hourglass c -> DBranch' x c
DBranch (Needle' x -> Needle' ξ
fn Needle' x
dir) ((NonEmpty (x, y) -> NonEmpty (ξ, υ))
-> (Needle' x -> Needle' ξ)
-> (Shade x -> Shade ξ)
-> Shaded x y
-> Shaded ξ υ
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(Shaded x y -> Shaded ξ υ)
-> Hourglass (Shaded x y) -> Hourglass (Shaded ξ υ)
forall (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 Shade ξ -> NonEmpty (DBranch ξ υ) -> Shaded ξ υ
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 :: Shaded x y -> [Twig x y]
allTwigs Shaded x y
tree = Depth -> Shaded x y -> [Twig x y] -> [Twig x y]
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)
         = (Depth, [(Depth, Shaded x y)] -> [(Depth, Shaded x y)])
-> [(Depth, Shaded x y)] -> [(Depth, Shaded x y)]
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd (((Depth, [(Depth, Shaded x y)] -> [(Depth, Shaded x y)])
 -> Shaded x y
 -> (Depth, [(Depth, Shaded x y)] -> [(Depth, Shaded x y)]))
-> (Depth, [(Depth, Shaded x y)] -> [(Depth, Shaded x y)])
-> NonEmpty (Shaded x y)
-> (Depth, [(Depth, Shaded x y)] -> [(Depth, Shaded x y)])
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₀'Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+Shaded x y -> Depth
forall x a. Shaded x a -> Depth
nLeaves Shaded x y
br, [(Depth, Shaded x y)] -> [(Depth, Shaded x y)]
prev ([(Depth, Shaded x y)] -> [(Depth, Shaded x y)])
-> ([(Depth, Shaded x y)] -> [(Depth, Shaded x y)])
-> [(Depth, Shaded x y)]
-> [(Depth, 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
. Depth
-> Shaded x y -> [(Depth, Shaded x y)] -> [(Depth, Shaded x y)]
go Depth
n₀' Shaded x y
br)) (Depth
n₀,[(Depth, Shaded x y)] -> [(Depth, Shaded x y)]
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)
         = (Depth, [(Depth, Shaded x y)] -> [(Depth, Shaded x y)])
-> [(Depth, Shaded x y)] -> [(Depth, Shaded x y)]
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd (((Depth, [(Depth, Shaded x y)] -> [(Depth, Shaded x y)])
 -> DBranch x y
 -> (Depth, [(Depth, Shaded x y)] -> [(Depth, Shaded x y)]))
-> (Depth, [(Depth, Shaded x y)] -> [(Depth, Shaded x y)])
-> [DBranch x y]
-> (Depth, [(Depth, Shaded x y)] -> [(Depth, Shaded x y)])
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₀'Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+Shaded x y -> Depth
forall x a. Shaded x a -> Depth
nLeaves Shaded x y
topDepth -> Depth -> Depth
forall a. Num a => a -> a -> a
+Shaded x y -> Depth
forall x a. Shaded x a -> Depth
nLeaves Shaded x y
bot
                             , [(Depth, Shaded x y)] -> [(Depth, Shaded x y)]
prev ([(Depth, Shaded x y)] -> [(Depth, Shaded x y)])
-> ([(Depth, Shaded x y)] -> [(Depth, Shaded x y)])
-> [(Depth, Shaded x y)]
-> [(Depth, 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
. Depth
-> Shaded x y -> [(Depth, Shaded x y)] -> [(Depth, Shaded x y)]
go Depth
n₀' Shaded x y
top ([(Depth, Shaded x y)] -> [(Depth, Shaded x y)])
-> ([(Depth, Shaded x y)] -> [(Depth, Shaded x y)])
-> [(Depth, Shaded x y)]
-> [(Depth, 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
. Depth
-> Shaded x y -> [(Depth, Shaded x y)] -> [(Depth, Shaded x y)]
go (Depth
n₀'Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+Shaded x y -> Depth
forall x a. Shaded x a -> Depth
nLeaves Shaded x y
top) Shaded x y
bot) )
                        (Depth
n₀,[(Depth, Shaded x y)] -> [(Depth, Shaded x y)]
forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id) ([DBranch x y]
 -> (Depth, [(Depth, Shaded x y)] -> [(Depth, Shaded x y)]))
-> [DBranch x y]
-> (Depth, [(Depth, Shaded x y)] -> [(Depth, Shaded x y)])
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ NonEmpty (DBranch x y) -> [DBranch x y]
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)(Depth, Shaded x y)
-> [(Depth, Shaded x y)] -> [(Depth, Shaded x y)]
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 :: Shaded x y -> [(Twig x y, TwigEnviron x y)]
twigsWithEnvirons = Writer [(Twig x y, TwigEnviron x y)] (Shaded x y)
-> [(Twig x y, TwigEnviron x y)]
forall w a. Writer w a -> w
execWriter (Writer [(Twig x y, TwigEnviron x y)] (Shaded x y)
 -> [(Twig x y, TwigEnviron x y)])
-> (Shaded x y
    -> Writer [(Twig x y, TwigEnviron x y)] (Shaded x y))
-> Shaded x y
-> [(Twig x y, TwigEnviron 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
. ((Twig x y, TwigEnviron x y)
 -> Writer [(Twig x y, TwigEnviron x y)] (Shaded x y))
-> Shaded x y -> Writer [(Twig x y, TwigEnviron x y)] (Shaded x y)
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 ((Shaded x y, [(Twig x y, TwigEnviron x y)])
-> Writer [(Twig x y, TwigEnviron x y)] (Shaded x y)
forall (m :: * -> *) a w. Monad m => (a, w) -> WriterT w m a
writer ((Shaded x y, [(Twig x y, TwigEnviron x y)])
 -> Writer [(Twig x y, TwigEnviron x y)] (Shaded x y))
-> ((Twig x y, TwigEnviron x y)
    -> (Shaded x y, [(Twig x y, TwigEnviron x y)]))
-> (Twig x y, TwigEnviron x y)
-> Writer [(Twig x y, TwigEnviron x y)] (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
. (Twig x y -> Shaded x y
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd(Twig x y -> Shaded x y)
-> ((Twig x y, TwigEnviron x y) -> Twig x y)
-> (Twig x y, TwigEnviron x y)
-> 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
.(Twig x y, TwigEnviron x y) -> Twig x y
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst((Twig x y, TwigEnviron x y) -> Shaded x y)
-> ((Twig x y, TwigEnviron x y) -> [(Twig x y, TwigEnviron x y)])
-> (Twig x y, TwigEnviron x y)
-> (Shaded x y, [(Twig x y, TwigEnviron x y)])
forall (a :: * -> * -> *) b c c'.
(PreArrow a, Object a b, ObjectPair a c c') =>
a b c -> a b c' -> a b (c, c')
&&&(Twig x y, TwigEnviron x y) -> [(Twig x y, TwigEnviron x y)]
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 :: ((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 = (f (Shaded x y), Bool) -> f (Shaded x y)
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst ((f (Shaded x y), Bool) -> f (Shaded x y))
-> (Shaded x y -> (f (Shaded x y), Bool))
-> Shaded x y
-> f (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
. PseudoAffineWitness x
-> TwigEnviron x y -> Twig x y -> (f (Shaded x y), Bool)
go PseudoAffineWitness x
forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness [] (Twig x y -> (f (Shaded x y), Bool))
-> (Shaded x y -> Twig x y) -> Shaded x y -> (f (Shaded x y), Bool)
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) = ( (NonEmpty (Shaded x y) -> Shaded x y)
-> f (NonEmpty (Shaded x y)) -> f (Shaded x y)
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 (Depth -> NonEmpty (Shaded x y) -> Shaded x y
forall x y. Depth -> NonEmpty (Shaded x y) -> Shaded x y
DisjointBranches Depth
nlvs)
                                                   (f (NonEmpty (Shaded x y)) -> f (Shaded x y))
-> (NonEmpty (Twig x y) -> f (NonEmpty (Shaded x y)))
-> NonEmpty (Twig x y)
-> f (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
. (Twig x y -> f (Shaded x y))
-> NonEmpty (Twig x y) -> f (NonEmpty (Shaded x y))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
Hask.traverse ((f (Shaded x y), Bool) -> f (Shaded x y)
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst ((f (Shaded x y), Bool) -> f (Shaded x y))
-> (Twig x y -> (f (Shaded x y), Bool))
-> Twig x y
-> f (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
. PseudoAffineWitness x
-> TwigEnviron x y -> Twig x y -> (f (Shaded x y), Bool)
go PseudoAffineWitness x
sw [])
                                                   (NonEmpty (Twig x y) -> f (Shaded x y))
-> NonEmpty (Twig x y) -> f (Shaded x y)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ NonEmpty Depth -> NonEmpty (Shaded x y) -> NonEmpty (Twig x y)
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 = (Depth -> Shaded x y -> Depth)
-> Depth -> NonEmpty (Shaded x y) -> NonEmpty Depth
forall (f :: * -> *) b a.
Foldable f =>
(b -> a -> b) -> b -> f a -> NonEmpty b
NE.scanl (\Depth
i -> (Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+Depth
i) (Depth -> Depth) -> (Shaded x y -> Depth) -> Shaded x y -> 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
. Shaded x y -> Depth
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
                         ((Twig x y, TwigEnviron x y) -> f (Shaded x y))
-> (Twig x y, TwigEnviron x y) -> f (Shaded x y)
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, (Twig x y -> TwigEnviron x y) -> TwigEnviron x y -> TwigEnviron x y
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Hask.foldMap (\(Depth
io,Shaded x y
te)
                                         -> (Depth -> Depth) -> Twig x y -> Twig 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 (Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+Depth
io) (Twig x y -> Twig x y) -> TwigEnviron x y -> TwigEnviron x y
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 -> ([DBranch x y] -> Shaded x y) -> f [DBranch x y] -> f (Shaded x y)
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 (Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
forall x y.
Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
OverlappingBranches Depth
nlvs Shade x
rob (NonEmpty (DBranch x y) -> Shaded x y)
-> ([DBranch x y] -> NonEmpty (DBranch x y))
-> [DBranch x y]
-> 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
. [DBranch x y] -> NonEmpty (DBranch x y)
forall a. [a] -> NonEmpty a
NE.fromList) f [DBranch x y]
dR
                  , Bool
False )
        where descentResult :: OuterMaybeT f [DBranch x y]
descentResult = ((Depth, (Needle' x, Shaded x y))
 -> [(Depth, (Needle' x, Shaded x y))]
 -> OuterMaybeT f (Shaded x y))
-> [DBranch x y] -> OuterMaybeT f [DBranch x y]
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 ([DBranch x y] -> OuterMaybeT f [DBranch x y])
-> [DBranch x y] -> OuterMaybeT f [DBranch x y]
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ NonEmpty (DBranch x y) -> [DBranch x y]
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₀Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+Depth
io, Shaded x y
ty) of
                                   (f (Shaded x y)
_, Bool
True) -> OuterMaybeT f (Shaded x y)
forall (f :: * -> *) a. OuterMaybeT f a
OuterNothing
                                   (f (Shaded x y)
down, Bool
_) -> f (Shaded x y) -> OuterMaybeT f (Shaded x y)
forall (f :: * -> *) a. f a -> OuterMaybeT f a
OuterJust f (Shaded x y)
down
               where envi'' :: TwigEnviron x y
envi'' = (Twig x y -> Bool) -> TwigEnviron x y -> TwigEnviron x y
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 (Twig x y -> Shaded x y
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd (Twig x y -> Shaded x y)
-> (Shaded x y -> Bool) -> Twig x y -> Bool
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
>>> Shaded x y -> [Shade x]
forall x y.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
Shaded x y -> [Shade x]
trunks (Shaded x y -> [Shade x])
-> ([Shade x] -> Bool) -> Shaded x y -> Bool
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
cex -> x -> Maybe (Needle x)
forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
robc
                                                qq :: Scalar (Needle x)
qq = Needle' x
vyNeedle' x -> Needle x -> Scalar (Needle x)
forall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^Needle x
δyenv
                                            in ℝ
Scalar (Needle x)
qq ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
> -ℝ
1
                                       ) TwigEnviron x y
envi'
                              TwigEnviron x y -> TwigEnviron x y -> TwigEnviron x y
forall a. [a] -> [a] -> [a]
++ ((Depth, (Needle' x, Shaded x y)) -> Twig x y)
-> [(Depth, (Needle' x, Shaded x y))] -> TwigEnviron x y
forall a b. (a -> b) -> [a] -> [b]
map ((Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+Depth
i₀)(Depth -> Depth)
-> ((Needle' x, Shaded x y) -> Shaded x y)
-> (Depth, (Needle' x, Shaded x y))
-> Twig x y
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')
***(Needle' x, Shaded x y) -> Shaded x y
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 (Twig x y -> TwigEnviron x y) -> TwigEnviron x y -> TwigEnviron x y
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)
_))
                  = (Depth -> Depth) -> Twig x y -> Twig 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 (Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+Depth
i₀e) (Twig x y -> Twig x y) -> TwigEnviron x y -> TwigEnviron x y
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 x -> x -> Maybe (Needle x)
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 ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
> -ℝ
1]
                       TwigEnviron x y -> TwigEnviron x y -> TwigEnviron x y
forall a. [a] -> [a] -> [a]
++ [(Shaded x y -> Depth
forall x a. Shaded x a -> Depth
nLeaves Shaded x y
bdc₁, Shaded x y
bdc₂) | ℝ
Scalar (Needle x)
overlap ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
< ℝ
1]
                      where overlap :: Scalar (Needle x)
overlap = Needle' x
bdirNeedle' x -> Needle x -> Scalar (Needle x)
forall 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 ((Twig x y, TwigEnviron x y) -> f (Shaded x y))
-> (Twig x y, TwigEnviron x y) -> f (Shaded x y)
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)
               = (Twig x y -> TwigEnviron x y)
-> NonEmpty (Twig x y) -> TwigEnviron x y
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Hask.foldMap (\(Depth
i₀,Shaded x y
st) -> (Depth -> Depth) -> Twig x y -> Twig 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 (Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+Depth
i₀) (Twig x y -> Twig x y) -> TwigEnviron x y -> TwigEnviron x y
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)
                    (NonEmpty (Twig x y) -> TwigEnviron x y)
-> NonEmpty (Twig x y) -> TwigEnviron x y
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ NonEmpty Depth -> NonEmpty (Shaded x y) -> NonEmpty (Twig x y)
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 = (Depth -> Shaded x y -> Depth)
-> Depth -> NonEmpty (Shaded x y) -> NonEmpty Depth
forall (f :: * -> *) b a.
Foldable f =>
(b -> a -> b) -> b -> f a -> NonEmpty b
NE.scanl (\Depth
i -> (Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+Depth
i) (Depth -> Depth) -> (Shaded x y -> Depth) -> Shaded x y -> 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
. Shaded x y -> Depth
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₀ x -> x -> Maybe (Needle 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₂))
                =  ((Bool -> [()]
forall (m :: * -> *) (k :: * -> * -> *).
(MonadPlus m k, Arrow k (->), Function k, UnitObject k ~ (),
 Object k Bool) =>
k Bool (m ())
guard (ℝ
Scalar (Needle x)
overlap ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
> -ℝ
1)) [()] -> TwigEnviron x y -> TwigEnviron x y
forall (k :: * -> * -> *) (m :: * -> *) b a.
(WellPointed k, Monad m k, ObjectPair k b (UnitObject k),
 ObjectPair k (m b) (UnitObject k),
 ObjectPair k (UnitObject k) (m b), ObjectPair k b a,
 ObjectPair k a b, Object k (m (a, b)), ObjectPair k (m a) (m b),
 ObjectPoint k (m a)) =>
m a -> k (m b) (m b)
>> PseudoAffineWitness x -> x -> Shaded x y -> TwigEnviron x y
twigProximæ PseudoAffineWitness x
sw x
x₀ Shaded x y
bdc₁)
                TwigEnviron x y -> TwigEnviron x y -> TwigEnviron x y
forall a. [a] -> [a] -> [a]
++ ((Bool -> [()]
forall (m :: * -> *) (k :: * -> * -> *).
(MonadPlus m k, Arrow k (->), Function k, UnitObject k ~ (),
 Object k Bool) =>
k Bool (m ())
guard (ℝ
Scalar (Needle x)
overlap ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
< ℝ
1)) [()] -> TwigEnviron x y -> TwigEnviron x y
forall (k :: * -> * -> *) (m :: * -> *) b a.
(WellPointed k, Monad m k, ObjectPair k b (UnitObject k),
 ObjectPair k (m b) (UnitObject k),
 ObjectPair k (UnitObject k) (m b), ObjectPair k b a,
 ObjectPair k a b, Object k (m (a, b)), ObjectPair k (m a) (m b),
 ObjectPoint k (m a)) =>
m a -> k (m b) (m b)
>> (Depth -> Depth) -> Twig x y -> Twig 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 (Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+Shaded x y -> Depth
forall x a. Shaded x a -> Depth
nLeaves Shaded x y
bdc₁)(Twig x y -> Twig x y) -> TwigEnviron x y -> TwigEnviron x y
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
bdirNeedle' x -> Needle x -> Scalar (Needle x)
forall 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 ((Depth, DBranch x y) -> Maybe (TwigEnviron x y))
-> NonEmpty (Depth, DBranch x y)
-> Maybe (NonEmpty (TwigEnviron x y))
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) -> TwigEnviron x y -> Maybe (TwigEnviron x y)
forall (f :: * -> *) a x y.
Alternative f =>
[(a, Shaded x y)] -> f [(a, Shaded x y)]
noLeaf (TwigEnviron x y -> Maybe (TwigEnviron x y))
-> TwigEnviron x y -> Maybe (TwigEnviron x y)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (Depth -> Depth) -> Twig x y -> Twig 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(Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+Depth
i₀)(Twig x y -> Twig x y) -> TwigEnviron x y -> TwigEnviron x y
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)
                                 (NonEmpty (Depth, DBranch x y)
 -> Maybe (NonEmpty (TwigEnviron x y)))
-> NonEmpty (Depth, DBranch x y)
-> Maybe (NonEmpty (TwigEnviron x y))
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ NonEmpty Depth
-> NonEmpty (DBranch x y) -> NonEmpty (Depth, DBranch x y)
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 -> NonEmpty (TwigEnviron x y) -> TwigEnviron x y
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)]
_)] = f [(a, Shaded x y)]
forall (f :: * -> *) a. Alternative f => f a
empty
              noLeaf [(a, Shaded x y)]
bqs = [(a, Shaded x y)] -> f [(a, Shaded x y)]
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 = (Depth -> DBranch x y -> Depth)
-> Depth -> NonEmpty (DBranch x y) -> NonEmpty Depth
forall (f :: * -> *) b a.
Foldable f =>
(b -> a -> b) -> b -> f a -> NonEmpty b
NE.scanl (\Depth
i -> (Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+Depth
i) (Depth -> Depth) -> (DBranch x y -> Depth) -> DBranch x y -> 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
. [Depth] -> Depth
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Depth] -> Depth)
-> (DBranch x y -> [Depth]) -> DBranch x y -> 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
. (Shaded x y -> Depth) -> [Shaded x y] -> [Depth]
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 Shaded x y -> Depth
forall x a. Shaded x a -> Depth
nLeaves ([Shaded x y] -> [Depth])
-> (DBranch x y -> [Shaded x y]) -> DBranch x y -> [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
. DBranch x y -> [Shaded x y]
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 = (Twig x y, TwigEnviron x y) -> (Twig x y, TwigEnviron x y)
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 :: Shaded x y -> [Shade' (x, y)]
completeTopShading (PlainLeaves [(x, y)]
plvs) = case ( DualSpaceWitness (Needle x)
forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualNeedleWitness x
                                             , DualSpaceWitness (Needle y)
forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualNeedleWitness y ) of
       (DualSpaceWitness (Needle x)
DualSpaceWitness, DualSpaceWitness (Needle y)
DualSpaceWitness)
          -> [(x, y)] -> [Shade' (x, y)]
forall x.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
[x] -> [Shade' x]
pointsShade's [(x, y)]
plvs
completeTopShading (DisjointBranches Depth
_ NonEmpty (Shaded x y)
bqs)
                     = Depth -> [Shade' (x, y)] -> [Shade' (x, y)]
forall a. Depth -> [a] -> [a]
take Depth
1 ([Shade' (x, y)] -> [Shade' (x, y)])
-> (Shaded x y -> [Shade' (x, y)]) -> Shaded x y -> [Shade' (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
. Shaded x y -> [Shade' (x, 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 -> [Shade' (x, y)]) -> [Shaded x y] -> [Shade' (x, y)]
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 (Shaded x y) -> [Shaded x y]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Shaded x y)
bqs
completeTopShading Shaded x y
t = case ( DualSpaceWitness (Needle x)
forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualNeedleWitness x
                            , DualSpaceWitness (Needle y)
forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualNeedleWitness y ) of
       (DualSpaceWitness (Needle x)
DualSpaceWitness, DualSpaceWitness (Needle y)
DualSpaceWitness)
          -> [(x, y)] -> [Shade' (x, y)]
forall x.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
[x] -> [Shade' x]
pointsCover's ([(x, y)] -> [Shade' (x, y)]) -> [(x, y)] -> [Shade' (x, y)]
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Shaded x y -> [(x, y)]
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 :: Norm v -> Variance v -> v -+> v
transferAsNormsDo = case DualSpaceWitness v
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) -> LinearFunction (Scalar v) (DualVector v) v
DualVector v -+> DualVector (DualVector v)
n LinearFunction (Scalar v) (DualVector v) v
-> LinearFunction (Scalar v) v (DualVector v) -> v -+> v
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. LinearFunction (Scalar v) v (DualVector v)
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 :: (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 = () -> f (Shaded x y) -> f (Shaded x y)
seq (Shaded x y -> ()
assert_onlyToplevDisjoint Shaded x y
tr)
                    (f (Shaded x y) -> f (Shaded x y))
-> f (Shaded x y) -> f (Shaded x y)
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 (DualSpaceWitness (Needle x)
forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness::DualNeedleWitness x
                            ,DualSpaceWitness (Needle y)
forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness::DualNeedleWitness y
                            ,PseudoAffineWitness y
forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness::PseudoAffineWitness y)
                            (Shaded x y -> [Shade' (x, 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)
          = f (Shaded x y)
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)
               [sha :: Shade' (x, y)
sha@(Shade' (_,yc₀) expa₀)] Shaded x y
t = ((x, (Shade' y, LinearMap ℝ (Needle x) (Needle y))) -> Shaded x y)
-> f (x, (Shade' y, LinearMap ℝ (Needle x) (Needle y)))
-> f (Shaded x y)
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 (f (x, (Shade' y, LinearMap ℝ (Needle x) (Needle y)))
 -> f (Shaded x y))
-> f (x, (Shade' y, LinearMap ℝ (Needle x) (Needle y)))
-> f (Shaded x y)
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'₀ = Norm (Needle x, Needle y) -> Variance (Needle x, Needle y)
forall v. SimpleSpace v => Norm v -> Variance v
dualNorm Norm (Needle x, Needle y)
Metric (x, y)
expa₀
              j₀ :: LocalLinear x y
              j₀ :: LocalLinear x y
j₀ = Variance (Needle x, Needle y) -> LocalLinear x y
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₀) = Norm (Needle x, Needle y) -> (Norm (Needle x), Norm (Needle y))
forall u v.
(SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v) =>
Norm (u, v) -> (Norm u, Norm v)
summandSpaceNorms Norm (Needle x, Needle y)
Metric (x, y)
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)) = ((x, y) -> (x, y)) -> Shaded x y -> Shaded x y
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
ycy -> y -> Maybe (Needle y)
forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.y
yc₀
                     tfm :: Needle y -+> Needle y
tfm = Norm (Needle y) -> Variance (Needle y) -> Needle y -+> Needle y
forall v. LSpace v => Norm v -> Variance v -> v -+> v
transferAsNormsDo Norm (Needle y)
expay₀ (Norm (Needle y) -> Variance (Needle y)
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₀ y -> Needle y -> y
forall x. Semimanifold x => x -> Needle x -> x
.+~^ ((Needle y -+> Needle y
tfm (Needle y -+> Needle y) -> Needle y -> Needle y
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Needle y
δy) Needle y -> Needle y -> Needle y
forall v. AdditiveGroup v => v -> v -> v
^+^ (LinearMap ℝ (Needle x) (Needle y)
jtg LinearMap ℝ (Needle x) (Needle y) -> Needle x -> Needle y
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Needle x
δx) Needle y -> Needle y -> Needle y
forall v. AdditiveGroup v => v -> v -> v
^+^ Needle y
δyc))
                      where Just Needle x
δx = x
xx -> x -> Maybe (Needle x)
forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
xc
                            Just Needle y
δy = y
yy -> y -> Maybe (Needle y)
forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.(y
yc₀y -> Needle y -> y
forall x. Semimanifold x => x -> Needle x -> x
.+~^(LinearMap ℝ (Needle x) (Needle y)
LocalLinear x y
j₀ LinearMap ℝ (Needle x) (Needle y) -> Needle x -> Needle y
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) = NonEmpty () -> ()
forall a. NFData a => a -> ()
rnf (Shaded x y -> ()
assert_connected(Shaded x y -> ()) -> NonEmpty (Shaded x y) -> NonEmpty ()
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)
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)
           = NonEmpty () -> ()
forall a. NFData a => a -> ()
rnf ((Shaded x y -> ()) -> DBranch x y -> ()
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Hask.foldMap Shaded x y -> ()
assert_connected(DBranch x y -> ()) -> NonEmpty (DBranch x y) -> NonEmpty ()
forall (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 :: (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 = ((Twig x y, TwigEnviron x y) -> f (Shaded x y))
-> Shaded x y -> f (Shaded x y)
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)
forall μ. (Twig x y, μ) -> f (Shaded x y)
locFlex
 where locFlex :: ∀ μ . ((Int, x`Shaded`y), μ) -> f (x`Shaded`y)
       locFlex :: (Twig x y, μ) -> f (Shaded x y)
locFlex ((Depth
_,Shaded x y
lsh), μ
_) = (Shade' (x, y) -> f (x, (Shade' y, LocalLinear x y)))
-> Shaded x y -> f (Shaded x y)
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 :: Shaded x y -> Shaded x (y, [Depth])
seekPotentialNeighbours Shaded x y
tree = Shaded x y -> NonEmpty [Depth] -> Shaded x (y, [Depth])
forall x w y. Shaded x w -> NonEmpty y -> Shaded x (w, y)
zipTreeWithList Shaded x y
tree
                     (NonEmpty [Depth] -> Shaded x (y, [Depth]))
-> NonEmpty [Depth] -> Shaded x (y, [Depth])
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ case ((x, y), [Depth]) -> [Depth]
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd(((x, y), [Depth]) -> [Depth]) -> [((x, y), [Depth])] -> [[Depth]]
forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>Shaded x y -> [((x, y), [Depth])]
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]
n[Depth] -> [[Depth]] -> NonEmpty [Depth]
forall a. a -> [a] -> NonEmpty a
:|[[Depth]]
ns

leavesWithPotentialNeighbours :: ∀ x y
            . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x))
                => x`Shaded`y -> [((x,y), [Int])]
leavesWithPotentialNeighbours :: Shaded x y -> [((x, y), [Depth])]
leavesWithPotentialNeighbours = (((x, y), ([Wall x], [Depth])) -> ((x, y), [Depth]))
-> [((x, y), ([Wall x], [Depth]))] -> [((x, y), [Depth])]
forall a b. (a -> b) -> [a] -> [b]
map ((([Wall x], [Depth]) -> [Depth])
-> ((x, y), ([Wall x], [Depth])) -> ((x, y), [Depth])
forall (a :: * -> * -> *) d b c.
(Morphism a, ObjectPair a d b, ObjectPair a d c) =>
a b c -> a (d, b) (d, c)
second ([Wall x], [Depth]) -> [Depth]
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd) ([((x, y), ([Wall x], [Depth]))] -> [((x, y), [Depth])])
-> (Shaded x y -> [((x, y), ([Wall x], [Depth]))])
-> Shaded x y
-> [((x, y), [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
. PseudoAffineWitness x
-> Depth
-> Depth
-> [Wall x]
-> Shaded x y
-> [((x, y), ([Wall x], [Depth]))]
go PseudoAffineWitness x
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 Wall x -> (Wall x -> Wall x) -> Wall x
forall a b. a -> (a -> b) -> b
& (ℝ -> Identity ℝ) -> Wall x -> Identity (Wall x)
forall x. Lens' (Wall x) (Scalar (Needle x))
wallDistance ((ℝ -> Identity ℝ) -> Wall x -> Identity (Wall x))
-> ℝ -> Wall x -> Wall x
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
xx -> x -> Maybe (Needle x)
forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.Wall x
wallWall x -> Getting x (Wall x) x -> x
forall s a. s -> Getting a s a -> a
^.Getting x (Wall x) x
forall x. Lens' (Wall x) x
wallAnchor]
                         , let d :: Scalar (Needle x)
d = (Wall x
wallWall x
-> Getting (DualVector (Needle x)) (Wall x) (DualVector (Needle x))
-> DualVector (Needle x)
forall s a. s -> Getting a s a -> a
^.Getting (DualVector (Needle x)) (Wall x) (DualVector (Needle x))
forall x. Lens' (Wall x) (Needle' x)
wallNormal)DualVector (Needle x) -> Needle x -> Scalar (Needle x)
forall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^Needle x
vw
                         , ℝ
Scalar (Needle x)
d ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
< Wall x
wallWall x -> Getting ℝ (Wall x) ℝ -> ℝ
forall s a. s -> Getting a s a -> a
^.Getting ℝ (Wall x) ℝ
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)
         = (Depth,
 [((x, y), ([Wall x], [Depth]))] -> [((x, y), ([Wall x], [Depth]))])
-> [((x, y), ([Wall x], [Depth]))]
-> [((x, y), ([Wall x], [Depth]))]
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd (((Depth,
  [((x, y), ([Wall x], [Depth]))] -> [((x, y), ([Wall x], [Depth]))])
 -> Shaded x y
 -> (Depth,
     [((x, y), ([Wall x], [Depth]))]
     -> [((x, y), ([Wall x], [Depth]))]))
-> (Depth,
    [((x, y), ([Wall x], [Depth]))] -> [((x, y), ([Wall x], [Depth]))])
-> NonEmpty (Shaded x y)
-> (Depth,
    [((x, y), ([Wall x], [Depth]))] -> [((x, y), ([Wall x], [Depth]))])
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₀'Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+Shaded x y -> Depth
forall x a. Shaded x a -> Depth
nLeaves Shaded x y
br
                                          , [((x, y), ([Wall x], [Depth]))] -> [((x, y), ([Wall x], [Depth]))]
prev ([((x, y), ([Wall x], [Depth]))]
 -> [((x, y), ([Wall x], [Depth]))])
-> ([((x, y), ([Wall x], [Depth]))]
    -> [((x, y), ([Wall x], [Depth]))])
-> [((x, y), ([Wall x], [Depth]))]
-> [((x, y), ([Wall x], [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
. (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
br[((x, y), ([Wall x], [Depth]))]
-> [((x, y), ([Wall x], [Depth]))]
-> [((x, y), ([Wall x], [Depth]))]
forall a. [a] -> [a] -> [a]
++)))
                        (Depth
n₀,[((x, y), ([Wall x], [Depth]))] -> [((x, y), ([Wall x], [Depth]))]
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 ([((x, y), ([Wall x], [Depth]))]
 -> [((x, y), ([Wall x], [Depth]))])
-> [((x, y), ([Wall x], [Depth]))]
-> [((x, y), ([Wall x], [Depth]))]
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (Depth,
 [((x, y), ([Wall x], [Depth]))] -> [((x, y), ([Wall x], [Depth]))])
-> [((x, y), ([Wall x], [Depth]))]
-> [((x, y), ([Wall x], [Depth]))]
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd
             (((Depth,
  [((x, y), ([Wall x], [Depth]))] -> [((x, y), ([Wall x], [Depth]))])
 -> ((Depth, (DualVector (Needle x), Shaded x y)),
     [(Depth, (DualVector (Needle x), Shaded x y))])
 -> (Depth,
     [((x, y), ([Wall x], [Depth]))]
     -> [((x, y), ([Wall x], [Depth]))]))
-> (Depth,
    [((x, y), ([Wall x], [Depth]))] -> [((x, y), ([Wall x], [Depth]))])
-> [((Depth, (DualVector (Needle x), Shaded x y)),
     [(Depth, (DualVector (Needle x), Shaded x y))])]
-> (Depth,
    [((x, y), ([Wall x], [Depth]))] -> [((x, y), ([Wall x], [Depth]))])
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, (DualVector (Needle x), Shaded x y)),
    [(Depth, (DualVector (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]))]
forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id) ([((Depth, (DualVector (Needle x), Shaded x y)),
   [(Depth, (DualVector (Needle x), Shaded x y))])]
 -> (Depth,
     [((x, y), ([Wall x], [Depth]))]
     -> [((x, y), ([Wall x], [Depth]))]))
-> ([DBranch x y]
    -> [((Depth, (DualVector (Needle x), Shaded x y)),
         [(Depth, (DualVector (Needle x), Shaded x y))])])
-> [DBranch x y]
-> (Depth,
    [((x, y), ([Wall x], [Depth]))] -> [((x, y), ([Wall x], [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
. Depth
-> [DBranch x y]
-> [((Depth, (DualVector (Needle x), Shaded x y)),
     [(Depth, (DualVector (Needle x), Shaded x y))])]
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 ([DBranch x y]
 -> (Depth,
     [((x, y), ([Wall x], [Depth]))]
     -> [((x, y), ([Wall x], [Depth]))]))
-> [DBranch x y]
-> (Depth,
    [((x, y), ([Wall x], [Depth]))] -> [((x, y), ([Wall x], [Depth]))])
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ NonEmpty (DBranch x y) -> [DBranch x y]
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, (DualVector (Needle x), Shaded x y)),
    [(Depth, (DualVector (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,(DualVector (Needle x)
thisDir,Shaded x y
br)),[(Depth, (DualVector (Needle x), Shaded x y))]
otherDirs)
                    = ( Depth
n₀'Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+Shaded x y -> Depth
forall x a. Shaded x a -> Depth
nLeaves Shaded x y
br
                      , [((x, y), ([Wall x], [Depth]))] -> [((x, y), ([Wall x], [Depth]))]
prev ([((x, y), ([Wall x], [Depth]))]
 -> [((x, y), ([Wall x], [Depth]))])
-> ([((x, y), ([Wall x], [Depth]))]
    -> [((x, y), ([Wall x], [Depth]))])
-> [((x, y), ([Wall x], [Depth]))]
-> [((x, y), ([Wall x], [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
. (PseudoAffineWitness x
-> Depth
-> Depth
-> [Wall x]
-> Shaded x y
-> [((x, y), ([Wall x], [Depth]))]
go PseudoAffineWitness x
pw (Depth
depthDepth -> Depth -> Depth
forall a. Num a => a -> a -> a
+Depth
1) Depth
n₀'
                                   ([Wall x]
newWalls [Wall x] -> [Wall x] -> [Wall x]
forall a. [a] -> [a] -> [a]
++ (Wall x -> Wall x
updWall(Wall x -> Wall x) -> [Wall x] -> [Wall x]
forall (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 [((x, y), ([Wall x], [Depth]))]
-> [((x, y), ([Wall x], [Depth]))]
-> [((x, y), ([Wall x], [Depth]))]
forall a. [a] -> [a] -> [a]
++) )
               where newWalls :: [Wall x]
newWalls = [ (Depth, (Depth, Depth))
-> x -> DualVector (Needle x) -> Scalar (Needle x) -> Wall x
forall x.
(Depth, (Depth, Depth))
-> x -> Needle' x -> Scalar (Needle x) -> Wall x
Wall (Depth
depth,(Depth
iDir,Depth
iDir'))
                                       x
brCtr
                                       (DualVector (Needle x)
thisDirDualVector (Needle x)
-> DualVector (Needle x) -> DualVector (Needle x)
forall v. AdditiveGroup v => v -> v -> v
^-^DualVector (Needle x)
otherDir)
                                       (ℝ
1ℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
0)
                                | (Depth
iDir',(DualVector (Needle x)
otherDir,Shaded x y
_)) <- [(Depth, (DualVector (Needle x), Shaded x y))]
otherDirs ]
                     updWall :: Wall x -> Wall x
updWall Wall x
wall = Wall x
wall Wall x -> (Wall x -> Wall x) -> Wall x
forall a b. a -> (a -> b) -> b
& (ℝ -> Identity ℝ) -> Wall x -> Identity (Wall x)
forall x. Lens' (Wall x) (Scalar (Needle x))
wallDistance ((ℝ -> Identity ℝ) -> Wall x -> Identity (Wall x))
-> (ℝ -> ℝ) -> Wall x -> Wall x
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
brCtrx -> x -> Maybe (Needle x)
forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.Wall x
wallWall x -> Getting x (Wall x) x -> x
forall s a. s -> Getting a s a -> a
^.Getting x (Wall x) x
forall x. Lens' (Wall x) x
wallAnchor
                            bcDist :: Scalar (Needle x)
bcDist = (Wall x
wallWall x
-> Getting (DualVector (Needle x)) (Wall x) (DualVector (Needle x))
-> DualVector (Needle x)
forall s a. s -> Getting a s a -> a
^.Getting (DualVector (Needle x)) (Wall x) (DualVector (Needle x))
forall x. Lens' (Wall x) (Needle' x)
wallNormal)DualVector (Needle x) -> Needle x -> Scalar (Needle x)
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]
newGroups[Depth] -> [Depth] -> [Depth]
forall 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)
                                      = (Wall x -> Bool) -> [Wall x] -> ([Wall x], [Wall x])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((Depth -> Depth -> Bool
forall a. Ord a => a -> a -> Bool
<Depth
depth) (Depth -> Bool) -> (Wall x -> Depth) -> Wall x -> Bool
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, (Depth, Depth)) -> Depth
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst ((Depth, (Depth, Depth)) -> Depth)
-> (Wall x -> (Depth, (Depth, Depth))) -> Wall x -> 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
. Wall x -> (Depth, (Depth, Depth))
forall x. Wall x -> (Depth, (Depth, Depth))
_wallID) [Wall x]
allWalls
                                     newGroups :: [Depth]
newGroups = [[Depth]] -> [Depth]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                                         [ [Depth] -> (Depth, Depth) -> Map (Depth, Depth) [Depth] -> [Depth]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault []
                                              (Wall x
wallWall x
-> Getting (Depth, Depth) (Wall x) (Depth, Depth) -> (Depth, Depth)
forall s a. s -> Getting a s a -> a
^.((Depth, (Depth, Depth))
 -> Const (Depth, Depth) (Depth, (Depth, Depth)))
-> Wall x -> Const (Depth, Depth) (Wall x)
forall x. Lens' (Wall x) (Depth, (Depth, Depth))
wallID(((Depth, (Depth, Depth))
  -> Const (Depth, Depth) (Depth, (Depth, Depth)))
 -> Wall x -> Const (Depth, Depth) (Wall x))
-> (((Depth, Depth) -> Const (Depth, Depth) (Depth, Depth))
    -> (Depth, (Depth, Depth))
    -> Const (Depth, Depth) (Depth, (Depth, Depth)))
-> Getting (Depth, Depth) (Wall x) (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
.((Depth, Depth) -> Const (Depth, Depth) (Depth, Depth))
-> (Depth, (Depth, Depth))
-> Const (Depth, Depth) (Depth, (Depth, Depth))
forall s t a b. Field2 s t a b => Lens s t a b
_2(((Depth, Depth) -> Const (Depth, Depth) (Depth, Depth))
 -> (Depth, (Depth, Depth))
 -> Const (Depth, Depth) (Depth, (Depth, Depth)))
-> (((Depth, Depth) -> Const (Depth, Depth) (Depth, Depth))
    -> (Depth, Depth) -> Const (Depth, Depth) (Depth, Depth))
-> ((Depth, Depth) -> Const (Depth, Depth) (Depth, Depth))
-> (Depth, (Depth, Depth))
-> Const (Depth, Depth) (Depth, (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
.((Depth, Depth) -> Const (Depth, Depth) (Depth, Depth))
-> (Depth, Depth) -> Const (Depth, Depth) (Depth, Depth)
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 = (([Depth] -> [Depth]) -> [Depth] -> [Depth]
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$[]) (([Depth] -> [Depth]) -> [Depth])
-> Map (Depth, Depth) ([Depth] -> [Depth])
-> Map (Depth, Depth) [Depth]
forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> (([Depth] -> [Depth])
 -> ([Depth] -> [Depth]) -> [Depth] -> [Depth])
-> [((Depth, Depth), [Depth] -> [Depth])]
-> Map (Depth, Depth) ([Depth] -> [Depth])
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith ([Depth] -> [Depth]) -> ([Depth] -> [Depth]) -> [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
(.)
                               [ (Wall x
wallWall x
-> Getting (Depth, Depth) (Wall x) (Depth, Depth) -> (Depth, Depth)
forall s a. s -> Getting a s a -> a
^.((Depth, (Depth, Depth))
 -> Const (Depth, Depth) (Depth, (Depth, Depth)))
-> Wall x -> Const (Depth, Depth) (Wall x)
forall x. Lens' (Wall x) (Depth, (Depth, Depth))
wallID(((Depth, (Depth, Depth))
  -> Const (Depth, Depth) (Depth, (Depth, Depth)))
 -> Wall x -> Const (Depth, Depth) (Wall x))
-> (((Depth, Depth) -> Const (Depth, Depth) (Depth, Depth))
    -> (Depth, (Depth, Depth))
    -> Const (Depth, Depth) (Depth, (Depth, Depth)))
-> Getting (Depth, Depth) (Wall x) (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
.((Depth, Depth) -> Const (Depth, Depth) (Depth, Depth))
-> (Depth, (Depth, Depth))
-> Const (Depth, Depth) (Depth, (Depth, Depth))
forall s t a b. Field2 s t a b => Lens s t a b
_2, (Depth
iDepth -> [Depth] -> [Depth]
forall a. a -> [a] -> [a]
:))
                               | (Depth
i,((x, y)
_, ([Wall x]
gsc,[Depth]
_))) <- [Depth]
-> [((x, y), ([Wall x], [Depth]))]
-> [(Depth, ((x, y), ([Wall x], [Depth])))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Depth
n₀..] [((x, y), ([Wall x], [Depth]))]
pts
                               , Wall x
wall <- (Wall x -> Bool) -> [Wall x] -> [Wall x]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((Depth -> Depth -> Bool
forall a. Eq a => a -> a -> Bool
==Depth
depth) (Depth -> Bool) -> (Wall x -> Depth) -> Wall x -> Bool
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, (Depth, Depth)) -> Depth
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst ((Depth, (Depth, Depth)) -> Depth)
-> (Wall x -> (Depth, (Depth, Depth))) -> Wall x -> 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
. Wall x -> (Depth, (Depth, Depth))
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 { GenericTree c b x -> c (x, GenericTree b b x)
treeBranches :: c (x,GenericTree b b x) }
 deriving ((forall x. GenericTree c b x -> Rep (GenericTree c b x) x)
-> (forall x. Rep (GenericTree c b x) x -> GenericTree c b x)
-> Generic (GenericTree c b x)
forall x. Rep (GenericTree c b x) x -> GenericTree c b x
forall x. GenericTree c b x -> Rep (GenericTree c b x) x
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, a -> GenericTree c b b -> GenericTree c b a
(a -> b) -> GenericTree c b a -> GenericTree c b b
(forall a b. (a -> b) -> GenericTree c b a -> GenericTree c b b)
-> (forall a b. a -> GenericTree c b b -> GenericTree c b a)
-> Functor (GenericTree c b)
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
<$ :: 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 :: (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, GenericTree c b a -> Bool
(a -> m) -> GenericTree c b a -> m
(a -> b -> b) -> b -> GenericTree c b a -> b
(forall m. Monoid m => GenericTree c b m -> m)
-> (forall m a. Monoid m => (a -> m) -> GenericTree c b a -> m)
-> (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 a b. (a -> b -> b) -> b -> GenericTree c b a -> b)
-> (forall b a. (b -> a -> b) -> b -> GenericTree c b a -> b)
-> (forall b a. (b -> a -> b) -> b -> GenericTree c b a -> b)
-> (forall a. (a -> a -> a) -> GenericTree c b a -> a)
-> (forall a. (a -> a -> a) -> GenericTree c b a -> a)
-> (forall a. GenericTree c b a -> [a])
-> (forall a. GenericTree c b a -> Bool)
-> (forall a. GenericTree c b a -> Depth)
-> (forall a. Eq a => a -> GenericTree c b a -> Bool)
-> (forall a. Ord a => GenericTree c b a -> a)
-> (forall a. Ord a => GenericTree c b a -> a)
-> (forall a. Num a => GenericTree c b a -> a)
-> (forall a. Num a => GenericTree c b a -> a)
-> Foldable (GenericTree c b)
forall a. Eq a => a -> GenericTree c b a -> Bool
forall a. Num a => GenericTree c b a -> a
forall a. Ord a => GenericTree c b a -> a
forall m. Monoid m => GenericTree c b m -> m
forall a. GenericTree c b a -> Bool
forall a. GenericTree c b a -> Depth
forall a. GenericTree c b a -> [a]
forall a. (a -> a -> a) -> GenericTree c b a -> a
forall m a. Monoid m => (a -> m) -> GenericTree c b a -> m
forall b a. (b -> a -> b) -> b -> GenericTree c b a -> b
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 :: GenericTree c b a -> a
$cproduct :: forall (c :: * -> *) (b :: * -> *) a.
(Foldable c, Foldable b, Num a) =>
GenericTree c b a -> a
sum :: GenericTree c b a -> a
$csum :: forall (c :: * -> *) (b :: * -> *) a.
(Foldable c, Foldable b, Num a) =>
GenericTree c b a -> a
minimum :: GenericTree c b a -> a
$cminimum :: forall (c :: * -> *) (b :: * -> *) a.
(Foldable c, Foldable b, Ord a) =>
GenericTree c b a -> a
maximum :: GenericTree c b a -> a
$cmaximum :: forall (c :: * -> *) (b :: * -> *) a.
(Foldable c, Foldable b, Ord a) =>
GenericTree c b a -> a
elem :: a -> GenericTree c b a -> Bool
$celem :: forall (c :: * -> *) (b :: * -> *) a.
(Foldable c, Foldable b, Eq a) =>
a -> GenericTree c b a -> Bool
length :: GenericTree c b a -> Depth
$clength :: forall (c :: * -> *) (b :: * -> *) a.
(Foldable c, Foldable b) =>
GenericTree c b a -> Depth
null :: GenericTree c b a -> Bool
$cnull :: forall (c :: * -> *) (b :: * -> *) a.
(Foldable c, Foldable b) =>
GenericTree c b a -> Bool
toList :: GenericTree c b a -> [a]
$ctoList :: forall (c :: * -> *) (b :: * -> *) a.
(Foldable c, Foldable b) =>
GenericTree c b a -> [a]
foldl1 :: (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 :: (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' :: (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 :: (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' :: (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 :: (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' :: (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 :: (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 :: GenericTree c b m -> m
$cfold :: forall (c :: * -> *) (b :: * -> *) m.
(Foldable c, Foldable b, Monoid m) =>
GenericTree c b m -> m
Hask.Foldable, Functor (GenericTree c b)
Foldable (GenericTree c b)
Functor (GenericTree c b)
-> Foldable (GenericTree c b)
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> GenericTree c b a -> f (GenericTree c b b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    GenericTree c b (f a) -> f (GenericTree c b a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> GenericTree c b a -> m (GenericTree c b b))
-> (forall (m :: * -> *) a.
    Monad m =>
    GenericTree c b (m a) -> m (GenericTree c b a))
-> Traversable (GenericTree c b)
(a -> f b) -> GenericTree c b a -> f (GenericTree c b 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 (m :: * -> *) a.
Monad m =>
GenericTree c b (m a) -> m (GenericTree c b a)
forall (f :: * -> *) a.
Applicative f =>
GenericTree c b (f a) -> f (GenericTree c b a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> GenericTree c b a -> m (GenericTree c b b)
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 :: 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 :: (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 :: 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 :: (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)
$cp2Traversable :: forall (c :: * -> *) (b :: * -> *).
(Traversable c, Traversable b) =>
Foldable (GenericTree c b)
$cp1Traversable :: forall (c :: * -> *) (b :: * -> *).
(Traversable c, Traversable b) =>
Functor (GenericTree c 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) = [(x, GenericTree b b x)] -> ()
forall a. NFData a => a -> ()
rnf ([(x, GenericTree b b x)] -> ()) -> [(x, GenericTree b b x)] -> ()
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ c (x, GenericTree b b x) -> [(x, GenericTree b b x)]
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 = 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 (c (x, GenericTree b b x) -> GenericTree c b x)
-> c (x, GenericTree b b x) -> GenericTree c b x
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ c (x, GenericTree b b x)
-> c (x, GenericTree b b x) -> c (x, GenericTree b b x)
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 = 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 c (x, GenericTree b b x)
forall (m :: * -> *) a. MonadPlus m => m a
Hask.mzero
  mappend :: GenericTree c b x -> GenericTree c b x -> GenericTree c b x
mappend = GenericTree c b x -> GenericTree c b x -> GenericTree c b x
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
pDepth -> Depth -> Bool
forall a. Ord a => a -> a -> Bool
>Depth
9) (ShowS -> ShowS) -> ShowS -> ShowS
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (Char
'朳'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. Depth -> c (x, GenericTree b b x) -> ShowS
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
朳 :: c (x, GenericTree b b x) -> GenericTree c b x
朳 = 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 :: ShadeTree x -> Trees x
onlyNodes (PlainLeaves []) = [(x, Trees x)] -> Trees x
forall (c :: * -> *) (b :: * -> *) x.
c (x, GenericTree b b x) -> GenericTree c b x
GenericTree []
onlyNodes (PlainLeaves [(x, ())]
ps) = let (x
ctr,([(x, ())], [(x, ())])
_) = [x] -> NonEmpty (x, ()) -> (x, ([(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]) (NonEmpty (x, ()) -> (x, ([(x, ())], [(x, ())])))
-> NonEmpty (x, ()) -> (x, ([(x, ())], [(x, ())]))
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ [(x, ())] -> NonEmpty (x, ())
forall a. [a] -> NonEmpty a
NE.fromList [(x, ())]
ps
                             in [(x, Trees x)] -> Trees x
forall (c :: * -> *) (b :: * -> *) x.
c (x, GenericTree b b x) -> GenericTree c b x
GenericTree [ (x
ctr, [(x, Trees x)] -> Trees x
forall (c :: * -> *) (b :: * -> *) x.
c (x, GenericTree b b x) -> GenericTree c b x
GenericTree ([(x, Trees x)] -> Trees x) -> [(x, Trees x)] -> Trees x
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (,Trees x
forall a. Monoid a => a
mempty)(x -> (x, Trees x)) -> ((x, ()) -> x) -> (x, ()) -> (x, Trees x)
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
.(x, ()) -> x
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst ((x, ()) -> (x, Trees x)) -> [(x, ())] -> [(x, Trees x)]
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 (ShadeTree x)
brs) = (ShadeTree x -> Trees x) -> NonEmpty (ShadeTree x) -> Trees x
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Hask.foldMap ShadeTree x -> Trees x
forall x.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
ShadeTree x -> Trees x
onlyNodes NonEmpty (ShadeTree x)
brs
onlyNodes (OverlappingBranches Depth
_ (Shade x
ctr Metric' x
_) NonEmpty (DBranch x ())
brs)
              = [(x, Trees x)] -> Trees x
forall (c :: * -> *) (b :: * -> *) x.
c (x, GenericTree b b x) -> GenericTree c b x
GenericTree [ ( x
ctr
                              , (DBranch x () -> Trees x) -> NonEmpty (DBranch x ()) -> Trees x
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Hask.foldMap ((ShadeTree x -> Trees x) -> DBranch x () -> Trees x
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Hask.foldMap ShadeTree x -> Trees x
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 :: Shaded x y -> LeafyTree x y
entireTree (PlainLeaves [(x, y)]
lvs)
    = let (x
ctr,([(x, y)], [(x, y)])
_) = [x] -> NonEmpty (x, y) -> (x, ([(x, y)], [(x, y)]))
forall x y (p :: * -> *).
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x), Functor p) =>
p x -> NonEmpty (x, y) -> (x, ([(x, y)], [(x, y)]))
pseudoECM ([]::[x]) (NonEmpty (x, y) -> (x, ([(x, y)], [(x, y)])))
-> NonEmpty (x, y) -> (x, ([(x, y)], [(x, y)]))
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ [(x, y)] -> NonEmpty (x, y)
forall a. [a] -> NonEmpty a
NE.fromList [(x, y)]
lvs
      in  [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)]
-> LeafyTree x y
forall (c :: * -> *) (b :: * -> *) x.
c (x, GenericTree b b x) -> GenericTree c b x
GenericTree [ (x
ctr, ListT
  (Either y) (x, GenericTree (ListT (Either y)) (ListT (Either y)) x)
-> GenericTree (ListT (Either y)) (ListT (Either y)) 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)
 -> GenericTree (ListT (Either y)) (ListT (Either y)) x)
-> (Either
      y [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)]
    -> ListT
         (Either y)
         (x, GenericTree (ListT (Either y)) (ListT (Either y)) x))
-> Either
     y [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)]
-> GenericTree (ListT (Either y)) (ListT (Either y)) x
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. Either y [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)]
-> ListT
     (Either y) (x, GenericTree (ListT (Either y)) (ListT (Either y)) x)
forall (m :: * -> *) a. m [a] -> ListT m a
ListT (Either
   y [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)]
 -> GenericTree (ListT (Either y)) (ListT (Either y)) x)
-> Either
     y [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)]
-> GenericTree (ListT (Either y)) (ListT (Either y)) x
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)]
-> Either
     y [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)]
forall a b. b -> Either a b
Right
                                [ (x
x, ListT
  (Either y) (x, GenericTree (ListT (Either y)) (ListT (Either y)) x)
-> GenericTree (ListT (Either y)) (ListT (Either y)) 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)
 -> GenericTree (ListT (Either y)) (ListT (Either y)) x)
-> (Either
      y (x, GenericTree (ListT (Either y)) (ListT (Either y)) x)
    -> ListT
         (Either y)
         (x, GenericTree (ListT (Either y)) (ListT (Either y)) x))
-> Either
     y (x, GenericTree (ListT (Either y)) (ListT (Either y)) x)
-> GenericTree (ListT (Either y)) (ListT (Either y)) x
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. Either y (x, GenericTree (ListT (Either y)) (ListT (Either y)) x)
-> ListT
     (Either y) (x, GenericTree (ListT (Either y)) (ListT (Either y)) x)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either y (x, GenericTree (ListT (Either y)) (ListT (Either y)) x)
 -> GenericTree (ListT (Either y)) (ListT (Either y)) x)
-> Either
     y (x, GenericTree (ListT (Either y)) (ListT (Either y)) x)
-> GenericTree (ListT (Either y)) (ListT (Either y)) x
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ y
-> Either
     y (x, GenericTree (ListT (Either y)) (ListT (Either y)) x)
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)
    = [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)]
-> LeafyTree x y
forall (c :: * -> *) (b :: * -> *) x.
c (x, GenericTree b b x) -> GenericTree c b x
GenericTree [ (x
x, ListT
  (Either y) (x, GenericTree (ListT (Either y)) (ListT (Either y)) x)
-> GenericTree (ListT (Either y)) (ListT (Either y)) 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 <- NonEmpty (LeafyTree x y) -> [LeafyTree x y]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty (LeafyTree x y) -> [LeafyTree x y])
-> NonEmpty (LeafyTree x y) -> [LeafyTree x y]
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (Shaded x y -> LeafyTree x y)
-> NonEmpty (Shaded x y) -> NonEmpty (LeafyTree x y)
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 Shaded x y -> LeafyTree x y
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)
    = [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)]
-> LeafyTree x y
forall (c :: * -> *) (b :: * -> *) x.
c (x, GenericTree b b x) -> GenericTree c b x
GenericTree [ ( x
ctr
                    , ListT
  (Either y) (x, GenericTree (ListT (Either y)) (ListT (Either y)) x)
-> GenericTree (ListT (Either y)) (ListT (Either y)) 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)
 -> GenericTree (ListT (Either y)) (ListT (Either y)) x)
-> ([(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)]
    -> ListT
         (Either y)
         (x, GenericTree (ListT (Either y)) (ListT (Either y)) x))
-> [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)]
-> GenericTree (ListT (Either y)) (ListT (Either y)) x
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. Either y [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)]
-> ListT
     (Either y) (x, GenericTree (ListT (Either y)) (ListT (Either y)) x)
forall (m :: * -> *) a. m [a] -> ListT m a
ListT (Either
   y [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)]
 -> ListT
      (Either y)
      (x, GenericTree (ListT (Either y)) (ListT (Either y)) x))
-> ([(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)]
    -> Either
         y [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)])
-> [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)]
-> ListT
     (Either y) (x, GenericTree (ListT (Either y)) (ListT (Either y)) x)
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)]
-> Either
     y [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)]
forall a b. b -> Either a b
Right
                       ([(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)]
 -> GenericTree (ListT (Either y)) (ListT (Either y)) x)
-> [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)]
-> GenericTree (ListT (Either y)) (ListT (Either y)) x
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (DBranch x y
 -> [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)])
-> NonEmpty (DBranch x y)
-> [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Hask.foldMap ((Shaded x y
 -> [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)])
-> DBranch x y
-> [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Hask.foldMap ((Shaded x y
  -> [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)])
 -> DBranch x y
 -> [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)])
-> (Shaded x y
    -> [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)])
-> DBranch x y
-> [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)]
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ LeafyTree x y
-> [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)]
forall (c :: * -> *) (b :: * -> *) x.
GenericTree c b x -> c (x, GenericTree b b x)
treeBranches (LeafyTree x y
 -> [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)])
-> (Shaded x y -> LeafyTree x y)
-> Shaded x y
-> [(x, GenericTree (ListT (Either y)) (ListT (Either y)) x)]
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. Shaded x y -> LeafyTree x y
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_ :: ShadeTree x -> [x]
onlyLeaves_ = ((x, ()) -> x) -> [(x, ())] -> [x]
forall a b. (a -> b) -> [a] -> [b]
map (x, ()) -> x
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst ([(x, ())] -> [x])
-> (ShadeTree x -> [(x, ())]) -> ShadeTree x -> [x]
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. ShadeTree x -> [(x, ())]
forall x y. WithField ℝ PseudoAffine x => Shaded x y -> [(x, y)]
onlyLeaves

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








data Sawbones x = Sawbones { Sawbones x -> [x] -> [x]
sawnTrunk1, Sawbones x -> [x] -> [x]
sawnTrunk2 :: [x]->[x]
                           , Sawbones x -> [x]
sawdust1,   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
     = ([x] -> [x]) -> ([x] -> [x]) -> [x] -> [x] -> Sawbones x
forall x. ([x] -> [x]) -> ([x] -> [x]) -> [x] -> [x] -> Sawbones x
Sawbones ([x] -> [x]
st11([x] -> [x]) -> ([x] -> [x]) -> [x] -> [x]
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
.[x] -> [x]
st21) ([x] -> [x]
st12([x] -> [x]) -> ([x] -> [x]) -> [x] -> [x]
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
.[x] -> [x]
st22) ([x]
sd11[x] -> [x] -> [x]
forall a. Semigroup a => a -> a -> a
<>[x]
sd21) ([x]
sd12[x] -> [x] -> [x]
forall a. Semigroup a => a -> a -> a
<>[x]
sd22)
instance Monoid (Sawbones x) where
  mempty :: Sawbones x
mempty = ([x] -> [x]) -> ([x] -> [x]) -> [x] -> [x] -> Sawbones x
forall x. ([x] -> [x]) -> ([x] -> [x]) -> [x] -> [x] -> Sawbones x
Sawbones [x] -> [x]
forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id [x] -> [x]
forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id [] []
  mappend :: Sawbones x -> Sawbones x -> Sawbones x
mappend = Sawbones x -> Sawbones x -> Sawbones x
forall a. Semigroup a => a -> a -> a
(<>)



type DList x = [x]->[x]
    
data DustyEdges x = DustyEdges { DustyEdges x -> DList x
sawChunk :: DList 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 = DList x -> DBranches' x [x] -> DustyEdges x
forall x. DList x -> DBranches' x [x] -> DustyEdges x
DustyEdges (DList x
c1DList x -> DList x -> DList x
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
.DList x
c2) (DBranches' x [x]
d1DBranches' x [x] -> DBranches' x [x] -> DBranches' x [x]
forall a. Semigroup a => a -> a -> a
<>DBranches' x [x]
d2)

data Sawboneses x = SingleCut (Sawbones x)
                  | Sawboneses (DBranches' x (DustyEdges x))
    deriving ((forall x. Sawboneses x -> Rep (Sawboneses x) x)
-> (forall x. Rep (Sawboneses x) x -> Sawboneses x)
-> Generic (Sawboneses x)
forall x. Rep (Sawboneses x) x -> Sawboneses x
forall x. Sawboneses x -> Rep (Sawboneses x) x
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 = Sawbones x -> Sawboneses x
forall x. Sawbones x -> Sawboneses x
SingleCut (Sawbones x -> Sawboneses x) -> Sawbones x -> Sawboneses x
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Sawbones x
cSawbones x -> Sawbones x -> Sawbones x
forall a. Semigroup a => a -> a -> a
<>Sawbones x
d
  Sawboneses DBranches' x (DustyEdges x)
c <> Sawboneses DBranches' x (DustyEdges x)
d = DBranches' x (DustyEdges x) -> Sawboneses x
forall x. DBranches' x (DustyEdges x) -> Sawboneses x
Sawboneses (DBranches' x (DustyEdges x) -> Sawboneses x)
-> DBranches' x (DustyEdges x) -> Sawboneses x
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ DBranches' x (DustyEdges x)
cDBranches' x (DustyEdges x)
-> DBranches' x (DustyEdges x) -> DBranches' x (DustyEdges x)
forall a. Semigroup a => a -> a -> a
<>DBranches' x (DustyEdges x)
d






constShaded :: y -> x`Shaded`y₀ -> x`Shaded`y
constShaded :: y -> Shaded x y₀ -> Shaded x y
constShaded y
y = (NonEmpty (x, y₀) -> NonEmpty (x, y))
-> (Needle' x -> Needle' x)
-> (Shade x -> Shade x)
-> Shaded x y₀
-> Shaded x y
forall x y ξ υ.
(NonEmpty (x, y) -> NonEmpty (ξ, υ))
-> (Needle' x -> Needle' ξ)
-> (Shade x -> Shade ξ)
-> Shaded x y
-> Shaded ξ υ
unsafeFmapTree (((x, y₀) -> (x, y)) -> NonEmpty (x, y₀) -> NonEmpty (x, y)
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)) -> NonEmpty (x, y₀) -> NonEmpty (x, y))
-> ((y₀ -> y) -> (x, y₀) -> (x, y))
-> (y₀ -> y)
-> NonEmpty (x, y₀)
-> NonEmpty (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
. (y₀ -> y) -> (x, y₀) -> (x, y)
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₀ -> y) -> NonEmpty (x, y₀) -> NonEmpty (x, y))
-> (y₀ -> y) -> NonEmpty (x, y₀) -> NonEmpty (x, y)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ y -> y₀ -> y
forall (a :: * -> * -> *) b x.
(WellPointed a, Object a b, ObjectPoint a x) =>
x -> a b x
const y
y) Needle' x -> Needle' x
forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id Shade x -> Shade x
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 :: (y -> υ) -> Shaded x y -> Shaded x υ
fmapShaded y -> υ
f = (NonEmpty (x, y) -> NonEmpty (x, υ))
-> (Needle' x -> Needle' x)
-> (Shade x -> Shade x)
-> Shaded x y
-> Shaded x υ
forall x y ξ υ.
(NonEmpty (x, y) -> NonEmpty (ξ, υ))
-> (Needle' x -> Needle' ξ)
-> (Shade x -> Shade ξ)
-> Shaded x y
-> Shaded ξ υ
unsafeFmapTree (((x, y) -> (x, υ)) -> NonEmpty (x, y) -> NonEmpty (x, υ)
forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (((x, y) -> (x, υ)) -> NonEmpty (x, y) -> NonEmpty (x, υ))
-> ((x, y) -> (x, υ)) -> NonEmpty (x, y) -> NonEmpty (x, υ)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (y -> υ) -> (x, y) -> (x, υ)
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) Needle' x -> Needle' x
forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id Shade x -> Shade x
forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id

zipTreeWithList :: x`Shaded`w -> NonEmpty y -> (x`Shaded`(w,y))
zipTreeWithList :: Shaded x w -> NonEmpty y -> Shaded x (w, y)
zipTreeWithList Shaded x w
tree = Shaded x w -> [y] -> Shaded x (w, y)
forall x y a. Shaded x y -> [a] -> Shaded x (y, a)
go Shaded x w
tree ([y] -> Shaded x (w, y))
-> (NonEmpty y -> [y]) -> NonEmpty y -> Shaded x (w, 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
. NonEmpty y -> [y]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty y -> [y])
-> (NonEmpty y -> NonEmpty y) -> NonEmpty y -> [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
. NonEmpty y -> NonEmpty y
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 = [(x, (y, a))] -> Shaded x (y, a)
forall x y. [(x, y)] -> Shaded x y
PlainLeaves ([(x, (y, a))] -> Shaded x (y, a))
-> [(x, (y, a))] -> Shaded x (y, a)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ ((x, y) -> a -> (x, (y, a))) -> [(x, y)] -> [a] -> [(x, (y, a))]
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
             = Depth -> NonEmpty (Shaded x (y, a)) -> Shaded x (y, a)
forall x y. Depth -> NonEmpty (Shaded x y) -> Shaded x y
DisjointBranches Depth
n (NonEmpty (Shaded x (y, a)) -> Shaded x (y, a))
-> ([Shaded x (y, a)] -> NonEmpty (Shaded x (y, a)))
-> [Shaded x (y, a)]
-> Shaded x (y, 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
. [Shaded x (y, a)] -> NonEmpty (Shaded x (y, a))
forall a. [a] -> NonEmpty a
NE.fromList
                  ([Shaded x (y, a)] -> Shaded x (y, a))
-> [Shaded x (y, a)] -> Shaded x (y, a)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ ([a], [Shaded x (y, a)] -> [Shaded x (y, a)])
-> [Shaded x (y, a)] -> [Shaded x (y, a)]
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd ((([a], [Shaded x (y, a)] -> [Shaded x (y, a)])
 -> Shaded x y -> ([a], [Shaded x (y, a)] -> [Shaded x (y, a)]))
-> ([a], [Shaded x (y, a)] -> [Shaded x (y, a)])
-> [Shaded x y]
-> ([a], [Shaded x (y, a)] -> [Shaded x (y, a)])
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 -> 
                                    (Depth -> [a] -> [a]
forall a. Depth -> [a] -> [a]
drop (Shaded x y -> Depth
forall x a. Shaded x a -> Depth
nLeaves Shaded x y
br) [a]
ys', [Shaded x (y, a)] -> [Shaded x (y, a)]
prev ([Shaded x (y, a)] -> [Shaded x (y, a)])
-> ([Shaded x (y, a)] -> [Shaded x (y, a)])
-> [Shaded x (y, a)]
-> [Shaded x (y, 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
. (Shaded x y -> [a] -> Shaded x (y, a)
go Shaded x y
br [a]
ys'Shaded x (y, a) -> [Shaded x (y, a)] -> [Shaded x (y, a)]
forall a. a -> [a] -> [a]
:)) )
                           ([a]
ys,[Shaded x (y, a)] -> [Shaded x (y, a)]
forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id) ([Shaded x y] -> ([a], [Shaded x (y, a)] -> [Shaded x (y, a)]))
-> [Shaded x y] -> ([a], [Shaded x (y, a)] -> [Shaded x (y, a)])
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ NonEmpty (Shaded x y) -> [Shaded x y]
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
             = Depth -> Shade x -> NonEmpty (DBranch x (y, a)) -> Shaded x (y, a)
forall x y.
Depth -> Shade x -> NonEmpty (DBranch x y) -> Shaded x y
OverlappingBranches Depth
n Shade x
shx (NonEmpty (DBranch x (y, a)) -> Shaded x (y, a))
-> ([DBranch x (y, a)] -> NonEmpty (DBranch x (y, a)))
-> [DBranch x (y, a)]
-> Shaded x (y, 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
. [DBranch x (y, a)] -> NonEmpty (DBranch x (y, a))
forall a. [a] -> NonEmpty a
NE.fromList
                  ([DBranch x (y, a)] -> Shaded x (y, a))
-> [DBranch x (y, a)] -> Shaded x (y, a)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ ([a], [DBranch x (y, a)] -> [DBranch x (y, a)])
-> [DBranch x (y, a)] -> [DBranch x (y, a)]
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd ((([a], [DBranch x (y, a)] -> [DBranch x (y, a)])
 -> DBranch x y -> ([a], [DBranch x (y, a)] -> [DBranch x (y, a)]))
-> ([a], [DBranch x (y, a)] -> [DBranch x (y, a)])
-> [DBranch x y]
-> ([a], [DBranch x (y, a)] -> [DBranch x (y, a)])
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 Depth -> [a] -> [a]
forall a. Depth -> [a] -> [a]
drop (Shaded x y -> Depth
forall x a. Shaded x a -> Depth
nLeaves Shaded x y
top) [a]
ys' of
                              [a]
ys'' -> ( Depth -> [a] -> [a]
forall a. Depth -> [a] -> [a]
drop (Shaded x y -> Depth
forall x a. Shaded x a -> Depth
nLeaves Shaded x y
bot) [a]
ys''
                                      , [DBranch x (y, a)] -> [DBranch x (y, a)]
prev ([DBranch x (y, a)] -> [DBranch x (y, a)])
-> ([DBranch x (y, a)] -> [DBranch x (y, a)])
-> [DBranch x (y, a)]
-> [DBranch x (y, 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
. (Needle' x -> Hourglass (Shaded x (y, a)) -> DBranch x (y, a)
forall x c. Needle' x -> Hourglass c -> DBranch' x c
DBranch Needle' x
dir (Shaded x (y, a) -> Shaded x (y, a) -> Hourglass (Shaded x (y, a))
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''))DBranch x (y, a) -> [DBranch x (y, a)] -> [DBranch x (y, a)]
forall a. a -> [a] -> [a]
:)
                                      ) )
                           ([a]
ys,[DBranch x (y, a)] -> [DBranch x (y, a)]
forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id) ([DBranch x y] -> ([a], [DBranch x (y, a)] -> [DBranch x (y, a)]))
-> [DBranch x y] -> ([a], [DBranch x (y, a)] -> [DBranch x (y, a)])
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ NonEmpty (DBranch x y) -> [DBranch x y]
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 :: Shaded x y -> x -> Cℝay y
stiWithDensity (PlainLeaves [(x, y)]
lvs)
  | LinearManifoldWitness y
LinearManifoldWitness <- TensorSpace y => LinearManifoldWitness y
forall v. TensorSpace v => LinearManifoldWitness v
linearManifoldWitness @y
  , [Shade x
baryc Metric' x
expa :: Shade x] <- [x] -> [Shade x]
forall x.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
[x] -> [Shade x]
pointsShades ([x] -> [Shade x]) -> [x] -> [Shade x]
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (x, y) -> x
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst ((x, y) -> x) -> [(x, y)] -> [x]
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 = Depth -> ℝ
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Depth -> ℝ) -> Depth -> ℝ
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ [(x, y)] -> Depth
forall (t :: * -> *) a. Foldable t => t a -> Depth
length [(x, y)]
lvs :: ℝ
             indiShapes :: [(Shade x, y)]
indiShapes = [(x -> Metric' x -> Shade x
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 = [ Shade x -> x -> ℝ
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 Scalar (Needle y) -> y -> Cℝay y
forall v.
(AdditiveGroup v, Real (Scalar (Needle v))) =>
Scalar (Needle v) -> v -> Cℝay v
mkCone ℝ
Scalar (Needle y)
dens (y -> Cℝay y) -> ([ℝ] -> y) -> [ℝ] -> Cℝay 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
. [(y, Scalar y)] -> y
forall v. VectorSpace v => [(v, Scalar v)] -> v
linearCombo ([(y, Scalar y)] -> y) -> ([ℝ] -> [(y, Scalar y)]) -> [ℝ] -> 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
. [y] -> [ℝ] -> [(y, ℝ)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Shade x, y) -> y
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd((Shade x, y) -> y) -> [(Shade x, y)] -> [y]
forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>[(Shade x, y)]
indiShapes)
                       ([ℝ] -> Cℝay y) -> [ℝ] -> Cℝay y
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 TensorSpace y => LinearManifoldWitness y
forall v. TensorSpace v => LinearManifoldWitness v
linearManifoldWitness @y of
          LinearManifoldWitness y
LinearManifoldWitness -> \x
x -> (Cℝay y -> Cℝay y -> Cℝay y) -> NonEmpty (Cℝay y) -> Cℝay y
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Cℝay y -> Cℝay y -> Cℝay y
forall x.
(Eq (Scalar (Needle x)), Num (Scalar (Needle x))) =>
Cℝay x -> Cℝay x -> Cℝay x
qGather (NonEmpty (Cℝay y) -> Cℝay y) -> NonEmpty (Cℝay y) -> Cℝay y
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (Shaded x y -> x -> Cℝay y
forall x y.
(WithField ℝ PseudoAffine x, LinearSpace y, Scalar y ~ ℝ,
 SimpleSpace (Needle x)) =>
Shaded x y -> x -> Cℝay y
`stiWithDensity`x
x)(Shaded x y -> Cℝay y)
-> NonEmpty (Shaded x y) -> NonEmpty (Cℝay y)
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 (DualNeedleWitness x
forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness, PseudoAffineWitness x
forall x. PseudoAffine x => PseudoAffineWitness x
pseudoAffineWitness, LinearManifoldWitness y
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
xx -> x -> Maybe (Needle x)
forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
bc of
           Just Needle x
v
             | Scalar (Needle x)
dist² <- Seminorm (Needle x) -> Needle x -> Scalar (Needle x)
forall v. LSpace v => Seminorm v -> v -> Scalar v
normSq Seminorm (Needle x)
ε Needle x
v
             , ℝ
Scalar (Needle x)
dist² ℝ -> ℝ -> Bool
forall a. Ord a => a -> a -> Bool
< ℝ
9
             , ℝ
att <- ℝ -> ℝ
forall a. Floating a => a -> a
exp(ℝ
1ℝ -> ℝ -> ℝ
forall 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
+ℝ
1ℝ -> ℝ -> ℝ
forall a. Fractional a => a -> a -> a
/ℝ
9)
               -> Scalar y -> NonEmpty (Cℝay y) -> Cℝay y
forall a.
(Real (Scalar (Needle a)), VectorSpace a, Fractional (Scalar a),
 Scalar (Needle a) ~ Scalar a) =>
Scalar a -> NonEmpty (Cℝay a) -> Cℝay a
qGather ℝ
Scalar y
att (NonEmpty (Cℝay y) -> Cℝay y) -> NonEmpty (Cℝay y) -> Cℝay y
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ ((x -> Cℝay y) -> Cℝay y)
-> NonEmpty (x -> Cℝay y) -> NonEmpty (Cℝay y)
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 -> Cℝay y) -> x -> Cℝay y
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)
_ -> Cℝay y
forall v. (AdditiveGroup v, Num (Scalar (Needle v))) => Cℝay v
coneTip
       ε :: Seminorm (Needle x)
ε = Metric' x -> Seminorm (Needle x)
forall v. SimpleSpace v => Variance v -> Norm v
dualNorm' Metric' x
extend :: Norm (Needle x)
       downPrepared :: NonEmpty (x -> Cℝay y)
downPrepared = DBranch x y -> NonEmpty (x -> Cℝay y)
forall x y 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,
 Scalar (Needle x) ~ ℝ, Scalar y ~ ℝ,
 Scalar (DualVector (Needle x)) ~ ℝ) =>
DBranch' x (Shaded x y) -> NonEmpty (x -> Cℝay y)
dp (DBranch x y -> NonEmpty (x -> Cℝay y))
-> NonEmpty (DBranch x y) -> NonEmpty (x -> Cℝay y)
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))
                 = (Shaded x y -> x -> Cℝay y)
-> NonEmpty (Shaded x y) -> NonEmpty (x -> Cℝay y)
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 Shaded x y -> x -> Cℝay y
forall x y.
(WithField ℝ PseudoAffine x, LinearSpace y, Scalar y ~ ℝ,
 SimpleSpace (Needle x)) =>
Shaded x y -> x -> Cℝay y
stiWithDensity (NonEmpty (Shaded x y) -> NonEmpty (x -> Cℝay y))
-> NonEmpty (Shaded x y) -> NonEmpty (x -> Cℝay y)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Shaded x y
upShaded x y -> [Shaded x y] -> NonEmpty (Shaded x y)
forall a. a -> [a] -> NonEmpty a
:|[Shaded x y
dn]
       qGather :: Scalar a -> NonEmpty (Cℝay a) -> Cℝay a
qGather Scalar a
att NonEmpty (Cℝay a)
contribs = Scalar (Needle a) -> a -> Cℝay a
forall v.
(AdditiveGroup v, Real (Scalar (Needle v))) =>
Scalar (Needle v) -> v -> Cℝay v
mkCone (Scalar a
attScalar a -> Scalar a -> Scalar a
forall a. Num a => a -> a -> a
*Scalar a
dens)
                 (a -> Cℝay a) -> a -> Cℝay a
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ [(a, Scalar a)] -> a
forall v. VectorSpace v => [(v, Scalar v)] -> v
linearCombo [(a
v, Scalar a
Scalar (Needle a)
dScalar a -> Scalar a -> Scalar a
forall a. Fractional a => a -> a -> a
/Scalar a
dens) | Cℝay Scalar (Needle a)
d a
v <- NonEmpty (Cℝay a) -> [Cℝay a]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Cℝay a)
contribs]
        where dens :: Scalar a
dens = NonEmpty (Scalar a) -> Scalar a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (Cℝay a -> Scalar a
forall x. Cℝay x -> Scalar (Needle x)
hParamCℝay (Cℝay a -> Scalar a) -> NonEmpty (Cℝay a) -> NonEmpty (Scalar a)
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 :: Shaded x y -> [(x, ((y, Diff y), LinearMap ℝ x y))]
stiAsIntervalMapping = Shaded ℝ ℝ -> [(Twig ℝ ℝ, TwigEnviron ℝ ℝ)]
forall x y.
(WithField ℝ Manifold x, SimpleSpace (Needle x)) =>
Shaded x y -> [(Twig x y, TwigEnviron x y)]
twigsWithEnvirons (Shaded ℝ ℝ -> [(Twig ℝ ℝ, TwigEnviron ℝ ℝ)])
-> ((Twig ℝ ℝ, TwigEnviron ℝ ℝ)
    -> [(ℝ, ((ℝ, ℝ), LinearMap ℝ ℝ ℝ))])
-> Shaded ℝ ℝ
-> [(ℝ, ((ℝ, ℝ), LinearMap ℝ ℝ ℝ))]
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)
>=> Shaded ℝ ℝ -> [Shaded ℝ ℝ]
forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a.
(Applicative f r t, Object r a, Object t (f a)) =>
t a (f a)
pure(Shaded ℝ ℝ -> [Shaded ℝ ℝ])
-> ((Twig ℝ ℝ, TwigEnviron ℝ ℝ) -> Shaded ℝ ℝ)
-> (Twig ℝ ℝ, TwigEnviron ℝ ℝ)
-> [Shaded ℝ ℝ]
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
.Twig ℝ ℝ -> Shaded ℝ ℝ
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd(Twig ℝ ℝ -> Shaded ℝ ℝ)
-> ((Twig ℝ ℝ, TwigEnviron ℝ ℝ) -> Twig ℝ ℝ)
-> (Twig ℝ ℝ, TwigEnviron ℝ ℝ)
-> Shaded ℝ ℝ
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
.(Twig ℝ ℝ, TwigEnviron ℝ ℝ) -> Twig ℝ ℝ
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst ((Twig ℝ ℝ, TwigEnviron ℝ ℝ) -> [Shaded ℝ ℝ])
-> (Shaded ℝ ℝ -> [(ℝ, ((ℝ, ℝ), LinearMap ℝ ℝ ℝ))])
-> (Twig ℝ ℝ, TwigEnviron ℝ ℝ)
-> [(ℝ, ((ℝ, ℝ), LinearMap ℝ ℝ ℝ))]
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)
>=> Shaded ℝ ℝ -> [Shade' (ℝ, ℝ)]
forall x y.
(WithField ℝ PseudoAffine x, WithField ℝ PseudoAffine y,
 SimpleSpace (Needle x), SimpleSpace (Needle y)) =>
Shaded x y -> [Shade' (x, y)]
completeTopShading (Shaded ℝ ℝ -> [Shade' (ℝ, ℝ)])
-> (Shade' (ℝ, ℝ) -> [(ℝ, ((ℝ, ℝ), LinearMap ℝ ℝ ℝ))])
-> Shaded ℝ ℝ
-> [(ℝ, ((ℝ, ℝ), LinearMap ℝ ℝ ℝ))]
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)
>=> (ℝ, ((ℝ, ℝ), LinearMap ℝ ℝ ℝ)) -> [(ℝ, ((ℝ, ℝ), LinearMap ℝ ℝ ℝ))]
forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a.
(Applicative f r t, Object r a, Object t (f a)) =>
t a (f a)
pure((ℝ, ((ℝ, ℝ), LinearMap ℝ ℝ ℝ))
 -> [(ℝ, ((ℝ, ℝ), LinearMap ℝ ℝ ℝ))])
-> (Shade' (ℝ, ℝ) -> (ℝ, ((ℝ, ℝ), LinearMap ℝ ℝ ℝ)))
-> Shade' (ℝ, ℝ)
-> [(ℝ, ((ℝ, ℝ), LinearMap ℝ ℝ ℝ))]
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
.
             \(Shade' (ℝ
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
$ Norm (ℝ, ℝ)
Metric (ℝ, ℝ)
shdNorm (ℝ, ℝ) -> (ℝ, ℝ) -> Scalar (ℝ, ℝ)
forall v.
(LSpace v, Floating (Scalar v)) =>
Seminorm v -> v -> Scalar v
|$|(ℝ
0,ℝ
1))
                            , Variance (ℝ, ℝ) -> ℝ +> ℝ
forall u v.
(SimpleSpace u, SimpleSpace v, Scalar u ~ Scalar v) =>
Variance (u, v) -> u +> v
dependence (Norm (ℝ, ℝ) -> Variance (ℝ, ℝ)
forall v. SimpleSpace v => Norm v -> Variance v
dualNorm Norm (ℝ, ℝ)
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 :: (Shade x -> Shade y) -> ShadeTree x -> Shaded x y
spanShading Shade x -> Shade y
f = (NonEmpty (x, ()) -> NonEmpty (x, y))
-> (Needle' x -> Needle' x)
-> (Shade x -> Shade x)
-> ShadeTree x
-> Shaded x y
forall x y ξ υ.
(NonEmpty (x, y) -> NonEmpty (ξ, υ))
-> (Needle' x -> Needle' ξ)
-> (Shade x -> Shade ξ)
-> Shaded x y
-> Shaded ξ υ
unsafeFmapTree (NonEmpty x -> NonEmpty (x, y)
addYs (NonEmpty x -> NonEmpty (x, y))
-> (NonEmpty (x, ()) -> NonEmpty x)
-> NonEmpty (x, ())
-> NonEmpty (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
. ((x, ()) -> x) -> NonEmpty (x, ()) -> NonEmpty x
forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (x, ()) -> x
forall (a :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) x
fst) Needle' x -> Needle' x
forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id Shade x -> Shade x
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 = ((x, y) -> NonEmpty (x, y) -> NonEmpty (x, y))
-> NonEmpty (x, y) -> [(x, y)] -> NonEmpty (x, y)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (x, y) -> NonEmpty (x, y) -> NonEmpty (x, y)
forall a. a -> NonEmpty a -> NonEmpty a
(NE.<|) ((x -> (x, y)) -> NonEmpty x -> NonEmpty (x, y)
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     )
                               ((y -> (x, y)) -> [y] -> [(x, y)]
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
_)] = [x] -> [Shade x]
forall x.
(WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) =>
[x] -> [Shade x]
pointsCovers ([x] -> [Shade x])
-> (NonEmpty x -> [x]) -> NonEmpty x -> [Shade x]
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. NonEmpty x -> [x]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
                                           (NonEmpty x -> [Shade x]) -> NonEmpty x -> [Shade x]
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 y -> Needle y -> y
forall x. Semimanifold x => x -> Needle x -> x
.+~^ ℝ
Scalar (Needle y)
σScalar (Needle y) -> Needle y -> Needle y
forall v. VectorSpace v => Scalar v -> v -> v
*^Needle y
δy
                         | Needle y
δy <- Metric' y -> [Needle y]
forall v. SimpleSpace v => Variance v -> [v]
varianceSpanningSystem Metric' y
yexpa, ℝ
σ <- [-ℝ
1,ℝ
1] ]
                      


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

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


foci :: [a] -> [(a,[a])]
foci :: [a] -> [(a, [a])]
foci [] = []
foci (a
x:[a]
xs) = (a
x,[a]
xs) (a, [a]) -> [(a, [a])] -> [(a, [a])]
forall a. a -> [a] -> [a]
: ((a, [a]) -> (a, [a])) -> [(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 (([a] -> [a]) -> (a, [a]) -> (a, [a])
forall (a :: * -> * -> *) d b c.
(Morphism a, ObjectPair a d b, ObjectPair a d c) =>
a b c -> a (d, b) (d, c)
second (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:)) ([a] -> [(a, [a])]
forall a. [a] -> [(a, [a])]
foci [a]
xs)
       
fociNE :: NonEmpty a -> NonEmpty (a,[a])
fociNE :: NonEmpty a -> NonEmpty (a, [a])
fociNE (a
x:|[a]
xs) = (a
x,[a]
xs) (a, [a]) -> [(a, [a])] -> NonEmpty (a, [a])
forall a. a -> [a] -> NonEmpty a
:| ((a, [a]) -> (a, [a])) -> [(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 (([a] -> [a]) -> (a, [a]) -> (a, [a])
forall (a :: * -> * -> *) d b c.
(Morphism a, ObjectPair a d b, ObjectPair a d c) =>
a b c -> a (d, b) (d, c)
second (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:)) ([a] -> [(a, [a])]
forall a. [a] -> [(a, [a])]
foci [a]
xs)
       

(.:) :: (c->d) -> (a->b->c) -> a->b->d 
.: :: (c -> d) -> (a -> b -> c) -> a -> b -> d
(.:) = ((b -> c) -> b -> 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
(.) (((b -> c) -> b -> d) -> (a -> b -> c) -> a -> b -> d)
-> ((c -> d) -> (b -> c) -> b -> d)
-> (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
. (c -> d) -> (b -> c) -> 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
(.)




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 :: 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 :: Sawbones x -> [[x]]
superFlatView = (([x], [[x]]) -> [[x]]) -> [([x], [[x]])] -> [[x]]
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 ([x], [[x]]) -> [[x]]
forall a. (a, [a]) -> [a]
go ([([x], [[x]])] -> [[x]])
-> (Sawbones x -> [([x], [[x]])]) -> Sawbones x -> [[x]]
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. Sawbones x -> [([x], [[x]])]
forall (f :: * -> *) x. HasFlatView f => f x -> FlatView f x
flatView
   where go :: (a, [a]) -> [a]
go (a
t,[a]
ds) = a
t a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ds

instance HasFlatView Sawboneses where
  type FlatView Sawboneses x = [([x],[[x]])]
  flatView :: 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[], NonEmpty (DBranch' x [x]) -> [DBranch' x [x]]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (DBranch' x [x])
ds [DBranch' x [x]] -> (DBranch' x [x] -> [[x]]) -> [[x]]
forall (f :: * -> * -> *) (m :: * -> *) a b.
(Function f, Monad m f, Object f a, Object f b, Object f (m a),
 Object f (m b), Object f (m (m b))) =>
m a -> f a (m b) -> m b
>>= \(DBranch Needle' x
_ (Hourglass [x]
u' [x]
l')) -> [[x]
u',[x]
l'])
        | (DBranch Needle' x
_ (Hourglass DustyEdges x
u DustyEdges x
l)) <- NonEmpty (DBranch' x (DustyEdges x)) -> [DBranch' x (DustyEdges x)]
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 :: Sawboneses x -> [[x]]
superFlatView = (([x], [[x]]) -> [[x]]) -> [([x], [[x]])] -> [[x]]
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 ([x], [[x]]) -> [[x]]
forall a. (a, [a]) -> [a]
go ([([x], [[x]])] -> [[x]])
-> (Sawboneses x -> [([x], [[x]])]) -> Sawboneses x -> [[x]]
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. Sawboneses x -> [([x], [[x]])]
forall (f :: * -> *) x. HasFlatView f => f x -> FlatView f x
flatView
   where go :: (a, [a]) -> [a]
go (a
t,[a]
ds) = a
t a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ds