diff --git a/Data/CoNat.hs b/Data/CoNat.hs --- a/Data/CoNat.hs +++ b/Data/CoNat.hs @@ -25,6 +25,7 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} @@ -34,7 +35,7 @@ , ftorTryToMatch, ftorTryToMatchT, ftorTryToMatchTT , KnownNat(..) , Range(..) - , FreeVect(..), (^)(), freeVector, freeCons, freeSnoc + , FreeVect(..), type (^)(), freeVector, freeCons, freeSnoc , replicVector, indices, perfectZipWith, freeRotate , ) where diff --git a/Data/Function/Affine.hs b/Data/Function/Affine.hs --- a/Data/Function/Affine.hs +++ b/Data/Function/Affine.hs @@ -30,20 +30,22 @@ module Data.Function.Affine ( - Affine - , linearAffine - , toOffsetSlope, toOffset'Slope + Affine(..) + , evalAffine + , fromOffsetSlope ) where import Data.Semigroup +import Data.MemoTrie import Data.VectorSpace import Data.AffineSpace import Data.Tagged import Data.Manifold.Types.Primitive import Data.Manifold.PseudoAffine +import Data.Manifold.Atlas import qualified Prelude import qualified Control.Applicative as Hask @@ -59,368 +61,140 @@ data Affine s d c where - Subtract :: AffineManifold α => Affine s (α,α) (Needle α) - AddTo :: Affine s (α, Needle α) α - ScaleWith :: (LinearManifold α, LinearManifold β) => (α+>β) -> Affine s α β - ReAffine :: ReWellPointed (Affine s) α β -> Affine s α β - -reAffine :: ReWellPointed (Affine s) α β -> Affine s α β -reAffine (ReWellPointed f) = f -reAffine f = ReAffine f - -pattern Specific f = ReWellPointed f -pattern Id = ReAffine WellPointedId -infixr 1 :>>>, :<<< -pattern f :>>> g <- ReAffine (WellPointedCompo (reAffine -> f) (reAffine -> g)) -pattern g :<<< f <- ReAffine (WellPointedCompo (reAffine -> f) (reAffine -> g)) -pattern Swap = ReAffine WellPointedSwap -pattern AttachUnit = ReAffine WellPointedAttachUnit -pattern DetachUnit = ReAffine WellPointedDetachUnit -pattern Regroup = ReAffine WellPointedRegroup -pattern Regroup' = ReAffine WellPointedRegroup_ -pattern Terminal = ReAffine WellPointedTerminal -pattern Fst = ReAffine WellPointedFst -pattern Snd = ReAffine WellPointedSnd -infixr 3 :***, :&&& -pattern f :*** g <- ReAffine (WellPointedPar (reAffine -> f) (reAffine -> g)) -pattern f :&&& g <- ReAffine (WellPointedFanout (reAffine -> f) (reAffine -> g)) -pattern Const c = ReAffine (WellPointedConst c) - - -toOffsetSlope :: (MetricScalar s, WithField s LinearManifold d - , WithField s AffineManifold c ) - => Affine s d c -> (c, Needle d +> Needle c) -toOffsetSlope f = toOffset'Slope f zeroV - -type MetricScalar s = (Num''' s, LSpace (ZeroDim s)) - -linear :: (LSpace a, LSpace b, Scalar a ~ Scalar b) - => (a -> b) -> (a+>b) -linear = arr . LinearFunction - --- | Basically evaluates an affine function as a generic differentiable one, --- yielding at a given reference point the result and Jacobian. Unlike with --- 'Data.Function.Differentiable.Differentiable', the induced 1st-order Taylor --- series is equal to the function! -toOffset'Slope :: ( MetricScalar s, WithField s AffineManifold d - , WithField s AffineManifold c ) - => Affine s d c -> d -> (c, Needle d +> Needle c) -toOffset'Slope Subtract (a,b) = (a.-.b, linear $ uncurry(^-^)) -toOffset'Slope AddTo (p,v) = (p.+^v, linear $ uncurry(^+^)) -toOffset'Slope (ScaleWith q) ref = (q $ ref, q) -toOffset'Slope Id ref = (ref, linear id) -toOffset'Slope (f :>>> g) ref = case toOffset'Slope f ref of - (cf,sf) -> case toOffset'Slope g cf of - (cg,sg) -> (cg, sg . sf) -toOffset'Slope Swap ref = (swap ref, linear swap) -toOffset'Slope AttachUnit ref = ((ref,Origin), linear (,Origin)) -toOffset'Slope DetachUnit ref = (fst ref, linear fst) -toOffset'Slope Regroup ref = (regroup ref, linear regroup) -toOffset'Slope Regroup' ref = (regroup' ref, linear regroup') -toOffset'Slope (f:***g) ref = case ( toOffset'Slope f (fst ref) - , toOffset'Slope g (snd ref) ) of - ((cf, sf), (cg, sg)) -> ((cf,cg), sf *** sg) -toOffset'Slope Terminal ref = (Origin, zeroV) -toOffset'Slope Fst ref = (fst ref, linear fst) -toOffset'Slope Snd ref = (snd ref, linear snd) -toOffset'Slope (f:&&&g) ref = case ( toOffset'Slope (arr f) ref - , toOffset'Slope (arr g) ref ) of - ((cf, sf), (cg, sg)) -> ((cf,cg), sf &&& sg) -toOffset'Slope (Const c) ref = (c, zeroV) - -coOffsetForm :: ( MetricScalar s, WithField s AffineManifold d - , WithField s AffineManifold c ) - => Affine s d c -> Affine s d c -coOffsetForm (ScaleWith q) = id&&&const zeroV >>> Subtract >>> ScaleWith q -coOffsetForm ((coOffsetForm -> Id:&&&Const cof :>>> Subtract :>>> f) :>>> g) - = id&&&const cof >>> Subtract >>> (f >>> g) -coOffsetForm ( (coOffsetForm -> Id:&&&Const cof :>>> Subtract :>>> f) - :*** (coOffsetForm -> Id:&&&Const cog :>>> Subtract :>>> g) ) - = id&&&const(cof,cog) >>> Subtract >>> (f***g) -coOffsetForm (Id:&&&Const cof :>>> Subtract) - = (Id&&&Const cof >>> ReAffine (ReWellPointed Subtract`WellPointedCompo`WellPointedId)) -coOffsetForm f = f - -pattern PreSubtract c f <- (coOffsetForm -> Id:&&&Const c :>>> Subtract :>>> f) - -preSubtract :: ( MetricScalar s, WithField s AffineManifold d - , WithField s AffineManifold c ) - => c -> Affine s (Diff c) d -> Affine s c d --- The specialised clauses may not actually be useful here. -preSubtract _ (Const d) = const d -preSubtract _ Terminal = Terminal -preSubtract c (f:>>>g) = preSubtract c f >>>! g --- preSubtract t (f:***g) | (c,d)<-t = preSubtract c f *** preSubtract d g -preSubtract c (f:&&&g) = preSubtract c f &&& preSubtract c g -preSubtract c f = id&&&const c >>>! Subtract >>>! f - -pattern PostAdd c f <- f:&&&Const c :>>> AddTo -pattern PostAdd' c f <- Const c:&&&f :>>> AddTo - -postAdd :: (MetricScalar s, WithField s AffineManifold d, WithField s AffineManifold c) - => Diff d -> Affine s c d -> Affine s c d -postAdd c f = f&&&const c >>>! AddTo -postAdd' :: (MetricScalar s, WithField s AffineManifold d, WithField s AffineManifold c) - => d -> Affine s c (Diff d) -> Affine s c d -postAdd' c f = const c&&&f >>>! AddTo - -instance (MetricScalar s) => EnhancedCat (->) (Affine s) where - arr f = fst . toOffset'Slope f - -instance (MetricScalar s) => EnhancedCat (Affine s) (ReWellPointed (Affine s)) where - arr (Specific c) = c - arr c = ReAffine c - -instance (MetricScalar s, WithField s AffineManifold d, WithField s AffineManifold c) - => AffineSpace (Affine s d c) where - type Diff (Affine s d c) = Affine s d (Diff c) - - ScaleWith q .-. ScaleWith r = ScaleWith $ q^-^r - (PostAdd c (ScaleWith q)) .-. g = let (d, r) = toOffsetSlope g - in postAdd (c.-.d) $ ScaleWith (q^-^r) - f .-. (PostAdd d (ScaleWith r)) = let (c, q) = toOffsetSlope f - in postAdd (c.-.d) $ ScaleWith (q^-^r) - (PostAdd' c (ScaleWith q)) .-. g = let (d, r) = toOffsetSlope g - in postAdd (c.-.d) $ ScaleWith (q^-^r) - f .-. (PostAdd' d (ScaleWith r)) = let (c, q) = toOffsetSlope f - in postAdd (c.-.d) $ ScaleWith (q^-^r) - - Id .-. Id = const zeroV - Fst .-. Fst = const zeroV - Snd .-. Snd = const zeroV - Swap .-. Swap = const zeroV - AttachUnit .-. AttachUnit = const zeroV - DetachUnit .-. DetachUnit = const zeroV - Terminal .-. _ = Terminal - _ .-. Terminal = Terminal - Subtract .-. Subtract = const zeroV - AddTo .-. AddTo = const zeroV - - Const c .-. Const d = Const $ c.-.d - - Fst .-. Snd = Subtract - - (f:***g) .-. (h:***i) = f.-.h *** g.-.i - (f:***g) .-. Const (c,d) = f.-.const c *** g.-.const d - ζ .-. (f:***g) | Const (c,d) <- ζ = const c.-.f *** const d.-.g - (f:&&&g) .-. (h:&&&i) = f.-.h &&& g.-.i - (f:&&&_) .-. AttachUnit = f.-.id >>>! AttachUnit - (f:&&&g) .-. Const (c,d) = f.-.const c &&& g.-.const d - ζ .-. (f:&&&g) | Const (c,d) <- ζ = const c.-.f &&& const d.-.g - - ScaleWith q .-. f = let (c, r) = toOffset'Slope f zeroV - in postAdd (negateV c) $ ScaleWith (q^-^r) - f .-. ScaleWith q = let (c, r) = toOffset'Slope f zeroV - in postAdd c $ ScaleWith (r^-^q) - - PreSubtract b f .-. g = let (c, q) = toOffsetSlope f - (d, r) = toOffset'Slope g b - in preSubtract b . postAdd (c.-.d) $ ScaleWith (q^-^r) - -- f x = q·x + c - -- g x = r·x + w - -- d = r·b + w - -- (q−r)·(x−b) = q·x − q⋅b − r⋅x + r⋅b - -- s x = f (x−b) − g x - -- = q⋅(x−b) + c − r⋅x − w - -- = q⋅x − q⋅b + c − r⋅x − w - -- = (q−r)·(x−b) + c − r⋅b − w - -- = (q−r)·(x−b) + c − d - - -- According to GHC, this clause overlaps with the above. Hm... - f .-. PreSubtract b g = let (c, q) = toOffset'Slope f b - (d, r) = toOffsetSlope g - in preSubtract b $ postAdd (c.-.d) $ ScaleWith (q^-^r) - -- f x = q·x + v - -- g x = r·x + d - -- c = q·b + v - -- (q−r)·(x−b) = q·x − q⋅b − r⋅x + r⋅b - -- s x = f x − g (x−b) - -- = q⋅x + v − r⋅(x−b) − d - -- = q⋅x + v − r⋅x + r⋅b − d - -- = (q−r)·(x−b) + q⋅b + v − d - -- = (q−r)·(x−b) + c − d - - f .-. g = f&&&g >>> Subtract - - - ScaleWith q .+^ ScaleWith r = ScaleWith $ q^+^r - (PostAdd c (ScaleWith q)) .+^ g = let (d, r) = toOffsetSlope g - in postAdd (c.+^d) $ ScaleWith (q^+^r) - f .+^ (PostAdd d (ScaleWith r)) = let (c, q) = toOffsetSlope f - in postAdd' (c.+^d) $ ScaleWith (q^+^r) - (PostAdd' c (ScaleWith q)) .+^ g = let (d, r) = toOffsetSlope g - in postAdd' (c.+^d) $ ScaleWith (q^+^r) - f .+^ (PostAdd' d (ScaleWith r)) = let (c, q) = toOffsetSlope f - in postAdd' (c.+^d) $ ScaleWith (q^+^r) - (f:***g) .+^ (h:***i) = f.+^h *** g.+^i - (f:&&&g) .+^ (h:&&&i) = f.+^h &&& g.+^i - - Const c .+^ Const c' = const (c.+^c') - - Terminal .+^ _ = Terminal - Const c .+^ Terminal = Const c - Const c .+^ f = const c&&&f >>> AddTo - - Id .+^ Id = Id >>> ScaleWith (linear (^*2)) - Fst .+^ Fst = Fst >>> ScaleWith (linear (^*2)) - Snd .+^ Snd = Snd >>> ScaleWith (linear (^*2)) - Fst .+^ Snd = AddTo - Swap .+^ Swap = Swap >>> ScaleWith (linear (^*2)) - - f .+^ Id = let (c,q) = toOffset'Slope f zeroV - in const c&&&ScaleWith (q^+^id) >>>! AddTo - f .+^ AttachUnit = let (c,q) = toOffset'Slope f zeroV - in postAdd' c $ ScaleWith (q^+^linear(,Origin)) - f .+^ DetachUnit = let (c,q) = toOffset'Slope f zeroV - in postAdd' c $ ScaleWith (q^+^linear fst) - f .+^ Swap = let (c,q) = toOffset'Slope f zeroV - in postAdd' c $ ScaleWith (q^+^linear swap) - - PreSubtract b f .+^ g = let (c, q) = toOffsetSlope f - (d, r) = toOffset'Slope g b - in preSubtract b . postAdd' (c.+^d) $ ScaleWith (q^+^r) - -- f x = q·x + c - -- g x = r·x + w - -- d = r·b + w - -- (q+r)·(x−b) = q·x − q⋅b + r⋅x − r⋅b - -- s x = f (x−b) + g x - -- = q⋅(x−b) + c + r⋅x + w - -- = q⋅x − q⋅b + c + r⋅x + w - -- = (q+r)·(x−b) + c + r⋅b + w - -- = (q−r)·(x−b) + c + d - - f .+^ PreSubtract b g = let (c, q) = toOffset'Slope f b - (d, r) = toOffsetSlope g - in preSubtract b . postAdd' (c.+^d) $ ScaleWith (q^+^r) - -- f x = q·x + v - -- g x = r·x + d - -- c = q·b + v - -- (q+r)·(x−b) = q·x − q⋅b + r⋅x − r⋅b - -- s x = f x + g (x−b) - -- = q⋅x + v + r⋅(x−b) + d - -- = q⋅x + v + r⋅x − r⋅b + d - -- = (q+r)·(x−b) + q⋅b + v + d - -- = (q+r)·(x−b) + c + d - - f .+^ g = f&&&g >>> AddTo + Affine :: (ChartIndex d :->: (c, LinearMap s (Needle d) (Needle c))) + -> Affine s d c +instance Category (Affine s) where + type Object (Affine s) x = ( Manifold x, Interior x ~ x + , Atlas x, LinearSpace (Needle x) + , Scalar (Needle x) ~ s, HasTrie (ChartIndex x) ) + id = Affine . trie $ chartReferencePoint >>> id &&& const id + Affine f . Affine g = Affine . trie + $ \ixa -> case untrie g ixa of + (b, ða'b) -> case untrie f $ lookupAtlas b of + (c, ðb'c) -> (c, ðb'c . ða'b) +instance ∀ s . Num' s => Cartesian (Affine s) where + type UnitObject (Affine s) = ZeroDim s + swap = Affine . trie $ chartReferencePoint >>> swap &&& const swap + attachUnit = Affine . trie $ chartReferencePoint >>> \a -> ((a,Origin), attachUnit) + detachUnit = Affine . trie $ chartReferencePoint + >>> \(a,Origin::ZeroDim s) -> (a, detachUnit) + regroup = Affine . trie $ chartReferencePoint >>> regroup &&& const regroup + regroup' = Affine . trie $ chartReferencePoint >>> regroup' &&& const regroup' -instance (MetricScalar s, WithField s AffineManifold d, WithField s LinearManifold c) - => AdditiveGroup (Affine s d c) where - zeroV = const zeroV - - negateV (Const c) = const $ negateV c - negateV Terminal = Terminal - negateV (ScaleWith ϕ) = ScaleWith $ negateV ϕ - negateV (f:***g) = negateV f *** negateV g - negateV (f:&&&g) = negateV f &&& negateV g - negateV (f:>>>AddTo) = negateV f >>> AddTo - negateV (f:>>>Subtract) = (f>>>swap) >>>! Subtract - negateV (f:>>>ScaleWith ϕ) = negateV f >>>! ScaleWith ϕ - negateV (f:>>>g) = f >>>! negateV g - negateV AttachUnit = ScaleWith $ linear (negateV >>> (,Origin)) - negateV Subtract = Swap >>>! Subtract - negateV f = f >>>! ScaleWith (linear negateV) - - (^+^) = (.+^) - (^-^) = (.-.) +instance ∀ s . Num' s => Morphism (Affine s) where + Affine f *** Affine g = Affine . trie + $ \(ixα,ixβ) -> case (untrie f ixα, untrie g ixβ) of + ((fα, ðα'f), (gβ,ðβ'g)) -> ((fα,gβ), ðα'f***ðβ'g) - -infixr 1 >>>!, <<>>!) :: ( MetricScalar s, WithField s AffineManifold α - , WithField s AffineManifold β, WithField s AffineManifold γ ) - => Affine s α β -> Affine s β γ -> Affine s α γ -ReAffine f >>>! ReAffine g = ReAffine $ f >>> g -f >>>! ReAffine g = ReAffine $ ReWellPointed f >>> g -ReAffine f >>>! g = ReAffine $ f >>> ReWellPointed g -f >>>! g = ReAffine $ ReWellPointed f >>> ReWellPointed g - -(<< Affine s β γ -> Affine s α β -> Affine s α γ -(<<>>!) - -instance (MetricScalar s) => Category (Affine s) where - type Object (Affine s) o = WithField s AffineManifold o +instance ∀ s . Num' s => PreArrow (Affine s) where + Affine f &&& Affine g = Affine . trie + $ \ix -> case (untrie f ix, untrie g ix) of + ((fα, ðα'f), (gβ,ðβ'g)) -> ((fα,gβ), ðα'f&&&ðβ'g) + terminal = Affine . trie $ \_ -> (Origin, zeroV) + fst = afst + where afst :: ∀ x y . ( Atlas x, Atlas y + , LinearSpace (Needle x), LinearSpace (Needle y) + , Scalar (Needle x) ~ s, Scalar (Needle y) ~ s + , HasTrie (ChartIndex x), HasTrie (ChartIndex y) ) + => Affine s (x,y) x + afst = Affine . trie $ chartReferencePoint >>> \(x,_::y) -> (x, fst) + snd = asnd + where asnd :: ∀ x y . ( Atlas x, Atlas y + , LinearSpace (Needle x), LinearSpace (Needle y) + , Scalar (Needle x) ~ s, Scalar (Needle y) ~ s + , HasTrie (ChartIndex x), HasTrie (ChartIndex y) ) + => Affine s (x,y) y + asnd = Affine . trie $ chartReferencePoint >>> \(_::x,y) -> (y, snd) - id = ReAffine id +instance ∀ s . Num' s => WellPointed (Affine s) where + const x = Affine . trie $ const (x, zeroV) + unit = Tagged Origin - ScaleWith ϕ . ScaleWith ψ = ScaleWith $ ϕ . ψ - g . ScaleWith ψ = let (d, ϕ) = toOffsetSlope g - in postAdd' d $ ScaleWith (ϕ . ψ) - (f:***g) . (h:***i) = f.h *** g.i - (f:***g) . (h:&&&i) = f.h &&& g.i - g . (PostAdd' c f) = let (d, ϕ) = toOffset'Slope g c - in postAdd' d $ ScaleWith ϕ . f +instance EnhancedCat (->) (Affine s) where + arr f = fst . evalAffine f - f . g = f << Cartesian (Affine s) where - type UnitObject (Affine s) = ZeroDim s - swap = ReAffine swap - attachUnit = ReAffine attachUnit - detachUnit = ReAffine detachUnit - regroup = ReAffine regroup - regroup' = ReAffine regroup' - -instance (MetricScalar s) => Morphism (Affine s) where - Const c *** Const c' = const (c,c') - Terminal *** Terminal = const (mempty, mempty) - ReAffine f *** ReAffine g = ReAffine $ f *** g - f *** ReAffine g = ReAffine $ ReWellPointed f *** g - ReAffine f *** g = ReAffine $ f *** ReWellPointed g - f *** g = ReAffine $ ReWellPointed f *** ReWellPointed g - -instance (MetricScalar s) => PreArrow (Affine s) where - terminal = ReAffine terminal - fst = ReAffine fst - snd = ReAffine snd - Const c &&& Const c' = const (c,c') - Terminal &&& Terminal = const (mempty, mempty) - ReAffine f &&& ReAffine g = ReAffine $ f &&& g - f &&& ReAffine g = ReAffine $ ReWellPointed f &&& g - ReAffine f &&& g = ReAffine $ f &&& ReWellPointed g - f &&& g = ReAffine $ ReWellPointed f &&& ReWellPointed g - --- Affine cof aof slf &&& Affine cog aog slg --- = Affine coh (aof.-^lapply slf rco, aog.+^lapply slg rco) --- (linear $ lapply slf &&& lapply slg) --- where rco = (cog.-.cof)^/2 --- coh = cof .+^ rco - -instance (MetricScalar s) => WellPointed (Affine s) where - unit = Tagged Origin - const = ReAffine . const - - -linearAffine :: (MetricScalar s, WithField s LinearManifold α, WithField s LinearManifold β) - => (α+>β) -> Affine s α β -linearAffine = ScaleWith - - -type AffinFuncValue s = GenericAgent (Affine s) - -instance (MetricScalar s) => HasAgent (Affine s) where - alg = genericAlg - ($~) = genericAgentMap -instance (MetricScalar s) => CartesianAgent (Affine s) where - alg1to2 = genericAlg1to2 - alg2to1 = genericAlg2to1 - alg2to2 = genericAlg2to2 -instance (MetricScalar s) - => PointAgent (AffinFuncValue s) (Affine s) a x where - point = genericPoint - - - -instance (MetricScalar s, WithField s LinearManifold v, WithField s LinearManifold a) - => AdditiveGroup (AffinFuncValue s a v) where - zeroV = GenericAgent zeroV - GenericAgent f ^+^ GenericAgent g = GenericAgent $ f ^+^ g - negateV (GenericAgent f) = GenericAgent $ negateV f +instance EnhancedCat (Affine s) (LinearMap s) where + arr = alarr (linearManifoldWitness, linearManifoldWitness) + where alarr :: ∀ x y . ( LinearSpace x, Atlas x, HasTrie (ChartIndex x) + , LinearSpace y + , Scalar x ~ s, Scalar y ~ s ) + => (LinearManifoldWitness x, LinearManifoldWitness y) + -> LinearMap s x y -> Affine s x y + alarr (LinearManifoldWitness _, LinearManifoldWitness _) f + = Affine . trie $ chartReferencePoint + >>> \x₀ -> let y₀ = f $ x₀ + in (negateV y₀, f) +instance ( Atlas x, HasTrie (ChartIndex x), LinearSpace (Needle x), Scalar (Needle x) ~ s + , Manifold y, Scalar (Needle y) ~ s ) + => Semimanifold (Affine s x y) where + type Needle (Affine s x y) = Affine s x (Needle y) + toInterior = pure + fromInterior = id + (.+~^) = case ( semimanifoldWitness :: SemimanifoldWitness y + , boundarylessWitness :: BoundarylessWitness y ) of + (SemimanifoldWitness _, BoundarylessWitness) -> \(Affine f) (Affine g) + -> Affine . trie $ \ix -> case (untrie f ix, untrie g ix) of + ((fx₀,f'), (gx₀,g')) -> (fx₀.+~^gx₀, f'^+^g') + translateP = Tagged (.+~^) + semimanifoldWitness = case semimanifoldWitness :: SemimanifoldWitness y of + SemimanifoldWitness _ -> SemimanifoldWitness BoundarylessWitness +instance ( Atlas x, HasTrie (ChartIndex x), LinearSpace (Needle x), Scalar (Needle x) ~ s + , Manifold y, Scalar (Needle y) ~ s ) + => PseudoAffine (Affine s x y) where + (.-~!) = case ( semimanifoldWitness :: SemimanifoldWitness y + , boundarylessWitness :: BoundarylessWitness y ) of + (SemimanifoldWitness _, BoundarylessWitness) -> \(Affine f) (Affine g) + -> Affine . trie $ \ix -> case (untrie f ix, untrie g ix) of + ((fx₀,f'), (gx₀,g')) -> (fx₀.-~!gx₀, f'^-^g') + pseudoAffineWitness = case semimanifoldWitness :: SemimanifoldWitness y of + SemimanifoldWitness _ -> PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness) +instance ( Atlas x, HasTrie (ChartIndex x), LinearSpace (Needle x), Scalar (Needle x) ~ s + , Manifold y, Scalar (Needle y) ~ s ) + => AffineSpace (Affine s x y) where + type Diff (Affine s x y) = Affine s x (Needle y) + (.+^) = (.+~^); (.-.) = (.-~!) +instance ( Atlas x, HasTrie (ChartIndex x), LinearSpace (Needle x), Scalar (Needle x) ~ s + , LinearSpace y, Scalar y ~ s, Num' s ) + => AdditiveGroup (Affine s x y) where + zeroV = case linearManifoldWitness :: LinearManifoldWitness y of + LinearManifoldWitness _ -> Affine . trie $ const (zeroV, zeroV) + (^+^) = case ( linearManifoldWitness :: LinearManifoldWitness y + , dualSpaceWitness :: DualSpaceWitness y ) of + (LinearManifoldWitness BoundarylessWitness, DualSpaceWitness) -> (.+~^) + negateV = case linearManifoldWitness :: LinearManifoldWitness y of + LinearManifoldWitness _ -> \(Affine f) -> Affine . trie $ + untrie f >>> negateV***negateV +instance ( Atlas x, HasTrie (ChartIndex x), LinearSpace (Needle x), Scalar (Needle x) ~ s + , LinearSpace y, Scalar y ~ s, Num' s ) + => VectorSpace (Affine s x y) where + type Scalar (Affine s x y) = s + (*^) = case linearManifoldWitness :: LinearManifoldWitness y of + LinearManifoldWitness _ -> \μ (Affine f) -> Affine . trie $ + untrie f >>> (μ*^)***(μ*^) +evalAffine :: ∀ s x y . ( Manifold x, Atlas x, HasTrie (ChartIndex x) + , Manifold y + , s ~ Scalar (Needle x), s ~ Scalar (Needle y) ) + => Affine s x y -> x -> (y, LinearMap s (Needle x) (Needle y)) +evalAffine = ea (boundarylessWitness, boundarylessWitness) + where ea :: (BoundarylessWitness x, BoundarylessWitness y) + -> Affine s x y -> x -> (y, LinearMap s (Needle x) (Needle y)) + ea (BoundarylessWitness, BoundarylessWitness) + (Affine f) x = (fx₀.+~^(ðx'f $ v), ðx'f) + where Just v = x .-~. chartReferencePoint chIx + chIx = lookupAtlas x + (fx₀, ðx'f) = untrie f chIx +fromOffsetSlope :: ∀ s x y . ( LinearSpace x, Atlas x, HasTrie (ChartIndex x) + , Manifold y + , s ~ Scalar x, s ~ Scalar (Needle y) ) + => y -> LinearMap s x (Needle y) -> Affine s x y +fromOffsetSlope = case ( linearManifoldWitness :: LinearManifoldWitness x + , boundarylessWitness :: BoundarylessWitness y ) of + (LinearManifoldWitness _, BoundarylessWitness) + -> \y0 ðx'y -> Affine . trie $ chartReferencePoint + >>> \x₀ -> let δy = ðx'y $ x₀ + in (y0.+~^δy, ðx'y) diff --git a/Data/Function/Differentiable.hs b/Data/Function/Differentiable.hs --- a/Data/Function/Differentiable.hs +++ b/Data/Function/Differentiable.hs @@ -22,6 +22,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} @@ -53,6 +54,7 @@ import Data.Maybe import Data.Semigroup import Data.Embedding +import Data.MemoTrie (HasTrie) import Data.VectorSpace import Math.LinearMap.Category @@ -63,6 +65,7 @@ import Data.Tagged import Data.Manifold.Types.Primitive import Data.Manifold.PseudoAffine +import Data.Manifold.Atlas import qualified Prelude import qualified Control.Applicative as Hask @@ -154,8 +157,8 @@ resoHere = normSq $ δbf xq resoStep = dir/sqrt(resoHere 1) definedHere = case fq₀ of - Option (Just _) -> True - Option Nothing -> False + Just _ -> True + Nothing -> False glueMid ((l,le):ls) ((re,r):rs) | le==re = (ls, (l,r):rs) glueMid l r = (l,r) huge = exp $ fromIntegral nLim @@ -179,17 +182,17 @@ = ( map discretise ivsL, map discretise ivsR ) where (ivsL, ivsR) = continuityRanges nLim mx f discretise rng@(l,r) = discretisePathIn nLim rng (mx,my) fr - where (_, Option (Just fr)) = ff $ (l+r)/2 + where (_, Just fr) = ff $ (l+r)/2 analyseLocalBehaviour :: - RWDiffable ℝ ℝ ℝ - -> ℝ -- ^ /x/₀ value. - -> Option ( (ℝ,ℝ) - , ℝ->Option ℝ ) -- ^ /f/ /x/₀, derivative (i.e. Taylor-1-coefficient), + RWDiffable ℝ ℝ ℝ + -> ℝ -- ^ /x/₀ value. + -> Maybe ( (ℝ,ℝ) + , ℝ->Maybe ℝ ) -- ^ /f/ /x/₀, derivative (i.e. Taylor-1-coefficient), -- and reverse propagation of /O/ (/δ/²) bound. analyseLocalBehaviour (RWDiffable f) x₀ = case f x₀ of - (r, Option (Just (Differentiable fd))) + (r, Just (Differentiable fd)) | inRegion r x₀ -> return $ let (fx, j, δf) = fd x₀ epsprop ε @@ -228,7 +231,7 @@ = (map (id&&&ivimg) domsL, map (id&&&ivimg) domsR) where (domsL, domsR) = continuityRanges nLim mx f ivimg (xl,xr) = go xl 1 i₀ ∪ go xr (-1) i₀ - where (_, Option (Just fdd@(Differentiable fddd))) + where (_, Just fdd@(Differentiable fddd)) = second (fmap genericiseDifferentiable) $ fd xc xc = (xl+xr)/2 i₀ = minimum&&&maximum $ [fdd$xl, fdd$xc, fdd$xr] @@ -276,7 +279,7 @@ ++ " gives non-positive δ="++show δ++"." else mempty dev_ε_δ :: RealDimension a - => (a -> a) -> Metric a -> Option (Metric a) + => (a -> a) -> Metric a -> Maybe (Metric a) dev_ε_δ f d = let ε'² = normSq d 1 in if ε'²>0 then let δ = f . sqrt $ recip ε'² @@ -296,7 +299,7 @@ genericiseDifferentiable :: (LocallyScalable s d, LocallyScalable s c) => Differentiable s d c -> Differentiable s d c genericiseDifferentiable (AffinDiffable _ af) - = Differentiable $ \x -> let (y₀, ϕ) = toOffset'Slope af x + = Differentiable $ \x -> let (y₀, ϕ) = evalAffine af x in (y₀, ϕ, const mempty) genericiseDifferentiable f = f @@ -371,32 +374,52 @@ instance (RealFrac' s) => HasAgent (Differentiable s) where alg = genericAlg ($~) = genericAgentMap -instance (RealFrac' s) => CartesianAgent (Differentiable s) where +instance ∀ s . (RealFrac' s) => CartesianAgent (Differentiable s) where alg1to2 = genericAlg1to2 - alg2to1 = genericAlg2to1 - alg2to2 = genericAlg2to2 + alg2to1 = a2t1 + where a2t1 :: ∀ α β γ . (LocallyScalable s α, LocallyScalable s β) + => (∀ q . LocallyScalable s q + => DfblFuncValue s q α -> DfblFuncValue s q β -> DfblFuncValue s q γ ) + -> Differentiable s (α,β) γ + a2t1 = case ( dualSpaceWitness :: DualSpaceWitness (Needle α) + , dualSpaceWitness :: DualSpaceWitness (Needle β) ) of + (DualSpaceWitness, DualSpaceWitness) -> genericAlg2to1 + alg2to2 = a2t1 + where a2t1 :: ∀ α β γ δ . ( LocallyScalable s α, LocallyScalable s β + , LocallyScalable s γ, LocallyScalable s δ ) + => (∀ q . LocallyScalable s q + => DfblFuncValue s q α -> DfblFuncValue s q β + -> (DfblFuncValue s q γ, DfblFuncValue s q δ) ) + -> Differentiable s (α,β) (γ,δ) + a2t1 = case ( dualSpaceWitness :: DualSpaceWitness (Needle α) + , dualSpaceWitness :: DualSpaceWitness (Needle β) + , dualSpaceWitness :: DualSpaceWitness (Needle γ) + , dualSpaceWitness :: DualSpaceWitness (Needle δ) ) of + (DualSpaceWitness, DualSpaceWitness, DualSpaceWitness, DualSpaceWitness) + -> genericAlg2to2 instance (RealFrac' s) => PointAgent (DfblFuncValue s) (Differentiable s) a x where point = genericPoint - -actuallyLinearEndo :: WithField s LinearManifold x +actuallyLinearEndo :: (Object (Affine s) x, Object (LinearMap s) x) => (x+>x) -> Differentiable s x x -actuallyLinearEndo = AffinDiffable IsDiffableEndo . linearAffine +actuallyLinearEndo = AffinDiffable IsDiffableEndo . arr -actuallyAffineEndo :: WithField s LinearManifold x - => x -> (x+>x) -> Differentiable s x x -actuallyAffineEndo y₀ f = AffinDiffable IsDiffableEndo $ const y₀ .+^ linearAffine f +actuallyAffineEndo :: (Object (Affine s) x, Object (LinearMap s) x) + => x -> (x+>Needle x) -> Differentiable s x x +actuallyAffineEndo y₀ f = AffinDiffable IsDiffableEndo $ fromOffsetSlope y₀ f -actuallyLinear :: ( WithField s LinearManifold x, WithField s LinearManifold y ) + +actuallyLinear :: ( Object (Affine s) x, Object (Affine s) y + , Object (LinearMap s) x, Object (LinearMap s) y ) => (x+>y) -> Differentiable s x y -actuallyLinear = AffinDiffable NotDiffableEndo . linearAffine +actuallyLinear = AffinDiffable NotDiffableEndo . arr -actuallyAffine :: ( WithField s LinearManifold x - , WithField s AffineManifold y ) - => y -> (x+>Diff y) -> Differentiable s x y -actuallyAffine y₀ f = AffinDiffable NotDiffableEndo $ const y₀ .+^ linearAffine f +actuallyAffine :: ( Object (Affine s) x, Object (Affine s) y + , Object (LinearMap s) x, Object (LinearMap s) (Needle y) ) + => y -> (x+>Needle y) -> Differentiable s x y +actuallyAffine y₀ f = AffinDiffable NotDiffableEndo $ fromOffsetSlope y₀ f -- affinPoint :: (WithField s LinearManifold c, WithField s LinearManifold d) @@ -443,7 +466,7 @@ -instance (WithField s LinearManifold v, LocallyScalable s a, RealFloat' s) +instance (LocallyScalable s v, LinearManifold v, LocallyScalable s a, RealFloat' s) => AdditiveGroup (DfblFuncValue s a v) where zeroV = point zeroV GenericAgent (AffinDiffable ef f) ^+^ GenericAgent (AffinDiffable eg g) @@ -635,15 +658,15 @@ instance (RealDimension s) => Category (RWDiffable s) where - type Object (RWDiffable s) o = (LocallyScalable s o, SimpleSpace (Needle o)) + type Object (RWDiffable s) o = (LocallyScalable s o, Manifold o, SimpleSpace (Needle o)) id = RWDiffable $ \x -> (GlobalRegion, pure id) RWDiffable f . RWDiffable g = RWDiffable h where h x₀ = case g x₀ of - ( rg, Option (Just gr'@(AffinDiffable IsDiffableEndo gr)) ) - -> let (y₀, ϕg) = toOffset'Slope gr x₀ + ( rg, Just gr'@(AffinDiffable IsDiffableEndo gr) ) + -> let (y₀, ϕg) = evalAffine gr x₀ in case f y₀ of - (GlobalRegion, Option (Just (AffinDiffable fe fr))) - -> (rg, Option (Just (AffinDiffable fe (fr.gr)))) + (GlobalRegion, Just (AffinDiffable fe fr)) + -> (rg, Just (AffinDiffable fe (fr.gr))) (GlobalRegion, fhr) -> (rg, fmap (. gr') fhr) (RealSubray diry yl, fhr) @@ -660,51 +683,51 @@ | otherwise -> (rg, hhr) (PreRegion ry, fhr) -> ( PreRegion $ ry . gr', fmap (. gr') fhr ) - ( rg, Option (Just gr'@(AffinDiffable _ gr)) ) - -> error "( rg, Option (Just gr'@(AffinDiffable gr)) )" - (GlobalRegion, Option (Just gr@(Differentiable grd))) + ( rg, Just gr'@(AffinDiffable _ gr) ) + -> error "( rg, Just gr'@(AffinDiffable gr) )" + (GlobalRegion, Just gr@(Differentiable grd)) -> let (y₀,_,_) = grd x₀ in case f y₀ of - (GlobalRegion, Option Nothing) + (GlobalRegion, Nothing) -> (GlobalRegion, notDefinedHere) - (GlobalRegion, Option (Just fr)) + (GlobalRegion, Just fr) -> (GlobalRegion, pure (fr . gr)) - (r, Option Nothing) | PreRegion ry <- genericisePreRegion r + (r, Nothing) | PreRegion ry <- genericisePreRegion r -> ( PreRegion $ ry . gr, notDefinedHere ) - (r, Option (Just fr)) | PreRegion ry <- genericisePreRegion r + (r, (Just fr)) | PreRegion ry <- genericisePreRegion r -> ( PreRegion $ ry . gr, pure (fr . gr) ) - (rg@(RealSubray _ _), Option (Just gr@(Differentiable grd))) + (rg@(RealSubray _ _), Just gr@(Differentiable grd)) -> let (y₀,_,_) = grd x₀ in case f y₀ of - (GlobalRegion, Option Nothing) + (GlobalRegion, Nothing) -> (rg, notDefinedHere) - (GlobalRegion, Option (Just fr)) + (GlobalRegion, Just fr) -> (rg, pure (fr . gr)) - (rf, Option Nothing) + (rf, Nothing) | PreRegion rx <- genericisePreRegion rg , PreRegion ry <- genericisePreRegion rf -> ( PreRegion $ minDblfuncs (ry . gr) rx , notDefinedHere ) - (rf, Option (Just fr)) + (rf, Just fr) | PreRegion rx <- genericisePreRegion rg , PreRegion ry <- genericisePreRegion rf -> ( PreRegion $ minDblfuncs (ry . gr) rx , pure (fr . gr) ) - (PreRegion rx, Option (Just gr@(Differentiable grd))) + (PreRegion rx, Just gr@(Differentiable grd)) -> let (y₀,_,_) = grd x₀ in case f y₀ of - (GlobalRegion, Option Nothing) + (GlobalRegion, Nothing) -> (PreRegion rx, notDefinedHere) - (GlobalRegion, Option (Just fr)) + (GlobalRegion, Just fr) -> (PreRegion rx, pure (fr . gr)) - (r, Option Nothing) | PreRegion ry <- genericisePreRegion r + (r, Nothing) | PreRegion ry <- genericisePreRegion r -> ( PreRegion $ minDblfuncs (ry . gr) rx , notDefinedHere ) - (r, Option (Just fr)) | PreRegion ry <- genericisePreRegion r + (r, Just fr) | PreRegion ry <- genericisePreRegion r -> ( PreRegion $ minDblfuncs (ry . gr) rx , pure (fr . gr) ) - (r, Option Nothing) + (r, Nothing) -> (r, notDefinedHere) @@ -754,7 +777,8 @@ genericiseRWDFV :: ( RealDimension s , LocallyScalable s c, SimpleSpace (Needle c) - , LocallyScalable s d, SimpleSpace (Needle d) ) + , LocallyScalable s d, SimpleSpace (Needle d) + , Manifold d, Manifold c ) => RWDfblFuncValue s d c -> RWDfblFuncValue s d c genericiseRWDFV (ConstRWDFV c) = GenericRWDFV $ const c genericiseRWDFV RWDFV_IdVar = GenericRWDFV id @@ -781,6 +805,7 @@ grwDfblFnValsFunc :: ( RealDimension s , LocallyScalable s c, LocallyScalable s c', LocallyScalable s d + , Manifold d, Manifold c, Manifold c' , v ~ Needle c, v' ~ Needle c' , SimpleSpace v, SimpleSpace (Needle d) , ε ~ Norm v, ε ~ Norm v' ) @@ -790,6 +815,7 @@ grwDfblFnValsCombine :: forall d c c' c'' v v' v'' ε ε' ε'' s. ( LocallyScalable s c, LocallyScalable s c', LocallyScalable s c'' , LocallyScalable s d, RealDimension s + , Manifold d, Manifold c', Manifold c'' , v ~ Needle c, v' ~ Needle c', v'' ~ Needle c'' , SimpleSpace v, SimpleSpace (Needle d) , ε ~ Norm v , ε' ~ Norm v' , ε'' ~ Norm v'', ε~ε', ε~ε'' ) @@ -802,7 +828,7 @@ (rc'',gmay) = gpcs d₀ in (unsafePreRegionIntersect rc' rc'',) $ case (genericiseDifferentiable<$>fmay, genericiseDifferentiable<$>gmay) of - (Option(Just(Differentiable f)), Option(Just(Differentiable g))) -> + (Just(Differentiable f), Just(Differentiable g)) -> pure . Differentiable $ \d -> let (c', jf, devf) = f d (c'',jg, devg) = g d @@ -823,11 +849,16 @@ rwDfbl_plus :: ∀ s a v . - ( WithField s EuclidSpace v, AdditiveGroup v, v ~ Needle (Interior (Needle v)) - , LocallyScalable s a, RealDimension s ) + ( WithField s Manifold a + , LinearSpace v, Scalar v ~ s + , RealDimension s ) => RWDiffable s a v -> RWDiffable s a v -> RWDiffable s a v -rwDfbl_plus (RWDiffable f) (RWDiffable g) = RWDiffable h - where h x₀ = (rh, liftA2 fgplus ff gf) +rwDfbl_plus (RWDiffable f) (RWDiffable g) = RWDiffable + $ h linearManifoldWitness dualSpaceWitness + where h :: LinearManifoldWitness v -> DualSpaceWitness v + -> a -> (PreRegion s a, Maybe (Differentiable s a v)) + h (LinearManifoldWitness _) DualSpaceWitness + x₀ = (rh, liftA2 fgplus ff gf) where (rf, ff) = f x₀ (rg, gf) = g x₀ rh = unsafePreRegionIntersect rf rg @@ -841,21 +872,25 @@ = Differentiable hd where hd x = (fx^+^gx, jf^+^ϕg, δf) where (fx, jf, δf) = fd x - (gx, ϕg) = toOffset'Slope ga x + (gx, ϕg) = evalAffine ga x fgplus (AffinDiffable _ fa) (Differentiable gd) = Differentiable hd where hd x = (fx^+^gx, ϕf^+^jg, δg) where (gx, jg, δg) = gd x - (fx, ϕf) = toOffset'Slope fa x + (fx, ϕf) = evalAffine fa x fgplus (AffinDiffable fe fa) (AffinDiffable ge ga) = AffinDiffable (fe<>ge) (fa^+^ga) rwDfbl_negateV :: ∀ s a v . - ( WithField s EuclidSpace v, AdditiveGroup v, v ~ Needle (Interior (Needle v)) - , LocallyScalable s a, RealDimension s ) + ( WithField s Manifold a + , LinearSpace v, Scalar v ~ s + , RealDimension s ) => RWDiffable s a v -> RWDiffable s a v -rwDfbl_negateV (RWDiffable f) = RWDiffable h - where h x₀ = (rf, fmap fneg ff) +rwDfbl_negateV (RWDiffable f) = RWDiffable $ h linearManifoldWitness dualSpaceWitness + where h :: LinearManifoldWitness v -> DualSpaceWitness v + -> a -> (PreRegion s a, Maybe (Differentiable s a v)) + h (LinearManifoldWitness _) DualSpaceWitness + x₀ = (rf, fmap fneg ff) where (rf, ff) = f x₀ fneg :: Differentiable s a v -> Differentiable s a v fneg (Differentiable fd) = Differentiable hd @@ -865,47 +900,61 @@ postCompRW :: ( RealDimension s , LocallyScalable s a, LocallyScalable s b, LocallyScalable s c + , Manifold a, Manifold b, Manifold c , SimpleSpace (Needle a), SimpleSpace (Needle b), SimpleSpace (Needle c) ) => RWDiffable s b c -> RWDfblFuncValue s a b -> RWDfblFuncValue s a c postCompRW (RWDiffable f) (ConstRWDFV x) = case f x of - (_, Option (Just fd)) -> ConstRWDFV $ fd $ x + (_, Just fd) -> ConstRWDFV $ fd $ x postCompRW f RWDFV_IdVar = GenericRWDFV f postCompRW f (GenericRWDFV g) = GenericRWDFV $ f . g -instance ( WithField s EuclidSpace v, SimpleSpace v, v ~ Needle (Interior (Needle v)) - , LocallyScalable s a, SimpleSpace (Needle a), RealDimension s) +instance ∀ s a v . ( WithField s Manifold a, SimpleSpace (Needle a) + , Atlas v, HasTrie (ChartIndex v), SimpleSpace v, Scalar v ~ s + , RealDimension s ) => AdditiveGroup (RWDfblFuncValue s a v) where - zeroV = point zeroV - ConstRWDFV c₁ ^+^ ConstRWDFV c₂ = ConstRWDFV (c₁^+^c₂) - ConstRWDFV c₁ ^+^ RWDFV_IdVar = GenericRWDFV $ + zeroV = case ( linearManifoldWitness :: LinearManifoldWitness v + , dualSpaceWitness :: DualSpaceWitness v ) of + (LinearManifoldWitness BoundarylessWitness, DualSpaceWitness) -> point zeroV + (^+^) = case ( linearManifoldWitness :: LinearManifoldWitness v + , dualSpaceWitness :: DualSpaceWitness v ) of + (LinearManifoldWitness BoundarylessWitness, DualSpaceWitness) + -> curry $ \case + (ConstRWDFV c₁, ConstRWDFV c₂) -> ConstRWDFV (c₁^+^c₂) + (ConstRWDFV c₁, RWDFV_IdVar) -> GenericRWDFV $ globalDiffable' (actuallyAffineEndo c₁ id) - RWDFV_IdVar ^+^ ConstRWDFV c₂ = GenericRWDFV $ + (RWDFV_IdVar, ConstRWDFV c₂) -> GenericRWDFV $ globalDiffable' (actuallyAffineEndo c₂ id) - ConstRWDFV c₁ ^+^ GenericRWDFV g = GenericRWDFV $ + (ConstRWDFV c₁, GenericRWDFV g) -> GenericRWDFV $ globalDiffable' (actuallyAffineEndo c₁ id) . g - GenericRWDFV f ^+^ ConstRWDFV c₂ = GenericRWDFV $ + (GenericRWDFV f, ConstRWDFV c₂) -> GenericRWDFV $ globalDiffable' (actuallyAffineEndo c₂ id) . f - fa^+^ga | GenericRWDFV f <- genericiseRWDFV fa - , GenericRWDFV g <- genericiseRWDFV ga = GenericRWDFV $ rwDfbl_plus f g - negateV (ConstRWDFV c) = ConstRWDFV (negateV c) - negateV RWDFV_IdVar = GenericRWDFV $ globalDiffable' (actuallyLinearEndo $ negateV id) - negateV (GenericRWDFV f) = GenericRWDFV $ rwDfbl_negateV f + (fa, ga) | GenericRWDFV f <- genericiseRWDFV fa + , GenericRWDFV g <- genericiseRWDFV ga + -> GenericRWDFV $ rwDfbl_plus f g + negateV = case ( linearManifoldWitness :: LinearManifoldWitness v + , dualSpaceWitness :: DualSpaceWitness v ) of + (LinearManifoldWitness BoundarylessWitness, DualSpaceWitness) -> \case + (ConstRWDFV c) -> ConstRWDFV (negateV c) + RWDFV_IdVar -> GenericRWDFV $ globalDiffable' (actuallyLinearEndo $ negateV id) + (GenericRWDFV f) -> GenericRWDFV $ rwDfbl_negateV f dualCoCoProduct :: ∀ v w s . ( SimpleSpace v, HilbertSpace v , SimpleSpace w, Scalar v ~ s, Scalar w ~ s ) => LinearMap s w v -> LinearMap s w v -> Norm w -dualCoCoProduct s t = Norm $ (tSpread*sSpread) *^ t²Ps²M - where t' = adjoint $ t :: LinearMap s v (DualVector w) - s' = adjoint $ s :: LinearMap s v (DualVector w) - tSpread = sum . map recip_t²PLUSs² $ snd (decomposeLinMap t') [] - sSpread = sum . map recip_t²PLUSs² $ snd (decomposeLinMap s') [] - t²PLUSs²@(Norm t²Ps²M) - = transformNorm t euclideanNorm <> transformNorm s euclideanNorm :: Norm w - recip_t²PLUSs² = normSq (dualNorm t²PLUSs²) :: DualVector w -> s +dualCoCoProduct = dccp (dualSpaceWitness::DualSpaceWitness w) + where dccp DualSpaceWitness s t = Norm $ (tSpread*sSpread) *^ t²Ps²M + where t' = adjoint $ t :: LinearMap s v (DualVector w) + s' = adjoint $ s :: LinearMap s v (DualVector w) + tSpread = sum . map recip_t²PLUSs² $ snd (decomposeLinMap t') [] + sSpread = sum . map recip_t²PLUSs² $ snd (decomposeLinMap s') [] + t²PLUSs²@(Norm t²Ps²M) + = transformNorm t euclideanNorm <> transformNorm s euclideanNorm :: Norm w + recip_t²PLUSs² = normSq (dualNorm t²PLUSs²) :: DualVector w -> s -instance (RealDimension n, LocallyScalable n a, SimpleSpace (Needle a)) +instance ( RealDimension n, WithField n Manifold a + , LocallyScalable n a, SimpleSpace (Needle a)) => Num (RWDfblFuncValue n a n) where fromInteger i = point $ fromInteger i (+) = (^+^) @@ -933,8 +982,8 @@ in case f'*g' of 0 -> AffinDiffableEndo $ const (aof*aog) f'g' -> -} Differentiable $ - \d -> let (fd,ϕf) = toOffset'Slope af d - (gd,ϕg) = toOffset'Slope ag d + \d -> let (fd,ϕf) = evalAffine af d + (gd,ϕg) = evalAffine ag d jf = ϕf $ 1; jg = ϕg $ 1 invf'g' = recip $ jf*jg in ( fd*gd @@ -971,7 +1020,8 @@ | a₀<0 = (negativePreRegion, pure (const $ -1)) | otherwise = (positivePreRegion, pure (const 1)) -instance (RealDimension n, LocallyScalable n a, SimpleSpace (Needle a)) +instance ( RealDimension n, WithField n Manifold a + , LocallyScalable n a, SimpleSpace (Needle a)) => Fractional (RWDfblFuncValue n a n) where fromRational i = point $ fromRational i recip = postCompRW . RWDiffable $ \a₀ -> if a₀<0 @@ -999,7 +1049,8 @@ -instance (RealDimension n, LocallyScalable n a, SimpleSpace (Needle a)) +instance ( RealDimension n, WithField n Manifold a + , LocallyScalable n a, SimpleSpace (Needle a) ) => Floating (RWDfblFuncValue n a n) where pi = point pi @@ -1176,19 +1227,20 @@ -- _ 'Control.Applicative.*>' a = Nothing -- @ (?->) :: ( RealDimension n, LocallyScalable n a, LocallyScalable n b, LocallyScalable n c + , Manifold b, Manifold c , SimpleSpace (Needle b), SimpleSpace (Needle c) ) => RWDfblFuncValue n c a -> RWDfblFuncValue n c b -> RWDfblFuncValue n c b ConstRWDFV _ ?-> f = f RWDFV_IdVar ?-> f = f GenericRWDFV (RWDiffable r) ?-> ConstRWDFV c = GenericRWDFV (RWDiffable s) where s x₀ = case r x₀ of - (rd, Option (Just q)) -> (rd, return $ const c) - (rd, Option Nothing) -> (rd, empty) + (rd, Just q) -> (rd, return $ const c) + (rd, Nothing) -> (rd, empty) GenericRWDFV (RWDiffable f) ?-> GenericRWDFV (RWDiffable g) = GenericRWDFV (RWDiffable h) where h x₀ = case f x₀ of - (rf, Option (Just _)) | (rg, q) <- g x₀ + (rf, Just _) | (rg, q) <- g x₀ -> (unsafePreRegionIntersect rf rg, q) - (rf, Option Nothing) -> (rf, empty) + (rf, Nothing) -> (rf, empty) c ?-> f = c ?-> genericiseRWDFV f positiveRegionalId :: RealDimension n => RWDiffable n n n @@ -1202,12 +1254,12 @@ -- allows chaining of comparison operators like in Python.) -- Note that less-than comparison is -- to less-or-equal comparison, because there is no such thing as equality. -(?>) :: (RealDimension n, LocallyScalable n a, SimpleSpace (Needle a)) +(?>) :: (RealDimension n, LocallyScalable n a, Manifold a, SimpleSpace (Needle a)) => RWDfblFuncValue n a n -> RWDfblFuncValue n a n -> RWDfblFuncValue n a n a ?> b = (positiveRegionalId $~ a-b) ?-> b -- | Return the RHS, if it is greater than the LHS. -(?<) :: (RealDimension n, LocallyScalable n a, SimpleSpace (Needle a)) +(?<) :: (RealDimension n, LocallyScalable n a, Manifold a, SimpleSpace (Needle a)) => RWDfblFuncValue n a n -> RWDfblFuncValue n a n -> RWDfblFuncValue n a n ConstRWDFV a ?< RWDFV_IdVar = GenericRWDFV . RWDiffable $ \x₀ -> if a < x₀ then ( preRegionToInfFrom a @@ -1231,18 +1283,19 @@ -- -- Basically a weaker and agent-ised version of 'backupRegions'. (?|:) :: ( RealDimension n, LocallyScalable n a, LocallyScalable n b + , Manifold a, Manifold b , SimpleSpace (Needle a), SimpleSpace (Needle b) ) => RWDfblFuncValue n a b -> RWDfblFuncValue n a b -> RWDfblFuncValue n a b ConstRWDFV c ?|: _ = ConstRWDFV c RWDFV_IdVar ?|: _ = RWDFV_IdVar GenericRWDFV (RWDiffable f) ?|: ConstRWDFV c = GenericRWDFV (RWDiffable h) where h x₀ = case f x₀ of - (rd, Option (Just q)) -> (rd, Option (Just q)) - (rd, Option Nothing) -> (rd, Option . Just $ const c) + (rd, Just q) -> (rd, Just q) + (rd, Nothing) -> (rd, Just $ const c) GenericRWDFV (RWDiffable f) ?|: GenericRWDFV (RWDiffable g) = GenericRWDFV (RWDiffable h) where h x₀ = case f x₀ of - (rf, Option (Just q)) -> (rf, pure q) - (rf, Option Nothing) | (rg, q) <- g x₀ + (rf, Just q) -> (rf, pure q) + (rf, Nothing) | (rg, q) <- g x₀ -> (unsafePreRegionIntersect rf rg, q) c ?|: f = c ?|: genericiseRWDFV f @@ -1252,8 +1305,8 @@ => RWDiffable n a b -> RWDiffable n a b -> RWDiffable n a b backupRegions (RWDiffable f) (RWDiffable g) = RWDiffable h where h x₀ = case f x₀ of - (rf, q@(Option (Just _))) -> (rf, q) - (rf, Option Nothing) | (rg, q) <- g x₀ + (rf, q@(Just _)) -> (rf, q) + (rf, Nothing) | (rg, q) <- g x₀ -> (unsafePreRegionIntersect rf rg, q) @@ -1262,7 +1315,8 @@ -- | Like 'Data.VectorSpace.lerp', but gives a differentiable function -- instead of a Hask one. -lerp_diffable :: (WithField s LinearManifold m, RealDimension s) +lerp_diffable :: ( WithField s LinearManifold m, Atlas m + , HasTrie (ChartIndex m), RealDimension s ) => m -> m -> Differentiable s s m lerp_diffable a b = actuallyAffine a . arr $ flipBilin scale $ b.-.a diff --git a/Data/Function/Differentiable/Data.hs b/Data/Function/Differentiable/Data.hs --- a/Data/Function/Differentiable/Data.hs +++ b/Data/Function/Differentiable/Data.hs @@ -61,7 +61,7 @@ -- some error margin ) ) -> Differentiable s d c - AffinDiffable :: (AffineManifold d, AffineManifold c) + AffinDiffable :: (CC.Object (Affine s) d, CC.Object (Affine s) c) => DiffableEndoProof d c -> Affine s d c -> Differentiable s d c @@ -129,8 +129,8 @@ -- @ newtype RWDiffable s d c = RWDiffable { - tryDfblDomain :: d -> (PreRegion s d, Option (Differentiable s d c)) } + tryDfblDomain :: d -> (PreRegion s d, Maybe (Differentiable s d c)) } -notDefinedHere :: Option (Differentiable s d c) -notDefinedHere = Option Nothing +notDefinedHere :: Maybe (Differentiable s d c) +notDefinedHere = Nothing diff --git a/Data/Manifold/Atlas.hs b/Data/Manifold/Atlas.hs new file mode 100644 --- /dev/null +++ b/Data/Manifold/Atlas.hs @@ -0,0 +1,80 @@ +-- | +-- Module : Data.Manifold.Atlas +-- Copyright : (c) Justus Sagemüller 2015 +-- License : GPL v3 +-- +-- Maintainer : (@) sagemueller $ geo.uni-koeln.de +-- Stability : experimental +-- Portability : portable +-- + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE EmptyDataDecls, EmptyCase #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.Manifold.Atlas where + +import Prelude as Hask + +import Data.VectorSpace +import Data.Manifold.PseudoAffine +import Data.Manifold.Types.Primitive + +import Data.Void + +import Data.VectorSpace.Free + +import Control.Arrow + +class Semimanifold m => Atlas m where + type ChartIndex m :: * + chartReferencePoint :: ChartIndex m -> m + chartReferencePoint = fromInterior . interiorChartReferencePoint ([]::[m]) + interiorChartReferencePoint :: Hask.Functor p => p m -> ChartIndex m -> Interior m + lookupAtlas :: m -> ChartIndex m + +#define VectorSpaceAtlas(c,v) \ +instance (c) => Atlas (v) where { \ + type ChartIndex (v) = (); \ + interiorChartReferencePoint _ () = zeroV; \ + chartReferencePoint () = zeroV; \ + lookupAtlas _ = () } + +VectorSpaceAtlas((), ZeroDim s) +VectorSpaceAtlas((), ℝ) +VectorSpaceAtlas(Num s, V0 s) +VectorSpaceAtlas(Num s, V1 s) +VectorSpaceAtlas(Num s, V2 s) +VectorSpaceAtlas(Num s, V3 s) +VectorSpaceAtlas(Num s, V4 s) + +instance (Atlas x, Atlas y) => Atlas (x,y) where + type ChartIndex (x,y) = (ChartIndex x, ChartIndex y) + chartReferencePoint = chartReferencePoint *** chartReferencePoint + interiorChartReferencePoint p + = interiorChartReferencePoint (fst<$>p) *** interiorChartReferencePoint (snd<$>p) + lookupAtlas = lookupAtlas *** lookupAtlas + +instance Atlas S⁰ where + type ChartIndex S⁰ = S⁰ + chartReferencePoint = id + interiorChartReferencePoint _ = id + lookupAtlas = id +instance Atlas S¹ where + type ChartIndex S¹ = S⁰ + chartReferencePoint NegativeHalfSphere = S¹ $ -pi/2 + chartReferencePoint PositiveHalfSphere = S¹ $ pi/2 + interiorChartReferencePoint _ NegativeHalfSphere = S¹ $ -pi/2 + interiorChartReferencePoint _ PositiveHalfSphere = S¹ $ pi/2 + lookupAtlas (S¹ φ) | φ<0 = NegativeHalfSphere + | otherwise = PositiveHalfSphere +instance Atlas S² where + type ChartIndex S² = S⁰ + chartReferencePoint PositiveHalfSphere = S² 0 0 + chartReferencePoint NegativeHalfSphere = S² pi 0 + interiorChartReferencePoint _ PositiveHalfSphere = S² 0 0 + interiorChartReferencePoint _ NegativeHalfSphere = S² pi 0 + lookupAtlas (S² ϑ _) | ϑ CD¹ m fromCD¹Interior = embCℝayToCD¹ . fromCℝayInterior - toCℝayInterior :: Cℝay m -> Option (ConeVecArr m) + toCℝayInterior :: Cℝay m -> Maybe (ConeVecArr m) toCℝayInterior = toCD¹Interior . embCℝayToCD¹ - toCD¹Interior :: CD¹ m -> Option (ConeVecArr m) + toCD¹Interior :: CD¹ m -> Maybe (ConeVecArr m) toCD¹Interior = toCℝayInterior . projCD¹ToCℝay @@ -93,7 +92,7 @@ where Tagged ctp' = translateP :: Tagged (ConeVecArr m) (ConeVecArr m -> ConeNeedle m -> ConeVecArr m) semimanifoldWitness = case semimanifoldWitness :: SemimanifoldWitness (ConeVecArr m) of - SemimanifoldWitness -> SemimanifoldWitness + SemimanifoldWitness BoundarylessWitness -> SemimanifoldWitness BoundarylessWitness instance (ConeSemimfd m) => Semimanifold (CD¹ m) where type Needle (CD¹ m) = ConeNeedle m @@ -106,7 +105,7 @@ where Tagged ctp' = translateP :: Tagged (ConeVecArr m) (ConeVecArr m -> ConeNeedle m -> ConeVecArr m) semimanifoldWitness = case semimanifoldWitness :: SemimanifoldWitness (ConeVecArr m) of - SemimanifoldWitness -> SemimanifoldWitness + SemimanifoldWitness BoundarylessWitness -> SemimanifoldWitness BoundarylessWitness diff --git a/Data/Manifold/DifferentialEquation.hs b/Data/Manifold/DifferentialEquation.hs --- a/Data/Manifold/DifferentialEquation.hs +++ b/Data/Manifold/DifferentialEquation.hs @@ -34,21 +34,24 @@ module Data.Manifold.DifferentialEquation ( -- * Formulating simple differential eqns. DifferentialEqn - , constLinearDEqn + , constLinearODE + , constLinearPDE , filterDEqnSolution_static, iterateFilterDEqn_static -- * Cost functions for error bounds , maxDeviationsGoal , uncertaintyGoal , uncertaintyGoal' , euclideanVolGoal + -- * Solver configuration + , InconsistencyStrategy(..) ) where import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE -import Data.Semigroup import Data.VectorSpace +import Data.VectorSpace.Free import Math.LinearMap.Category import Data.AffineSpace import Data.Basis @@ -76,16 +79,39 @@ import Data.Traversable.Constrained (Traversable, traverse) -constLinearDEqn :: ( WithField ℝ LinearManifold x, SimpleSpace x - , WithField ℝ LinearManifold y, SimpleSpace y ) - => (DualVector y +> (y +> x)) -> DifferentialEqn x y -constLinearDEqn bwt = factoriseShade - >>> \(_x, Shade y δy) -> let j = bwt'inv y - δj = bwt' `transformNorm` dualNorm δy - in Shade' j δj - where bwt' = adjoint $ bwt - bwt'inv = (bwt'\$) +constLinearODE :: ∀ x y . ( WithField ℝ LinearManifold x, SimpleSpace x + , WithField ℝ LinearManifold y, SimpleSpace y ) + => ((x +> y) +> y) -> DifferentialEqn x y +constLinearODE = case ( dualSpaceWitness :: DualNeedleWitness x + , dualSpaceWitness :: DualNeedleWitness y ) of + (DualSpaceWitness, DualSpaceWitness) -> \bwt' -> + let bwt'inv = (bwt'\$) + in \(Shade (_x,y) δxy) -> LocalDifferentialEqn + (let j = bwt'inv y + δj = (bwt'>>>zeroV&&&id) `transformNorm` dualNorm δxy + in return $ Shade' j δj ) + (\_ -> pure ) + +constLinearPDE :: ∀ x y y' . + ( WithField ℝ LinearManifold x, SimpleSpace x + , WithField ℝ LinearManifold y, SimpleSpace y, FiniteFreeSpace y + , WithField ℝ LinearManifold y', SimpleSpace y' ) + => ((x +> (y,y')) +> (y, y')) -> DifferentialEqn x (y,y') +constLinearPDE = undefined{-case ( dualSpaceWitness :: DualNeedleWitness x + , dualSpaceWitness :: DualNeedleWitness y + , dualSpaceWitness :: DualSpaceWitness y' ) of + (DualSpaceWitness, DualSpaceWitness, DualSpaceWitness) -> \bwt' -> + let bwt'inv = (bwt'\$) + in \(Shade (_x,(y,y')) δxy) (Shade' jApriori σjApriori) + -> let j = bwt'inv $ (zeroV,y') + δj = (bwt'>>>zeroV&&&id) + `transformNorm` dualNorm δxy + (_,y'Apriori) = bwt' $ jApriori + Norm δy' = (arr $ LinearFunction bwt'inv . (zeroV&&&id)) + `transformNorm` σjApriori + in (Shade' (y,y'Apriori) . Norm $ zeroV *** δy' , ) + <$> mixShade's (Shade' jApriori σjApriori :| [Shade' j δj])-} -- | A function that variates, relatively speaking, most strongly -- for arguments around 1. In the zero-limit it approaches a constant diff --git a/Data/Manifold/Griddable.hs b/Data/Manifold/Griddable.hs --- a/Data/Manifold/Griddable.hs +++ b/Data/Manifold/Griddable.hs @@ -110,8 +110,10 @@ | n < 0 = floor $ lg (-n) -instance ( SimpleSpace (Needle m), SimpleSpace (Needle n), SimpleSpace (Needle a) - , Griddable m a, Griddable n a ) => Griddable (m,n) a where +instance ∀ m n a + . ( SimpleSpace (Needle m), SimpleSpace (Needle n), SimpleSpace (Needle a) + , Griddable m a, Griddable n a, m ~ Interior m, n ~ Interior n ) + => Griddable (m,n) a where data GriddingParameters (m,n) a = PairGriddingParameters { fstGriddingParams :: GriddingParameters m a , sndGriddingParams :: GriddingParameters n a } @@ -124,7 +126,9 @@ <$> g₂s ) where g₁s = mkGridding p₁ n $ fullShade c₁ e₁ g₂s = mkGridding p₂ n $ fullShade c₂ e₂ - (e₁,e₂) = summandSpaceNorms e₁e₂ + (e₁,e₂) = case ( dualSpaceWitness :: DualNeedleWitness m + , dualSpaceWitness :: DualNeedleWitness n ) of + (DualSpaceWitness, DualSpaceWitness) -> summandSpaceNorms e₁e₂ prettyFloatShow :: Int -> Double -> String prettyFloatShow _ 0 = "0" diff --git a/Data/Manifold/PseudoAffine.hs b/Data/Manifold/PseudoAffine.hs --- a/Data/Manifold/PseudoAffine.hs +++ b/Data/Manifold/PseudoAffine.hs @@ -34,6 +34,7 @@ {-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ConstraintKinds #-} @@ -53,11 +54,17 @@ , Semimanifold(..), Needle' , PseudoAffine(..) -- * Type definitions + -- ** Needles + , Local(..) -- ** Metrics , Metric, Metric', euclideanMetric , RieMetric, RieMetric' -- ** Constraints , SemimanifoldWitness(..) + , PseudoAffineWitness(..) + , BoundarylessWitness(..) + , boundarylessWitness + , DualNeedleWitness , RealDimension, AffineManifold , LinearManifold , WithField @@ -72,9 +79,9 @@ ) where +import Math.Manifold.Core.PseudoAffine import Data.Maybe -import Data.Semigroup import Data.Fixed import Data.VectorSpace @@ -104,146 +111,15 @@ import GHC.Exts (Constraint) - --- | This is the reified form of the property that the interior of a semimanifold --- is a manifold. -data SemimanifoldWitness x where - SemimanifoldWitness :: - ( Semimanifold (Interior x), Semimanifold (Needle x) - , Interior (Interior x) ~ Interior x, Needle (Interior x) ~ Needle x - , Interior (Needle x) ~ Needle x ) - => SemimanifoldWitness x - - -infix 6 .-~. -infixl 6 .+~^, .-~^ - -class AdditiveGroup (Needle x) => Semimanifold x where - {-# MINIMAL ((.+~^) | fromInterior), toInterior, translateP #-} - -- | The space of “natural” ways starting from some reference point - -- and going to some particular target point. Hence, - -- the name: like a compass needle, but also with an actual length. - -- For affine spaces, 'Needle' is simply the space of - -- line segments (aka vectors) between two points, i.e. the same as 'Diff'. - -- The 'AffineManifold' constraint makes that requirement explicit. - -- - -- This space should be isomorphic to the tangent space (and is in fact - -- used somewhat synonymously). - type Needle x :: * - -- | Manifolds with boundary are a bit tricky. We support such manifolds, - -- but carry out most calculations only in “the fleshy part” – the - -- interior, which is an “infinite space”, so you can arbitrarily scale paths. - -- - -- The default implementation is @'Interior' x = x@, which corresponds - -- to a manifold that has no boundary to begin with. - type Interior x :: * - type Interior x = x - -- | Generalised translation operation. Note that the result will always also - -- be in the interior; scaling up the needle can only get you ever /closer/ - -- to a boundary. - (.+~^) :: Interior x -> Needle x -> x - (.+~^) = addvp - where addvp :: ∀ x . Semimanifold x => Interior x -> Needle x -> x - addvp p = fromInterior . tp p - where (Tagged tp) = translateP :: Tagged x (Interior x -> Needle x -> Interior x) - - -- | 'id' sans boundary. - fromInterior :: Interior x -> x - fromInterior p = p .+~^ zeroV - - toInterior :: x -> Option (Interior x) - - -- | The signature of '.+~^' should really be @'Interior' x -> 'Needle' x -> 'Interior' x@, - -- only, this is not possible because it only consists of non-injective type families. - -- The solution is this tagged signature, which is of course rather unwieldy. That's - -- why '.+~^' has the stronger, but easier usable signature. Without boundary, these - -- functions should be equivalent, i.e. @translateP = Tagged (.+~^)@. - translateP :: Tagged x (Interior x -> Needle x -> Interior x) - - -- | Shorthand for @\\p v -> p .+~^ 'negateV' v@, which should obey the /asymptotic/ law - -- - -- @ - -- p .-~^ v .+~^ v ≅ p - -- @ - -- - -- Meaning: if @v@ is scaled down with sufficiently small factors /η/, then - -- the difference @(p.-~^v.+~^v) .-~. p@ should scale down even faster: - -- as /O/ (/η/²). For large vectors, it will however behave differently, - -- except in flat spaces (where all this should be equivalent to the 'AffineSpace' - -- instance). - (.-~^) :: Interior x -> Needle x -> x - p .-~^ v = p .+~^ negateV v - - semimanifoldWitness :: SemimanifoldWitness x - default semimanifoldWitness :: - ( Semimanifold (Interior x), Semimanifold (Needle x) - , Interior (Interior x) ~ Interior x, Needle (Interior x) ~ Needle x - , Interior (Needle x) ~ Needle x ) - => SemimanifoldWitness x - semimanifoldWitness = SemimanifoldWitness - --- | This is the class underlying manifolds. ('Manifold' only precludes boundaries --- and adds an extra constraint that would be circular if it was in a single --- class. You can always just use 'Manifold' as a constraint in your signatures, --- but you must /define/ only 'PseudoAffine' for manifold types – --- the 'Manifold' instance follows universally from this, if @'Interior x ~ x@.) --- --- The interface is (boundaries aside) almost identical to the better-known --- 'AffineSpace' class, but we don't require associativity of '.+~^' with '^+^' --- – except in an /asymptotic sense/ for small vectors. --- --- That innocent-looking change makes the class applicable to vastly more general types: --- while an affine space is basically nothing but a vector space without particularly --- designated origin, a pseudo-affine space can have nontrivial topology on the global --- scale, and yet be used in practically the same way as an affine space. At least the --- usual spheres and tori make good instances, perhaps the class is in fact equivalent to --- manifolds in their usual maths definition (with an atlas of charts: a family of --- overlapping regions of the topological space, each homeomorphic to the 'Needle' --- vector space or some simply-connected subset thereof). -class ( Semimanifold x, Semimanifold (Interior x) - , Needle (Interior x) ~ Needle x, Interior (Interior x) ~ Interior x) - => PseudoAffine x where - {-# MINIMAL (.-~.) | (.-~!) #-} - -- | The path reaching from one point to another. - -- Should only yield 'Nothing' if - -- - -- * The points are on disjoint segments of a non–path-connected space. - -- - -- * Either of the points is on the boundary. Use '|-~.' to deal with this. - -- - -- On manifolds, the identity - -- - -- @ - -- p .+~^ (q.-~.p) ≡ q - -- @ - -- - -- should hold, at least save for floating-point precision limits etc.. - -- - -- '.-~.' and '.+~^' only really work in manifolds without boundary. If you consider - -- the path between two points, one of which lies on the boundary, it can't really - -- be possible to scale this path any longer – it would have to reach “out of the - -- manifold”. To adress this problem, these functions basically consider only the - -- /interior/ of the space. - (.-~.) :: x -> Interior x -> Option (Needle x) - p.-~.q = return $ p.-~!q - - -- | Unsafe version of '.-~.'. If the two points lie in disjoint regions, - -- the behaviour is undefined. - (.-~!) :: x -> Interior x -> Needle x - p.-~!q = case p.-~.q of - Option (Just v) -> v - - - - - - -- | See 'Semimanifold' and 'PseudoAffine' for the methods. -class (PseudoAffine m, LinearManifold (Needle m), Interior m ~ m) => Manifold m -instance (PseudoAffine m, LinearManifold (Needle m), Interior m ~ m) => Manifold m +class (PseudoAffine m, LSpace (Needle m)) => Manifold m where + boundarylessWitness :: BoundarylessWitness m + default boundarylessWitness :: (m ~ Interior m) => BoundarylessWitness m + boundarylessWitness = BoundarylessWitness +instance (PseudoAffine m, LSpace (Needle m), Interior m ~ m) => Manifold m @@ -293,11 +169,15 @@ data CanonicalDiffeomorphism a b where CanonicalDiffeomorphism :: LocallyCoercible a b => CanonicalDiffeomorphism a b +-- | A point on a manifold, as seen from a nearby reference point. +newtype Local x = Local { getLocalOffset :: Needle x } +deriving instance (Show (Needle x)) => Show (Local x) type LocallyScalable s x = ( PseudoAffine x , LSpace (Needle x) , s ~ Scalar (Needle x) - , Num''' s ) + , s ~ Scalar (Needle' x) + , Num' s ) type LocalLinear x y = LinearMap (Scalar (Needle x)) (Needle x) (Needle y) type LocalAffine x y = (Needle y, LocalLinear x y) @@ -316,7 +196,7 @@ -- general need the @-XLiberalTypeSynonyms@ extension (except if the constraint -- is an actual type class (like 'Manifold'): only those can always be partially -- applied, for @type@ constraints this is by default not allowed). -type WithField s c x = ( c x, s ~ Scalar (Needle x) ) +type WithField s c x = ( c x, s ~ Scalar (Needle x), s ~ Scalar (Needle' x) ) -- | The 'RealFloat' class plus manifold constraints. type RealDimension r = ( PseudoAffine r, Interior r ~ r, Needle r ~ r, r ~ ℝ) @@ -339,7 +219,7 @@ type EuclidSpace x = ( AffineManifold x, InnerSpace (Diff x) , DualVector (Diff x) ~ Diff x, Floating (Scalar (Diff x)) ) -type NumberManifold n = ( Num''' n, Manifold n, Interior n ~ n, Needle n ~ n +type NumberManifold n = ( Num' n, Manifold n, Interior n ~ n, Needle n ~ n , LSpace n, DualVector n ~ n, Scalar n ~ n ) euclideanMetric :: EuclidSpace x => proxy x -> Metric x @@ -372,49 +252,28 @@ coerceMetric :: ∀ x ξ . (LocallyCoercible x ξ, LSpace (Needle ξ)) => RieMetric ξ -> RieMetric x -coerceMetric m x = case m $ locallyTrivialDiffeomorphism x of +coerceMetric = case ( dualSpaceWitness :: DualNeedleWitness x + , dualSpaceWitness :: DualNeedleWitness ξ ) of + (DualSpaceWitness, DualSpaceWitness) + -> \m x -> case m $ locallyTrivialDiffeomorphism x of Norm sc -> Norm $ bw . sc . fw where fw = coerceNeedle ([]::[(x,ξ)]) bw = case oppositeLocalCoercion :: CanonicalDiffeomorphism ξ x of CanonicalDiffeomorphism -> coerceNeedle' ([]::[(ξ,x)]) coerceMetric' :: ∀ x ξ . (LocallyCoercible x ξ, LSpace (Needle ξ)) => RieMetric' ξ -> RieMetric' x -coerceMetric' m x = case m $ locallyTrivialDiffeomorphism x of +coerceMetric' = case ( dualSpaceWitness :: DualNeedleWitness x + , dualSpaceWitness :: DualNeedleWitness ξ ) of + (DualSpaceWitness, DualSpaceWitness) + -> \m x -> case m $ locallyTrivialDiffeomorphism x of Norm sc -> Norm $ bw . sc . fw where fw = coerceNeedle' ([]::[(x,ξ)]) bw = case oppositeLocalCoercion :: CanonicalDiffeomorphism ξ x of CanonicalDiffeomorphism -> coerceNeedle ([]::[(ξ,x)]) --- | Interpolate between points, approximately linearly. For --- points that aren't close neighbours (i.e. lie in an almost --- flat region), the pathway is basically undefined – save for --- its end points. --- --- A proper, really well-defined (on global scales) interpolation --- only makes sense on a Riemannian manifold, as 'Data.Manifold.Riemannian.Geodesic'. -palerp :: ∀ x. Manifold x - => Interior x -> Interior x -> Option (Scalar (Needle x) -> x) -palerp p1 p2 = case (fromInterior p2 :: x) .-~. p1 of - Option (Just v) -> return $ \t -> p1 .+~^ t *^ v - _ -> empty --- | Like 'palerp', but actually restricted to the interval between the points, --- with a signature like 'Data.Manifold.Riemannian.geodesicBetween' --- rather than 'Data.AffineSpace.alerp'. -palerpB :: ∀ x. WithField ℝ Manifold x => Interior x -> Interior x -> Option (D¹ -> x) -palerpB p1 p2 = case (fromInterior p2 :: x) .-~. p1 of - Option (Just v) -> return $ \(D¹ t) -> p1 .+~^ ((t+1)/2) *^ v - _ -> empty --- | Like 'alerp', but actually restricted to the interval between the points. -alerpB :: ∀ x. (AffineSpace x, VectorSpace (Diff x), Scalar (Diff x) ~ ℝ) - => x -> x -> D¹ -> x -alerpB p1 p2 = case p2 .-. p1 of - v -> \(D¹ t) -> p1 .+^ ((t+1)/2) *^ v - - - hugeℝVal :: ℝ hugeℝVal = 1e+100 @@ -428,12 +287,7 @@ instance (c) => PseudoAffine (t) where { \ a.-~.b = pure (a.-.b); } -deriveAffine((),Double) -deriveAffine((),Rational) -deriveAffine(NumberManifold s, V1 s) -deriveAffine(NumberManifold s, V2 s) -deriveAffine(NumberManifold s, V3 s) -deriveAffine(NumberManifold s, V4 s) +deriveAffine(KnownNat n, FreeVect n ℝ) instance (NumberManifold s) => LocallyCoercible (ZeroDim s) (V0 s) where locallyTrivialDiffeomorphism Origin = V0 @@ -484,43 +338,12 @@ coerceNeedle _ = LinearFunction $ \(V4 x y z w) -> ((x,y),(z,w)) coerceNeedle' _ = LinearFunction $ \(V4 x y z w) -> ((x,y),(z,w)) -instance Semimanifold (ZeroDim k) where - type Needle (ZeroDim k) = ZeroDim k - fromInterior = id - toInterior = pure - Origin .+~^ Origin = Origin - Origin .-~^ Origin = Origin - translateP = Tagged (.+~^) -instance PseudoAffine (ZeroDim k) where - Origin .-~. Origin = pure Origin -instance Num k => Semimanifold (V0 k) where - type Needle (V0 k) = V0 k - fromInterior = id - toInterior = pure - V0 .+~^ V0 = V0 - V0 .-~^ V0 = V0 - translateP = Tagged (.+~^) -instance Num k => PseudoAffine (V0 k) where - V0 .-~. V0 = pure V0 -instance ∀ a b . (Semimanifold a, Semimanifold b) => Semimanifold (a,b) where - type Needle (a,b) = (Needle a, Needle b) - type Interior (a,b) = (Interior a, Interior b) - (a,b).+~^(v,w) = (a.+~^v, b.+~^w) - (a,b).-~^(v,w) = (a.-~^v, b.-~^w) - fromInterior (i,j) = (fromInterior i, fromInterior j) - toInterior (a,b) = fzip (toInterior a, toInterior b) - translateP = Tagged $ \(a,b) (v,w) -> (ta a v, tb b w) - where Tagged ta = translateP :: Tagged a (Interior a -> Needle a -> Interior a) - Tagged tb = translateP :: Tagged b (Interior b -> Needle b -> Interior b) - semimanifoldWitness = case ( semimanifoldWitness :: SemimanifoldWitness a - , semimanifoldWitness :: SemimanifoldWitness b ) of - (SemimanifoldWitness, SemimanifoldWitness) -> SemimanifoldWitness -instance (PseudoAffine a, PseudoAffine b) => PseudoAffine (a,b) where - (a,b).-~.(c,d) = liftA2 (,) (a.-~.c) (b.-~.d) instance ( Semimanifold a, Semimanifold b, Semimanifold c , LSpace (Needle a), LSpace (Needle b), LSpace (Needle c) - , Scalar (Needle a) ~ Scalar (Needle b), Scalar (Needle b) ~ Scalar (Needle c) ) + , Scalar (Needle a) ~ Scalar (Needle b), Scalar (Needle b) ~ Scalar (Needle c) + , Scalar (Needle' a) ~ Scalar (Needle a), Scalar (Needle' b) ~ Scalar (Needle b) + , Scalar (Needle' c) ~ Scalar (Needle c) ) => LocallyCoercible (a,(b,c)) ((a,b),c) where locallyTrivialDiffeomorphism = regroup coerceNeedle _ = regroup @@ -529,12 +352,16 @@ interiorLocalCoercion _ = case ( semimanifoldWitness :: SemimanifoldWitness a , semimanifoldWitness :: SemimanifoldWitness b , semimanifoldWitness :: SemimanifoldWitness c ) of - (SemimanifoldWitness, SemimanifoldWitness, SemimanifoldWitness) + ( SemimanifoldWitness BoundarylessWitness + ,SemimanifoldWitness BoundarylessWitness + ,SemimanifoldWitness BoundarylessWitness ) -> CanonicalDiffeomorphism instance ∀ a b c . ( Semimanifold a, Semimanifold b, Semimanifold c , LSpace (Needle a), LSpace (Needle b), LSpace (Needle c) - , Scalar (Needle a) ~ Scalar (Needle b), Scalar (Needle b) ~ Scalar (Needle c) ) + , Scalar (Needle a) ~ Scalar (Needle b), Scalar (Needle b) ~ Scalar (Needle c) + , Scalar (Needle' a) ~ Scalar (Needle a), Scalar (Needle' b) ~ Scalar (Needle b) + , Scalar (Needle' c) ~ Scalar (Needle c) ) => LocallyCoercible ((a,b),c) (a,(b,c)) where locallyTrivialDiffeomorphism = regroup' coerceNeedle _ = regroup' @@ -543,30 +370,12 @@ interiorLocalCoercion _ = case ( semimanifoldWitness :: SemimanifoldWitness a , semimanifoldWitness :: SemimanifoldWitness b , semimanifoldWitness :: SemimanifoldWitness c ) of - (SemimanifoldWitness, SemimanifoldWitness, SemimanifoldWitness) + ( SemimanifoldWitness BoundarylessWitness + ,SemimanifoldWitness BoundarylessWitness + ,SemimanifoldWitness BoundarylessWitness ) -> CanonicalDiffeomorphism -instance ∀ a b c . (Semimanifold a, Semimanifold b, Semimanifold c) - => Semimanifold (a,b,c) where - type Needle (a,b,c) = (Needle a, Needle b, Needle c) - type Interior (a,b,c) = (Interior a, Interior b, Interior c) - (a,b,c).+~^(v,w,x) = (a.+~^v, b.+~^w, c.+~^x) - (a,b,c).-~^(v,w,x) = (a.-~^v, b.-~^w, c.-~^x) - fromInterior (i,j,k) = (fromInterior i, fromInterior j, fromInterior k) - toInterior (a,b,c) = liftA3 (,,) (toInterior a) (toInterior b) (toInterior c) - translateP = Tagged $ \(a,b,c) (v,w,x) -> (ta a v, tb b w, tc c x) - where Tagged ta = translateP :: Tagged a (Interior a -> Needle a -> Interior a) - Tagged tb = translateP :: Tagged b (Interior b -> Needle b -> Interior b) - Tagged tc = translateP :: Tagged c (Interior c -> Needle c -> Interior c) - semimanifoldWitness = case ( semimanifoldWitness :: SemimanifoldWitness a - , semimanifoldWitness :: SemimanifoldWitness b - , semimanifoldWitness :: SemimanifoldWitness c ) of - (SemimanifoldWitness, SemimanifoldWitness, SemimanifoldWitness) - -> SemimanifoldWitness -instance (PseudoAffine a, PseudoAffine b, PseudoAffine c) => PseudoAffine (a,b,c) where - (a,b,c).-~.(d,e,f) = liftA3 (,,) (a.-~.d) (b.-~.e) (c.-~.f) - instance LinearManifold (a n) => Semimanifold (LinAff.Point a n) where type Needle (LinAff.Point a n) = a n fromInterior = id @@ -577,70 +386,8 @@ LinAff.P v .-~. LinAff.P w = return $ v ^-^ w -instance (LSpace a, LSpace b, s~Scalar a, s~Scalar b) - => Semimanifold (Tensor s a b) where - type Needle (Tensor s a b) = Tensor s a b - fromInterior = id - toInterior = pure - translateP = Tagged (.+~^) - (.+~^) = (^+^) -instance (LSpace a, LSpace b, s~Scalar a, s~Scalar b) - => PseudoAffine (Tensor s a b) where - a.-~.b = pure (a^-^b) -instance (LSpace a, LSpace b, Scalar a~s, Scalar b~s) - => Semimanifold (LinearMap s a b) where - type Needle (LinearMap s a b) = LinearMap s a b - fromInterior = id - toInterior = pure - translateP = Tagged (.+^) - (.+~^) = (^+^) -instance (LSpace a, LSpace b, Scalar a~s, Scalar b~s) - => PseudoAffine (LinearMap s a b) where - a.-~.b = pure (a^-^b) -instance Semimanifold S⁰ where - type Needle S⁰ = ZeroDim ℝ - fromInterior = id - toInterior = pure - translateP = Tagged (.+~^) - p .+~^ Origin = p - p .-~^ Origin = p -instance PseudoAffine S⁰ where - PositiveHalfSphere .-~. PositiveHalfSphere = pure Origin - NegativeHalfSphere .-~. NegativeHalfSphere = pure Origin - _ .-~. _ = Option Nothing - -instance Semimanifold S¹ where - type Needle S¹ = ℝ - fromInterior = id - toInterior = pure - translateP = Tagged (.+~^) - S¹ φ₀ .+~^ δφ - | φ' < 0 = S¹ $ φ' + tau - | otherwise = S¹ $ φ' - where φ' = toS¹range $ φ₀ + δφ -instance PseudoAffine S¹ where - S¹ φ₁ .-~. S¹ φ₀ - | δφ > pi = pure (δφ - 2*pi) - | δφ < (-pi) = pure (δφ + 2*pi) - | otherwise = pure δφ - where δφ = φ₁ - φ₀ - -instance Semimanifold D¹ where - type Needle D¹ = ℝ - type Interior D¹ = ℝ - fromInterior = D¹ . tanh - toInterior (D¹ x) | abs x < 1 = return $ atanh x - | otherwise = empty - translateP = Tagged (+) -instance PseudoAffine D¹ where - D¹ 1 .-~. _ = empty - D¹ (-1) .-~. _ = empty - D¹ x .-~. y - | abs x < 1 = return $ atanh x - y - | otherwise = empty - instance Semimanifold S² where type Needle S² = ℝ² fromInterior = id @@ -701,15 +448,9 @@ -tau :: ℝ -tau = 2 * pi -toS¹range :: ℝ -> ℝ -toS¹range φ = (φ+pi)`mod'`tau - pi - - class ImpliesMetric s where type MetricRequirement s x :: Constraint type MetricRequirement s x = Semimanifold x @@ -723,4 +464,7 @@ inferMetric = id inferMetric' = dualNorm + + +type DualNeedleWitness x = DualSpaceWitness (Needle x) diff --git a/Data/Manifold/Riemannian.hs b/Data/Manifold/Riemannian.hs --- a/Data/Manifold/Riemannian.hs +++ b/Data/Manifold/Riemannian.hs @@ -48,12 +48,12 @@ import Data.Maybe import qualified Data.Vector as Arr -import Data.Semigroup import Data.VectorSpace import Data.VectorSpace.Free import Data.AffineSpace import Math.LinearMap.Category +import Linear (V0(..), V1(..), V2(..), V3(..), V4(..)) import Data.Manifold.Types import Data.Manifold.Types.Primitive ((^), empty, embed, coEmbed) @@ -83,10 +83,10 @@ -> x -- ^ End point, for +1. -- -- If the two points are actually connected by a path... - -> Option (D¹ -> x) -- ^ ...then this is the interpolation function. Attention: - -- the type will change to 'Differentiable' in the future. + -> Maybe (D¹ -> x) -- ^ ...then this is the interpolation function. Attention: + -- the type will change to 'Differentiable' in the future. -interpolate :: (Geodesic x, IntervalLike i) => x -> x -> Option (i -> x) +interpolate :: (Geodesic x, IntervalLike i) => x -> x -> Maybe (i -> x) interpolate a b = (. toClosedInterval) <$> geodesicBetween a b @@ -157,7 +157,7 @@ -- instance Geodesic (Cℝay S¹) where -- geodesicBetween p q = (>>> fromP) <$> geodesicBetween (toP p) (toP q) -- where fromP = fromInterior --- toP w = case toInterior w of {Option (Just i) -> i} +-- toP w = case toInterior w of {Just i -> i} -- -- instance Geodesic (CD¹ S¹) where -- geodesicBetween p q = (>>> fromI) <$> geodesicBetween (toI p) (toI q) @@ -167,7 +167,7 @@ -- instance Geodesic (Cℝay S²) where -- geodesicBetween p q = (>>> fromP) <$> geodesicBetween (toP p) (toP q) -- where fromP = fromInterior --- toP w = case toInterior w of {Option (Just i) -> i} +-- toP w = case toInterior w of {Just i -> i} -- -- instance Geodesic (CD¹ S²) where -- geodesicBetween p q = (>>> fromI) <$> geodesicBetween (toI p) (toI q :: ℝ³) @@ -192,6 +192,11 @@ -- , Geodesic (a,b)), (a,b)) -- geoVSpCone (KnownNat n, FreeVect n ℝ) +deriveAffineGD ((V0 ℝ)) +deriveAffineGD (ℝ¹) +deriveAffineGD (ℝ²) +deriveAffineGD (ℝ³) +deriveAffineGD (ℝ⁴) @@ -223,3 +228,9 @@ instance Riemannian ℝ where rieMetric = const euclideanNorm + + + + +middleBetween :: Geodesic m => m -> m -> Maybe m +middleBetween p₀ p₁ = ($ D¹ 0) <$> geodesicBetween p₀ p₁ diff --git a/Data/Manifold/TreeCover.hs b/Data/Manifold/TreeCover.hs --- a/Data/Manifold/TreeCover.hs +++ b/Data/Manifold/TreeCover.hs @@ -30,1585 +30,1859 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE LiberalTypeSynonyms #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DataKinds #-} - - -module Data.Manifold.TreeCover ( - -- * Shades - Shade(..), pattern(:±), Shade'(..), (|±|), IsShade - -- ** Lenses - , shadeCtr, shadeExpanse, shadeNarrowness - -- ** Construction - , fullShade, fullShade', pointsShades, pointsShade's, pointsCovers, pointsCover's - -- ** Evaluation - , occlusion - -- ** Misc - , factoriseShade, intersectShade's - , Refinable, subShade', refineShade', convolveShade', coerceShade - -- * Shade trees - , ShadeTree(..), fromLeafPoints, onlyLeaves, indexShadeTree, positionIndex - -- * View helpers - , onlyNodes - -- ** Auxiliary types - , SimpleTree, Trees, NonEmptyTree, GenericTree(..) - -- * Misc - , sShSaw, chainsaw, HasFlatView(..), shadesMerge, smoothInterpolate - , twigsWithEnvirons, Twig, TwigEnviron - , completeTopShading, flexTwigsShading - , WithAny(..), Shaded, fmapShaded, stiAsIntervalMapping, spanShading - , constShaded, stripShadedUntopological - , DifferentialEqn, propagateDEqnSolution_loc - -- ** Triangulation-builders - , TriangBuild, doTriangBuild - , AutoTriang, breakdownAutoTriang - ) where - - -import Data.List hiding (filter, all, elem, sum, foldr1) -import Data.Maybe -import qualified Data.Map as Map -import qualified Data.Vector as Arr -import Data.List.NonEmpty (NonEmpty(..)) -import Data.List.FastNub -import qualified Data.List.NonEmpty as NE -import Data.Semigroup -import Data.Ord (comparing) -import Control.DeepSeq - -import Data.VectorSpace -import Data.AffineSpace -import Math.LinearMap.Category -import Data.Tagged - -import Data.SimplicialComplex -import Data.Manifold.Types -import Data.Manifold.Types.Primitive ((^), empty) -import Data.Manifold.PseudoAffine -import Data.Manifold.Riemannian - -import Data.Embedding -import Data.CoNat - -import Lens.Micro (Lens') - -import qualified Prelude as Hask hiding(foldl, sum, sequence) -import qualified Control.Applicative as Hask -import qualified Control.Monad as Hask hiding(forM_, sequence) -import Data.Functor.Identity -import Control.Monad.Trans.State -import Control.Monad.Trans.Writer -import Control.Monad.Trans.OuterMaybe -import Control.Monad.Trans.Class -import qualified Data.Foldable as Hask -import Data.Foldable (all, elem, toList, sum, foldr1) -import qualified Data.Traversable as Hask -import Data.Traversable (forM) - -import Control.Category.Constrained.Prelude hiding - ((^), all, elem, sum, forM, Foldable(..), foldr1, Traversable, traverse) -import Control.Arrow.Constrained -import Control.Monad.Constrained hiding (forM) -import Data.Foldable.Constrained -import Data.Traversable.Constrained (traverse) - -import GHC.Generics (Generic) -import Data.Type.Coercion - - --- | Possibly / Partially / asymPtotically singular metric. -data PSM x = PSM { - psmExpanse :: !(Metric' x) - , relevantEigenspan :: ![Needle' x] - } - - --- | A 'Shade' is a very crude description of a region within a manifold. It --- can be interpreted as either an ellipsoid shape, or as the Gaussian peak --- of a normal distribution (use --- for actually sampling from that distribution). --- --- For a /precise/ description of an arbitrarily-shaped connected subset of a manifold, --- there is 'Region', whose implementation is vastly more complex. -data Shade x = Shade { _shadeCtr :: !(Interior x) - , _shadeExpanse :: !(Metric' x) } -deriving instance (Show x, Show (Metric' x), WithField ℝ Manifold x) => Show (Shade x) - --- | A “co-shade” can describe ellipsoid regions as well, but unlike --- 'Shade' it can be unlimited / infinitely wide in some directions. --- It does OTOH need to have nonzero thickness, which 'Shade' needs not. -data Shade' x = Shade' { _shade'Ctr :: !(Interior x) - , _shade'Narrowness :: !(Metric x) } -deriving instance (Show x, Show (Metric x), WithField ℝ Manifold x) => Show (Shade' x) - -class IsShade shade where --- type (*) shade :: *->* - -- | Access the center of a 'Shade' or a 'Shade''. - shadeCtr :: Lens' (shade x) (Interior x) --- -- | Convert between 'Shade' and 'Shade' (which must be neither singular nor infinite). --- unsafeDualShade :: WithField ℝ Manifold x => shade x -> shade* x - -- | Check the statistical likelihood-density of a point being within a shade. - -- This is taken as a normal distribution. - occlusion :: ( Manifold x, SimpleSpace (Needle x) - , s ~ (Scalar (Needle x)), RealDimension s ) - => shade x -> x -> s - factoriseShade :: ( Manifold x, SimpleSpace (Needle x) - , Manifold y, SimpleSpace (Needle y) - , Scalar (Needle x) ~ Scalar (Needle y) ) - => shade (x,y) -> (shade x, shade y) - coerceShade :: (Manifold x, Manifold y, LocallyCoercible x y) => shade x -> shade y - -instance IsShade Shade where - shadeCtr f (Shade c e) = fmap (`Shade`e) $ f c - occlusion (Shade p₀ δ) = occ - where occ p = case p .-~. p₀ of - Option(Just vd) | mSq <- normSq δinv vd - , mSq == mSq -- avoid NaN - -> exp (negate mSq) - _ -> zeroV - δinv = dualNorm δ - factoriseShade (Shade (x₀,y₀) δxy) = (Shade x₀ δx, Shade y₀ δy) - where (δx,δy) = summandSpaceNorms δxy - coerceShade = cS - where cS :: ∀ x y . (LocallyCoercible x y) => Shade x -> Shade y - cS = \(Shade x δxym) -> Shade (internCoerce x) (tN δxym) - where tN = case oppositeLocalCoercion :: CanonicalDiffeomorphism y x of - CanonicalDiffeomorphism -> - transformNorm . arr $ coerceNeedle' ([]::[(y,x)]) - internCoerce = case interiorLocalCoercion ([]::[(x,y)]) of - CanonicalDiffeomorphism -> locallyTrivialDiffeomorphism - -instance ImpliesMetric Shade where - type MetricRequirement Shade x = (Manifold x, SimpleSpace (Needle x)) - inferMetric' (Shade _ e) = e - inferMetric (Shade _ e) = dualNorm e - -instance ImpliesMetric Shade' where - type MetricRequirement Shade' x = (Manifold x, SimpleSpace (Needle x)) - inferMetric (Shade' _ e) = e - inferMetric' (Shade' _ e) = dualNorm e - -shadeExpanse :: Lens' (Shade x) (Metric' x) -shadeExpanse f (Shade c e) = fmap (Shade c) $ f e - -instance IsShade Shade' where - shadeCtr f (Shade' c e) = fmap (`Shade'`e) $ f c - occlusion (Shade' p₀ δinv) = occ - where occ p = case p .-~. p₀ of - Option(Just vd) | mSq <- normSq δinv vd - , mSq == mSq -- avoid NaN - -> exp (negate mSq) - _ -> zeroV - factoriseShade (Shade' (x₀,y₀) δxy) = (Shade' x₀ δx, Shade' y₀ δy) - where (δx,δy) = summandSpaceNorms δxy - coerceShade = cS - where cS :: ∀ x y . (LocallyCoercible x y) => Shade' x -> Shade' y - cS = \(Shade' x δxym) -> Shade' (internCoerce x) (tN δxym) - where tN = case oppositeLocalCoercion :: CanonicalDiffeomorphism y x of - CanonicalDiffeomorphism -> - transformNorm . arr $ coerceNeedle ([]::[(y,x)]) - internCoerce = case interiorLocalCoercion ([]::[(x,y)]) of - CanonicalDiffeomorphism -> locallyTrivialDiffeomorphism - -shadeNarrowness :: Lens' (Shade' x) (Metric x) -shadeNarrowness f (Shade' c e) = fmap (Shade' c) $ f e - -instance (AffineManifold x) => Semimanifold (Shade x) where - type Needle (Shade x) = Diff x - fromInterior = id - toInterior = pure - translateP = Tagged (.+~^) - Shade c e .+~^ v = Shade (c.+^v) e - Shade c e .-~^ v = Shade (c.-^v) e - -instance (WithField ℝ AffineManifold x, Geodesic x, SimpleSpace (Needle x)) - => Geodesic (Shade x) where - geodesicBetween (Shade c e) (Shade ζ η) = pure interp - where sharedSpan = sharedNormSpanningSystem e η - interp t = Shade (pinterp t) - (spanNorm [ v ^* (alerpB 1 qη t) - | (v,qη) <- sharedSpan ]) - Option (Just pinterp) = geodesicBetween c ζ - -instance (AffineManifold x) => Semimanifold (Shade' x) where - type Needle (Shade' x) = Diff x - fromInterior = id - toInterior = pure - translateP = Tagged (.+~^) - Shade' c e .+~^ v = Shade' (c.+^v) e - Shade' c e .-~^ v = Shade' (c.-^v) e - -instance (WithField ℝ AffineManifold x, Geodesic x, SimpleSpace (Needle x)) - => Geodesic (Shade' x) where - geodesicBetween (Shade' c e) (Shade' ζ η) = pure interp - where sharedSpan = sharedNormSpanningSystem e η - interp t = Shade' (pinterp t) - (spanNorm [ v ^/ (alerpB 1 (recip qη) t) - | (v,qη) <- sharedSpan ]) - Option (Just pinterp) = geodesicBetween c ζ - -fullShade :: WithField ℝ Manifold x => x -> Metric' x -> Shade x -fullShade ctr expa = Shade ctr expa - -fullShade' :: WithField ℝ Manifold x => x -> Metric x -> Shade' x -fullShade' ctr expa = Shade' ctr expa - - --- | Span a 'Shade' from a center point and multiple deviation-vectors. -pattern (:±) :: () => (WithField ℝ Manifold x, SimpleSpace (Needle x)) - => x -> [Needle x] -> Shade x -pattern x :± shs <- Shade x (normSpanningSystem -> shs) - where x :± shs = fullShade x $ spanVariance shs - - --- | Similar to ':±', but instead of expanding the shade, each vector /restricts/ it. --- Iff these form a orthogonal basis (in whatever sense applicable), then both --- methods will be equivalent. --- --- Note that '|±|' is only possible, as such, in an inner-product space; in --- general you need reciprocal vectors ('Needle'') to define a 'Shade''. -(|±|) :: WithField ℝ EuclidSpace x => x -> [Needle x] -> Shade' x -x |±| shs = Shade' x $ spanNorm [v^/(v<.>v) | v<-shs] - - - -subshadeId' :: WithField ℝ Manifold x - => x -> NonEmpty (Needle' x) -> x -> (Int, HourglassBulb) -subshadeId' c expvs x = case x .-~. c of - Option (Just v) -> let (iu,vl) = maximumBy (comparing $ abs . snd) - $ zip [0..] (map (v <.>^) $ NE.toList expvs) - in (iu, if vl>0 then UpperBulb else LowerBulb) - _ -> (-1, error "Trying to obtain the subshadeId of a point not actually included in the shade.") - -subshadeId :: (WithField ℝ Manifold x, FiniteDimensional (Needle' x)) - => Shade x -> x -> (Int, HourglassBulb) -subshadeId (Shade c expa) = subshadeId' c . NE.fromList $ normSpanningSystem' expa - - - --- | Attempt to find a 'Shade' that describes the distribution of given points. --- At least in an affine space (and thus locally in any manifold), this can be used to --- estimate the parameters of a normal distribution from which some points were --- sampled. Note that some points will be “outside” of the shade, --- as happens for a normal distribution with some statistical likelyhood. --- (Use 'pointsCovers' if you need to prevent that.) --- --- For /nonconnected/ manifolds it will be necessary to yield separate shades --- for each connected component. And for an empty input list, there is no shade! --- Hence the result type is a list. -pointsShades :: (WithField ℝ Manifold x, SimpleSpace (Needle x)) - => [x] -> [Shade x] -pointsShades = map snd . pointsShades' mempty - --- | Like 'pointsShades', but ensure that all points are actually in --- the shade, i.e. if @['Shade' x₀ ex]@ is the result then --- @'metric' (recipMetric ex) (p-x₀) ≤ 1@ for all @p@ in the list. -pointsCovers :: ∀ x . (WithField ℝ Manifold x, SimpleSpace (Needle x)) - => [x] -> [Shade x] -pointsCovers = map guaranteeIn . pointsShades' mempty - where guaranteeIn (ps, Shade x₀ ex) - = case ps >>= \p -> let Option (Just v) = p.-~.x₀ - in guard ((ex'|$|v) > 1) >> [(p, spanVariance [v])] - of [] -> Shade x₀ ex - outs -> guaranteeIn ( fst<$>outs - , Shade x₀ - $ ex <> scaleNorm - (sqrt . recip . fromIntegral - $ 2 * length outs) - (mconcat $ snd<$>outs) - ) - where ex' = dualNorm ex - -pointsShade's :: (WithField ℝ Manifold x, SimpleSpace (Needle x)) => [x] -> [Shade' x] -pointsShade's = map (\(Shade c e) -> Shade' c $ dualNorm e) . pointsShades - -pointsCover's :: (WithField ℝ Manifold x, SimpleSpace (Needle x)) => [x] -> [Shade' x] -pointsCover's = map (\(Shade c e) -> Shade' c $ dualNorm e) . pointsCovers - -pseudoECM :: (WithField ℝ Manifold x, SimpleSpace (Needle x)) - => NonEmpty x -> (x, ([x],[x])) -pseudoECM (p₀ NE.:| psr) = foldl' ( \(acc, (rb,nr)) (i,p) - -> case p.-~.acc of - Option (Just δ) -> (acc .+~^ δ^/i, (p:rb, nr)) - _ -> (acc, (rb, p:nr)) ) - (p₀, mempty) - ( zip [1..] $ p₀:psr ) - -pointsShades' :: (WithField ℝ Manifold x, SimpleSpace (Needle x)) - => Metric' x -> [x] -> [([x], Shade x)] -pointsShades' _ [] = [] -pointsShades' minExt ps = case expa of - Option (Just e) -> (ps, fullShade ctr e) - : pointsShades' minExt unreachable - _ -> pointsShades' minExt inc'd - ++ pointsShades' minExt unreachable - where (ctr,(inc'd,unreachable)) = pseudoECM $ NE.fromList ps - expa = ( (<>minExt) . spanVariance . map (^/ fromIntegral (length ps)) ) - <$> mapM (.-~.ctr) ps - - --- | Attempt to reduce the number of shades to fewer (ideally, a single one). --- In the simplest cases these should guaranteed cover the same area; --- for non-flat manifolds it only works in a heuristic sense. -shadesMerge :: (WithField ℝ Manifold x, SimpleSpace (Needle x)) - => ℝ -- ^ How near (inverse normalised distance, relative to shade expanse) - -- two shades must be to be merged. If this is zero, any shades - -- in the same connected region of a manifold are merged. - -> [Shade x] -- ^ A list of /n/ shades. - -> [Shade x] -- ^ /m/ ≤ /n/ shades which cover at least the same area. -shadesMerge fuzz (sh₁@(Shade c₁ e₁) : shs) = case extractJust tryMerge shs of - (Just mg₁, shs') -> shadesMerge fuzz - $ shs'++[mg₁] -- Append to end to prevent undue weighting - -- of first shade and its mergers. - (_, shs') -> sh₁ : shadesMerge fuzz shs' - where tryMerge (Shade c₂ e₂) - | Option (Just v) <- c₁.-~.c₂ - , Option (Just v') <- c₂.-~.c₁ - , [e₁',e₂'] <- dualNorm<$>[e₁, e₂] - , b₁ <- e₂'|$|v - , b₂ <- e₁'|$|v - , fuzz*b₁*b₂ <= b₁ + b₂ - = Just $ let cc = c₂ .+~^ v ^/ 2 - Option (Just cv₁) = c₁.-~.cc - Option (Just cv₂) = c₂.-~.cc - in Shade cc $ e₁ <> e₂ <> spanVariance [cv₁, cv₂] - | otherwise = Nothing -shadesMerge _ shs = shs - --- | Evaluate the shade as a quadratic form; essentially --- @ --- minusLogOcclusion sh x = x <.>^ (sh^.shadeExpanse $ x - sh^.shadeCtr) --- @ --- where 'shadeExpanse' gives a metric (matrix) that characterises the --- width of the shade. -minusLogOcclusion' :: ( Manifold x, s ~ (Scalar (Needle x)), RealDimension s ) - => Shade' x -> x -> s -minusLogOcclusion' (Shade' p₀ δinv) = occ - where occ p = case p .-~. p₀ of - Option(Just vd) | mSq <- normSq δinv vd - , mSq == mSq -- avoid NaN - -> mSq - _ -> 1/0 -minusLogOcclusion :: ( Manifold x, SimpleSpace (Needle x) - , s ~ (Scalar (Needle x)), RealDimension s ) - => Shade x -> x -> s -minusLogOcclusion (Shade p₀ δ) = occ - where occ p = case p .-~. p₀ of - Option(Just vd) | mSq <- normSq δinv vd - , mSq == mSq -- avoid NaN - -> mSq - _ -> 1/0 - δinv = dualNorm δ - - - - --- | Hourglass as the geometric shape (two opposing ~conical volumes, sharing --- only a single point in the middle); has nothing to do with time. -data Hourglass s = Hourglass { upperBulb, lowerBulb :: !s } - deriving (Generic, Hask.Functor, Hask.Foldable) -instance (NFData s) => NFData (Hourglass s) -instance (Semigroup s) => Semigroup (Hourglass s) where - Hourglass u l <> Hourglass u' l' = Hourglass (u<>u') (l<>l') - sconcat hgs = let (us,ls) = NE.unzip $ (upperBulb&&&lowerBulb) <$> hgs - in Hourglass (sconcat us) (sconcat ls) -instance (Monoid s, Semigroup s) => Monoid (Hourglass s) where - mempty = Hourglass mempty mempty; mappend = (<>) - mconcat hgs = let (us,ls) = unzip $ (upperBulb&&&lowerBulb) <$> hgs - in Hourglass (mconcat us) (mconcat ls) -instance Hask.Applicative Hourglass where - pure x = Hourglass x x - Hourglass f g <*> Hourglass x y = Hourglass (f x) (g y) -instance Foldable Hourglass (->) (->) where - ffoldl f (x, Hourglass a b) = f (f(x,a), b) - foldMap f (Hourglass a b) = f a `mappend` f b - -flipHour :: Hourglass s -> Hourglass s -flipHour (Hourglass u l) = Hourglass l u - -data HourglassBulb = UpperBulb | LowerBulb -oneBulb :: HourglassBulb -> (a->a) -> Hourglass a->Hourglass a -oneBulb UpperBulb f (Hourglass u l) = Hourglass (f u) l -oneBulb LowerBulb f (Hourglass u l) = Hourglass u (f l) - - - -data ShadeTree x = PlainLeaves [x] - | DisjointBranches !Int (NonEmpty (ShadeTree x)) - | OverlappingBranches !Int !(Shade x) (NonEmpty (DBranch x)) - deriving (Generic) - -data DBranch' x c = DBranch { boughDirection :: !(Needle' x) - , boughContents :: !(Hourglass c) } - deriving (Generic, Hask.Functor, Hask.Foldable) -type DBranch x = DBranch' x (ShadeTree x) - -newtype DBranches' x c = DBranches (NonEmpty (DBranch' x c)) - deriving (Generic, Hask.Functor, Hask.Foldable) - --- ^ /Unsafe/: this assumes the direction information of both containers to be equivalent. -instance (Semigroup c) => Semigroup (DBranches' x c) where - DBranches b1 <> DBranches b2 = DBranches $ NE.zipWith (\(DBranch d1 c1) (DBranch _ c2) - -> DBranch d1 $ c1<>c2 ) b1 b2 - -directionChoices :: WithField ℝ Manifold x - => [DBranch x] - -> [ ( (Needle' x, ShadeTree x) - ,[(Needle' x, ShadeTree x)] ) ] -directionChoices [] = [] -directionChoices (DBranch ѧ (Hourglass t b) : hs) - = ( (ѧ,t), (v,b) : map fst uds) - : ((v,b), (ѧ,t) : map fst uds) - : map (second $ ((ѧ,t):) . ((v,b):)) uds - where v = negateV ѧ - uds = directionChoices hs - -traverseDirectionChoices :: (WithField ℝ Manifold x, Hask.Applicative f) - => ( (Int, (Needle' x, ShadeTree x)) - -> [(Int, (Needle' x, ShadeTree x))] - -> f (ShadeTree x) ) - -> [DBranch x] - -> f [DBranch x] -traverseDirectionChoices f dbs - = td [] . scanLeafNums 0 - $ dbs >>= \(DBranch ѧ (Hourglass τ β)) - -> [(ѧ,τ), (negateV ѧ,β)] - where td pds (ѧt@(_,(ѧ,_)):vb:vds) - = liftA3 (\t' b' -> (DBranch ѧ (Hourglass t' b') :)) - (f ѧt $ vb:uds) - (f vb $ ѧt:uds) - $ td (ѧt:vb:pds) vds - where uds = pds ++ vds - td _ _ = pure [] - scanLeafNums _ [] = [] - scanLeafNums i₀ ((v,t):vts) = (i₀, (v,t)) : scanLeafNums (i₀ + nLeaves t) vts - - -indexDBranches :: NonEmpty (DBranch x) -> NonEmpty (DBranch' x (Int, ShadeTree x)) -indexDBranches (DBranch d (Hourglass t b) :| l) -- this could more concisely be written as a traversal - = DBranch d (Hourglass (0,t) (nt,b)) :| ixDBs (nt + nb) l - where nt = nLeaves t; nb = nLeaves b - ixDBs _ [] = [] - ixDBs i₀ (DBranch δ (Hourglass τ β) : l) - = DBranch δ (Hourglass (i₀,τ) (i₀+nτ,β)) : ixDBs (i₀ + nτ + nβ) l - where nτ = nLeaves τ; nβ = nLeaves β - -instance (NFData x, NFData (Needle' x)) => NFData (ShadeTree x) where - rnf (PlainLeaves xs) = rnf xs - rnf (DisjointBranches n bs) = n `seq` rnf (NE.toList bs) - rnf (OverlappingBranches n sh bs) = n `seq` sh `seq` rnf (NE.toList bs) -instance (NFData x, NFData (Needle' x)) => NFData (DBranch x) - --- | Experimental. There might be a more powerful instance possible. -instance (AffineManifold x) => Semimanifold (ShadeTree x) where - type Needle (ShadeTree x) = Diff x - fromInterior = id - toInterior = pure - translateP = Tagged (.+~^) - PlainLeaves xs .+~^ v = PlainLeaves $ (.+^v)<$>xs - OverlappingBranches n sh br .+~^ v - = OverlappingBranches n (sh.+~^v) - $ fmap (\(DBranch d c) -> DBranch d $ (.+~^v)<$>c) br - DisjointBranches n br .+~^ v = DisjointBranches n $ (.+~^v)<$>br - --- | WRT union. -instance (WithField ℝ Manifold x, SimpleSpace (Needle x)) => Semigroup (ShadeTree x) where - PlainLeaves [] <> t = t - t <> PlainLeaves [] = t - t <> s = fromLeafPoints $ onlyLeaves t ++ onlyLeaves s - -- Could probably be done more efficiently - sconcat = mconcat . NE.toList -instance (WithField ℝ Manifold x, SimpleSpace (Needle x)) => Monoid (ShadeTree x) where - mempty = PlainLeaves [] - mappend = (<>) - mconcat l = case filter ne l of - [] -> mempty - [t] -> t - l' -> fromLeafPoints $ onlyLeaves =<< l' - where ne (PlainLeaves []) = False; ne _ = True - - --- | Build a quite nicely balanced tree from a cloud of points, on any real manifold. --- --- Example: https://nbviewer.jupyter.org/github/leftaroundabout/manifolds/blob/master/test/Trees-and-Webs.ipynb#pseudorandomCloudTree --- --- <> -fromLeafPoints :: ∀ x. (WithField ℝ Manifold x, SimpleSpace (Needle x)) - => [x] -> ShadeTree x -fromLeafPoints = fromLeafPoints' sShIdPartition - - --- | The leaves of a shade tree are numbered. For a given index, this function --- attempts to find the leaf with that ID, within its immediate environment. -indexShadeTree :: ∀ x . WithField ℝ Manifold x - => ShadeTree x -> Int -> Either Int ([ShadeTree x], x) -indexShadeTree _ i - | i<0 = Left i -indexShadeTree sh@(PlainLeaves lvs) i = case length lvs of - n | i Right ([sh], lvs!!i) - | otherwise -> Left $ i-n -indexShadeTree (DisjointBranches n brs) i - | i (`indexShadeTree`i') - result -> return result - ) (Left i) brs - | otherwise = Left $ i-n -indexShadeTree sh@(OverlappingBranches n _ brs) i - | i foldl (\case - Left i' -> (`indexShadeTree`i') - result -> return result - ) (Left i) (toList brs>>=toList) - | otherwise = Left $ i-n - - --- | “Inverse indexing” of a tree. This is roughly a nearest-neighbour search, --- but not guaranteed to give the correct result unless evaluated at the --- precise position of a tree leaf. -positionIndex :: ∀ x . (WithField ℝ Manifold x, SimpleSpace (Needle x)) - => Option (Metric x) -- ^ For deciding (at the lowest level) what “close” means; - -- this is optional for any tree of depth >1. - -> ShadeTree x -- ^ The tree to index into - -> x -- ^ Position to look up - -> Option (Int, ([ShadeTree x], x)) - -- ^ Index of the leaf near to the query point, the “path” of - -- environment trees leading down to its position (in decreasing - -- order of size), and actual position of the found node. -positionIndex (Option (Just m)) sh@(PlainLeaves lvs) x - = case catMaybes [ ((i,p),) . normSq m <$> getOption (p.-~.x) - | (i,p) <- zip [0..] lvs] of - [] -> empty - l | ((i,p),_) <- minimumBy (comparing snd) l - -> pure (i, ([sh], p)) -positionIndex m (DisjointBranches _ brs) x - = fst . foldl' (\case - (q@(Option (Just _)), i₀) -> const (q, i₀) - (_, i₀) -> \t' -> ( first (+i₀) <$> positionIndex m t' x - , i₀+nLeaves t' ) ) - (empty, 0) - $ brs -positionIndex _ sh@(OverlappingBranches n (Shade c ce) brs) x - | Option (Just vx) <- x.-~.c - = let (_,(i₀,t')) = maximumBy (comparing fst) - [ (σ*ω, t') - | DBranch d (Hourglass t'u t'd) <- NE.toList $ indexDBranches brs - , let ω = d<.>^vx - , (t',σ) <- [(t'u, 1), (t'd, -1)] ] - in ((+i₀) *** first (sh:)) - <$> positionIndex (return $ dualNorm ce) t' x -positionIndex _ _ _ = empty - - - -fromFnGraphPoints :: ∀ x y . ( WithField ℝ Manifold x, WithField ℝ Manifold y - , SimpleSpace (Needle x), SimpleSpace (Needle y) ) - => [(x,y)] -> ShadeTree (x,y) -fromFnGraphPoints = fromLeafPoints' fg_sShIdPart - where fg_sShIdPart :: Shade (x,y) -> [(x,y)] -> NonEmpty (DBranch' (x,y) [(x,y)]) - fg_sShIdPart (Shade c expa) xs - | b:bs <- [DBranch (v, zeroV) mempty - | v <- normSpanningSystem' - (transformNorm (id&&&zeroV) expa :: Metric' x) ] - = sShIdPartition' c xs $ b:|bs - -fromLeafPoints' :: ∀ x. (WithField ℝ Manifold x, SimpleSpace (Needle x)) => - (Shade x -> [x] -> NonEmpty (DBranch' x [x])) -> [x] -> ShadeTree x -fromLeafPoints' sShIdPart = go mempty - where go :: Metric' x -> [x] -> ShadeTree x - go preShExpa = \xs -> case pointsShades' (scaleNorm (1/3) preShExpa) xs of - [] -> mempty - [(_,rShade)] -> let trials = sShIdPart rShade xs - in case reduce rShade trials of - Just redBrchs - -> OverlappingBranches - (length xs) rShade - (branchProc (_shadeExpanse rShade) redBrchs) - _ -> PlainLeaves xs - partitions -> DisjointBranches (length xs) - . NE.fromList - $ map (\(xs',pShade) -> go mempty xs') partitions - where - branchProc redSh = fmap (fmap $ go redSh) - - reduce :: Shade x -> NonEmpty (DBranch' x [x]) - -> Maybe (NonEmpty (DBranch' x [x])) - reduce sh@(Shade c _) brCandidates - = case findIndex deficient cards of - Just i | (DBranch _ reBr, o:ok) - <- amputateId i (NE.toList brCandidates) - -> reduce sh - $ sShIdPartition' c (fold reBr) (o:|ok) - | otherwise -> Nothing - _ -> Just brCandidates - where (cards, maxCard) = (NE.toList &&& maximum') - $ fmap (fmap length . boughContents) brCandidates - deficient (Hourglass u l) = any (\c -> c^2 <= maxCard + 1) [u,l] - maximum' = maximum . NE.toList . fmap (\(Hourglass u l) -> max u l) - - -sShIdPartition' :: WithField ℝ Manifold x - => x -> [x] -> NonEmpty (DBranch' x [x])->NonEmpty (DBranch' x [x]) -sShIdPartition' c xs st - = foldr (\p -> let (i,h) = ssi p - in asList $ update_nth (\(DBranch d c) - -> DBranch d (oneBulb h (p:) c)) - i ) - st xs - where ssi = subshadeId' c (boughDirection<$>st) -sShIdPartition :: (WithField ℝ Manifold x, SimpleSpace (Needle x)) - => Shade x -> [x] -> NonEmpty (DBranch' x [x]) -sShIdPartition (Shade c expa) xs - | b:bs <- [DBranch v mempty | v <- normSpanningSystem' expa] - = sShIdPartition' c xs $ b:|bs - - -asList :: ([a]->[b]) -> NonEmpty a->NonEmpty b -asList f = NE.fromList . f . NE.toList - -update_nth :: (a->a) -> Int -> [a] -> [a] -update_nth _ n l | n<0 = l -update_nth f 0 (c:r) = f c : r -update_nth f n [] = [] -update_nth f n (l:r) = l : update_nth f (n-1) r - - -amputateId :: Int -> [a] -> (a,[a]) -amputateId i l = let ([a],bs) = amputateIds [i] l in (a, bs) - -deleteIds :: [Int] -> [a] -> [a] -deleteIds kids = snd . amputateIds kids - -amputateIds :: [Int] -- ^ Sorted list of non-negative indices to extract - -> [a] -- ^ Input list - -> ([a],[a]) -- ^ (Extracted elements, remaining elements) -amputateIds = go 0 - where go _ _ [] = ([],[]) - go _ [] l = ([],l) - go i (k:ks) (x:xs) - | i==k = first (x:) $ go (i+1) ks xs - | otherwise = second (x:) $ go (i+1) (k:ks) xs - - - - -sortByKey :: Ord a => [(a,b)] -> [b] -sortByKey = map snd . sortBy (comparing fst) - - -trunks :: ∀ x. (WithField ℝ Manifold x, SimpleSpace (Needle x)) - => ShadeTree x -> [Shade x] -trunks (PlainLeaves lvs) = pointsCovers lvs -trunks (DisjointBranches _ brs) = Hask.foldMap trunks brs -trunks (OverlappingBranches _ sh _) = [sh] - - -nLeaves :: ShadeTree x -> Int -nLeaves (PlainLeaves lvs) = length lvs -nLeaves (DisjointBranches n _) = n -nLeaves (OverlappingBranches n _ _) = n - - -instance ImpliesMetric ShadeTree where - type MetricRequirement ShadeTree x = (WithField ℝ Manifold x, SimpleSpace (Needle x)) - inferMetric (OverlappingBranches _ (Shade _ e) _) = dualNorm e - inferMetric (PlainLeaves lvs) = case pointsShades lvs of - (Shade _ sh:_) -> dualNorm sh - _ -> mempty - inferMetric (DisjointBranches _ (br:|_)) = inferMetric br - inferMetric' (OverlappingBranches _ (Shade _ e) _) = e - inferMetric' (PlainLeaves lvs) = case pointsShades lvs of - (Shade _ sh:_) -> sh - _ -> mempty - inferMetric' (DisjointBranches _ (br:|_)) = inferMetric' br - - - -overlappingBranches :: Shade x -> NonEmpty (DBranch x) -> ShadeTree x -overlappingBranches shx brs = OverlappingBranches n shx brs - where n = sum $ fmap (sum . fmap nLeaves) brs - -unsafeFmapLeaves :: (x -> x) -> ShadeTree x -> ShadeTree x -unsafeFmapLeaves f (PlainLeaves lvs) = PlainLeaves $ fmap f lvs -unsafeFmapLeaves f (DisjointBranches n brs) - = DisjointBranches n $ unsafeFmapLeaves f <$> brs -unsafeFmapLeaves f (OverlappingBranches n sh brs) - = OverlappingBranches n sh $ fmap (unsafeFmapLeaves f) <$> brs - -unsafeFmapTree :: (NonEmpty x -> NonEmpty y) - -> (Needle' x -> Needle' y) - -> (Shade x -> Shade y) - -> ShadeTree x -> ShadeTree y -unsafeFmapTree _ _ _ (PlainLeaves []) = PlainLeaves [] -unsafeFmapTree f _ _ (PlainLeaves lvs) = PlainLeaves . toList . f $ NE.fromList lvs -unsafeFmapTree f fn fs (DisjointBranches n brs) - = let brs' = unsafeFmapTree f fn fs <$> brs - in DisjointBranches (sum $ nLeaves<$>brs') brs' -unsafeFmapTree f fn fs (OverlappingBranches n sh brs) - = let brs' = fmap (\(DBranch dir br) - -> DBranch (fn dir) (unsafeFmapTree f fn fs<$>br) - ) brs - in overlappingBranches (fs sh) brs' - - --- | Class of manifolds which can use 'Shade'' as a basic set type. --- This is easily possible for vector spaces with the default implementations. -class (WithField ℝ Manifold y, SimpleSpace (Needle y)) => Refinable y where - -- | @a `subShade'` b ≡ True@ means @a@ is fully contained in @b@, i.e. from - -- @'minusLogOcclusion'' a p < 1@ follows also @minusLogOcclusion' b p < 1@. - subShade' :: Shade' y -> Shade' y -> Bool - subShade' (Shade' ac ae) tsh = all ((<1) . minusLogOcclusion' tsh) - [ ac.+~^σ*^v | σ<-[-1,1], v<-normSpanningSystem' ae ] - - refineShade' :: Shade' y -> Shade' y -> Option (Shade' y) - refineShade' (Shade' c₀ (Norm e₁)) - (Shade' c₀₂ (Norm e₂)) - | Option (Just c₂) <- c₀₂.-~.c₀ - , e₁c₂ <- e₁ $ c₂ - , e₂c₂ <- e₂ $ c₂ - , cc <- σe \$ e₂c₂ - , cc₂ <- cc ^-^ c₂ - , e₁cc <- e₁ $ cc - , e₂cc <- e₂ $ cc - , α <- 2 + cc₂<.>^e₂c₂ - , α > 0 - , ee <- σe ^/ α - , c₂e₁c₂ <- c₂<.>^e₁c₂ - , c₂e₂c₂ <- c₂<.>^e₂c₂ - , c₂eec₂ <- (c₂e₁c₂ + c₂e₂c₂) / α - , [γ₁,γ₂] <- middle . sort - $ quadraticEqnSol c₂e₁c₂ - (2 * (c₂<.>^e₁cc)) - (cc<.>^e₁cc - 1) - ++ quadraticEqnSol c₂e₂c₂ - (2 * (c₂<.>^e₂cc - c₂e₂c₂)) - (cc<.>^e₂cc - 2 * (cc<.>^e₂c₂) + c₂e₂c₂ - 1) - , cc' <- cc ^+^ ((γ₁+γ₂)/2)*^c₂ - , rγ <- abs (γ₁ - γ₂) / 2 - , η <- if rγ * c₂eec₂ /= 0 && 1 - rγ^2 * c₂eec₂ > 0 - then sqrt (1 - rγ^2 * c₂eec₂) / (rγ * c₂eec₂) - else 0 - = return $ - Shade' (c₀.+~^cc') - (Norm (arr ee) <> spanNorm [ee $ c₂^*η]) - | otherwise = empty - where σe = arr $ e₁^+^e₂ - quadraticEqnSol a b c - | a /= 0 && disc > 0 = [ (σ * sqrt disc - b) / (2*a) - | σ <- [-1, 1] ] - | otherwise = [0] - where disc = b^2 - 4*a*c - middle (_:x:y:_) = [x,y] - middle l = l - -- ⟨x−c₁|e₁|x−c₁⟩ < 1 ∧ ⟨x−c₂|e₂|x−c₂⟩ < 1 - -- We search (cc,ee) such that this implies - -- ⟨x−cc|ee|x−cc⟩ < 1. - -- Let WLOG c₁ = 0, so - -- ⟨x|e₁|x⟩ < 1. - -- cc should minimise the quadratic form - -- β(cc) = ⟨cc−c₁|e₁|cc−c₁⟩ + ⟨cc−c₂|e₂|cc−c₂⟩ - -- = ⟨cc|e₁|cc⟩ + ⟨cc−c₂|e₂|cc−c₂⟩ - -- = ⟨cc|e₁|cc⟩ + ⟨cc|e₂|cc⟩ − 2⋅⟨c₂|e₂|cc⟩ + ⟨c₂|e₂|c₂⟩ - -- It is thus - -- β(cc + δ⋅v) − β cc - -- = ⟨cc + δ⋅v|e₁|cc + δ⋅v⟩ + ⟨cc + δ⋅v|e₂|cc + δ⋅v⟩ − 2⋅⟨c₂|e₂|cc + δ⋅v⟩ + ⟨c₂|e₂|c₂⟩ - -- − ⟨cc|e₁|cc⟩ − ⟨cc|e₂|cc⟩ + 2⋅⟨c₂|e₂|cc⟩ − ⟨c₂|e₂|c₂⟩ - -- = ⟨cc + δ⋅v|e₁|cc + δ⋅v⟩ + ⟨cc + δ⋅v|e₂|cc + δ⋅v⟩ − 2⋅⟨c₂|e₂|δ⋅v⟩ - -- − ⟨cc|e₁|cc⟩ − ⟨cc|e₂|cc⟩ - -- = 2⋅⟨δ⋅v|e₁|cc⟩ + ⟨δ⋅v|e₁|δ⋅v⟩ + 2⋅⟨δ⋅v|e₂|cc⟩ + ⟨δ⋅v|e₂|δ⋅v⟩ − 2⋅⟨c₂|e₂|δ⋅v⟩ - -- = 2⋅δ⋅⟨v|e₁+e₂|cc⟩ − 2⋅δ⋅⟨v|e₂|c₂⟩ + 𝓞(δ²) - -- This should vanish for all v, which is fulfilled by - -- (e₁+e₂)|cc⟩ = e₂|c₂⟩. - -- - -- If we now choose - -- ee = (e₁+e₂) / α - -- then - -- ⟨x−cc|ee|x−cc⟩ ⋅ α - -- = ⟨x−cc|ee|x⟩ ⋅ α − ⟨x−cc|ee|cc⟩ ⋅ α - -- = ⟨x|ee|x−cc⟩ ⋅ α − ⟨x−cc|e₂|c₂⟩ - -- = ⟨x|ee|x⟩ ⋅ α − ⟨x|ee|cc⟩ ⋅ α − ⟨x−cc|e₂|c₂⟩ - -- = ⟨x|e₁+e₂|x⟩ − ⟨x|e₂|c₂⟩ − ⟨x−cc|e₂|c₂⟩ - -- = ⟨x|e₁|x⟩ + ⟨x|e₂|x⟩ − ⟨x|e₂|c₂⟩ − ⟨x−cc|e₂|c₂⟩ - -- < 1 + ⟨x|e₂|x−c₂⟩ − ⟨x−cc|e₂|c₂⟩ - -- = 1 + ⟨x−c₂|e₂|x−c₂⟩ + ⟨c₂|e₂|x−c₂⟩ − ⟨x−cc|e₂|c₂⟩ - -- < 2 + ⟨x−c₂−x+cc|e₂|c₂⟩ - -- = 2 + ⟨cc−c₂|e₂|c₂⟩ - -- Really we want - -- ⟨x−cc|ee|x−cc⟩ ⋅ α < α - -- So choose α = 2 + ⟨cc−c₂|e₂|c₂⟩. - -- - -- The ellipsoid "cc±√ee" captures perfectly the intersection - -- of the boundary of the shades, but it tends to significantly - -- overshoot the interior intersection in perpendicular direction, - -- i.e. in direction of c₂−c₁. E.g. - -- https://github.com/leftaroundabout/manifolds/blob/bc0460b9/manifolds/images/examples/ShadeCombinations/EllipseIntersections.png - -- 1. Really, the relevant points are those where either of the - -- intersector badnesses becomes 1. The intersection shade should - -- be centered between those points. We perform according corrections, - -- but only in c₂ direction, so this can be handled efficiently - -- as a 1D quadratic equation. - -- Consider - -- dⱼ c := ⟨c−cⱼ|eⱼ|c−cⱼ⟩ =! 1 - -- dⱼ (cc + γ⋅c₂) - -- = ⟨cc+γ⋅c₂−cⱼ|eⱼ|cc+γ⋅c₂−cⱼ⟩ - -- = ⟨cc−cⱼ|eⱼ|cc−cⱼ⟩ + 2⋅γ⋅⟨c₂|eⱼ|cc−cⱼ⟩ + γ²⋅⟨c₂|eⱼ|c₂⟩ - -- =! 1 - -- So - -- γⱼ = (- b ± √(b²−4⋅a⋅c)) / 2⋅a - -- where a = ⟨c₂|eⱼ|c₂⟩ - -- b = 2 ⋅ (⟨c₂|eⱼ|cc⟩ − ⟨c₂|eⱼ|cⱼ⟩) - -- c = ⟨cc|eⱼ|cc⟩ − 2⋅⟨cc|eⱼ|cⱼ⟩ + ⟨cⱼ|eⱼ|cⱼ⟩ − 1 - -- The ± sign should be chosen to get the smaller |γ| (otherwise - -- we end up on the wrong side of the shade), i.e. - -- γⱼ = (sgn bⱼ ⋅ √(bⱼ²−4⋅aⱼ⋅cⱼ) − bⱼ) / 2⋅aⱼ - -- 2. Trim the result in that direction to the actual - -- thickness of the lens-shaped intersection: we want - -- ⟨rγ⋅c₂|ee'|rγ⋅c₂⟩ = 1 - -- for a squeezed version of ee, - -- ee' = ee + ee|η⋅c₂⟩⟨η⋅c₂|ee - -- ee' = ee + η² ⋅ ee|c₂⟩⟨c₂|ee - -- ⟨rγ⋅c₂|ee'|rγ⋅c₂⟩ - -- = rγ² ⋅ (⟨c₂|ee|c₂⟩ + η² ⋅ ⟨c₂|ee|c₂⟩²) - -- = rγ² ⋅ ⟨c₂|ee|c₂⟩ + η² ⋅ rγ² ⋅ ⟨c₂|ee|c₂⟩² - -- η² = (1 − rγ²⋅⟨c₂|ee|c₂⟩) / (rγ² ⋅ ⟨c₂|ee|c₂⟩²) - -- η = √(1 − rγ²⋅⟨c₂|ee|c₂⟩) / (rγ ⋅ ⟨c₂|ee|c₂⟩) - -- With ⟨c₂|ee|c₂⟩ = (⟨c₂|e₁|c₂⟩ + ⟨c₂|e₂|c₂⟩)/α. - - - -- | If @p@ is in @a@ (red) and @δ@ is in @b@ (green), - -- then @p.+~^δ@ is in @convolveShade' a b@ (blue). - -- --- Example: https://nbviewer.jupyter.org/github/leftaroundabout/manifolds/blob/master/test/ShadeCombinations.ipynb#shadeConvolutions --- --- <> - convolveShade' :: Shade' y -> Shade' (Needle y) -> Shade' y - convolveShade' (Shade' y₀ ey) (Shade' δ₀ eδ) - = Shade' (y₀.+~^δ₀) - ( spanNorm [ f ^* ζ crl - | (f,_) <- eδsp - | crl <- corelap ] ) - where eδsp = sharedNormSpanningSystem ey eδ - corelap = map snd eδsp - ζ = case filter (>0) corelap of - [] -> const 0 - nzrelap - -> let cre₁ = 1/minimum nzrelap - cre₂ = maximum nzrelap - edgeFactor = sqrt ( (1 + cre₁)^2 + (1 + cre₂)^2 ) - / (sqrt (1 + cre₁^2) + sqrt (1 + cre₂^2)) - in \case - 0 -> 0 - sq -> edgeFactor / (recip sq + 1) - - -instance Refinable ℝ where - refineShade' (Shade' cl el) (Shade' cr er) - = case (normSq el 1, normSq er 1) of - (0, _) -> return $ Shade' cr er - (_, 0) -> return $ Shade' cl el - (ql,qr) | ql>0, qr>0 - -> let [rl,rr] = sqrt . recip <$> [ql,qr] - b = maximum $ zipWith (-) [cl,cr] [rl,rr] - t = minimum $ zipWith (+) [cl,cr] [rl,rr] - in guard (b> - let cm = (b+t)/2 - rm = (t-b)/2 - in return $ Shade' cm (spanNorm [recip rm]) --- convolveShade' (Shade' y₀ ey) (Shade' δ₀ eδ) --- = case (metricSq ey 1, metricSq eδ 1) of --- (wy,wδ) | wy>0, wδ>0 --- -> Shade' (y₀.+~^δ₀) --- ( projector . recip --- $ recip (sqrt wy) + recip (sqrt wδ) ) --- (_ , _) -> Shade' y₀ zeroV - -instance (Refinable a, Refinable b) => Refinable (a,b) - -instance Refinable ℝ⁰ -instance Refinable ℝ¹ -instance Refinable ℝ² -instance Refinable ℝ³ -instance Refinable ℝ⁴ - - -intersectShade's :: ∀ y . Refinable y => NonEmpty (Shade' y) -> Option (Shade' y) -intersectShade's (sh:|shs) = Hask.foldrM refineShade' sh shs - - - - -type DifferentialEqn x y = Shade (x,y) -> Shade' (LocalLinear x y) - - -propagateDEqnSolution_loc :: ∀ x y . ( WithField ℝ Manifold x, Refinable y - , SimpleSpace (Needle x) ) - => DifferentialEqn x y -> ((x, Shade' y), NonEmpty (Needle x, Shade' y)) - -> NonEmpty (Shade' y) -propagateDEqnSolution_loc f ((x, shy@(Shade' y _)), neighbours) = ycs - where jShade@(Shade' j₀ jExpa) = f shxy - [shxy] = pointsCovers [ (xs, ys') - | (xs, Shade' ys yse) - <- (x,shy):(first (x.+~^)<$>NE.toList neighbours) - , δy <- normSpanningSystem' yse - , ys' <- [ys.+~^δy, ys.-~^δy] ] - [Shade' _ expax] = pointsCover's $ x : ((x.+~^).fst<$>NE.toList neighbours) - marginδs :: NonEmpty (Needle x, (Needle y, Metric y)) - marginδs = [ (δxm, (δym, expany)) - | (δxm, Shade' yn expany) <- neighbours - , let (Option (Just δym)) = yn.-~.y - ] - back2Centre :: (Needle x, (Needle y, Metric y)) -> Shade' y - back2Centre (δx, (δym, expany)) - = convolveShade' - (Shade' y expany) - (Shade' δyb $ applyLinMapNorm jExpa (δx'^/(δx'<.>^δx))) - where δyb = δym ^-^ (j₀ $ δx) - δx' = expax<$|δx - ycs :: NonEmpty (Shade' y) - ycs = back2Centre <$> marginδs - xSpan = normSpanningSystem expax - -applyLinMapNorm :: (LSpace x, LSpace y, Scalar x ~ Scalar y) - => Norm (x+>y) -> DualVector x -> Norm y -applyLinMapNorm n dx - = transformNorm (fmap (arr Coercion . transposeTensor) . blockVectSpan' $ dx) n - - -type Twig x = (Int, ShadeTree x) -type TwigEnviron x = [Twig x] - --- Formerly, 'twigsWithEnvirons' what has now become 'traverseTwigsWithEnvirons'. --- The simple list-yielding version (see rev. b4a427d59ec82889bab2fde39225b14a57b694df) --- may well be more efficient than the current traversal-derived version. - --- | Example: https://nbviewer.jupyter.org/github/leftaroundabout/manifolds/blob/master/test/Trees-and-Webs.ipynb#pseudorandomCloudTree --- --- <> -twigsWithEnvirons :: ∀ x. (WithField ℝ Manifold x, SimpleSpace (Needle x)) - => ShadeTree x -> [(Twig x, TwigEnviron x)] -twigsWithEnvirons = execWriter . traverseTwigsWithEnvirons (writer . (snd.fst&&&pure)) - -traverseTwigsWithEnvirons :: ∀ x f . - (WithField ℝ Manifold x, SimpleSpace (Needle x), Hask.Applicative f) - => ( (Twig x, TwigEnviron x) -> f (ShadeTree x) ) -> ShadeTree x -> f (ShadeTree x) -traverseTwigsWithEnvirons f = fst . go [] . (0,) - where go :: TwigEnviron x -> Twig x -> (f (ShadeTree x), Bool) - go _ (i₀, DisjointBranches nlvs djbs) = ( fmap (DisjointBranches nlvs) - . Hask.traverse (fst . go []) - $ NE.zip ioffs djbs - , False ) - where ioffs = NE.scanl (\i -> (+i) . nLeaves) i₀ djbs - go envi ct@(i₀, (OverlappingBranches nlvs rob@(Shade robc _) brs)) - = ( case descentResult of - OuterNothing -> f - $ purgeRemotes - (ct, Hask.foldMap (\(io,te) - -> first (+io) <$> twigProximæ robc te) envi) - OuterJust dR -> fmap (OverlappingBranches nlvs rob . NE.fromList) dR - , False ) - where descentResult = traverseDirectionChoices tdc $ NE.toList brs - tdc (io, (vy, ty)) alts = case go envi'' (i₀+io, ty) of - (_, True) -> OuterNothing - (down, _) -> OuterJust down - where envi'' = filter (snd >>> trunks >>> \(Shade ce _:_) - -> let Option (Just δyenv) = ce.-~.robc - qq = vy<.>^δyenv - in qq > -1 - ) envi' - ++ map ((+i₀)***snd) alts - envi' = approach =<< envi - approach (i₀e, apt@(OverlappingBranches _ (Shade envc _) _)) - = first (+i₀e) <$> twigsaveTrim hither apt - where Option (Just δxenv) = robc .-~. envc - hither (DBranch bdir (Hourglass bdc₁ bdc₂)) - = [(0 , bdc₁) | overlap > -1] - ++ [(nLeaves bdc₁, bdc₂) | overlap < 1] - where overlap = bdir<.>^δxenv - approach q = [q] - go envi plvs@(i₀, (PlainLeaves _)) - = (f $ purgeRemotes (plvs, envi), True) - - twigProximæ :: x -> ShadeTree x -> TwigEnviron x - twigProximæ x₀ (DisjointBranches _ djbs) - = Hask.foldMap (\(i₀,st) -> first (+i₀) <$> twigProximæ x₀ st) - $ NE.zip ioffs djbs - where ioffs = NE.scanl (\i -> (+i) . nLeaves) 0 djbs - twigProximæ x₀ ct@(OverlappingBranches _ (Shade xb qb) brs) - = twigsaveTrim hither ct - where Option (Just δxb) = x₀ .-~. xb - hither (DBranch bdir (Hourglass bdc₁ bdc₂)) - = ((guard (overlap > -1)) >> twigProximæ x₀ bdc₁) - ++ ((guard (overlap < 1)) >> first (+nLeaves bdc₁)<$>twigProximæ x₀ bdc₂) - where overlap = bdir<.>^δxb - twigProximæ _ plainLeaves = [(0, plainLeaves)] - - twigsaveTrim :: (DBranch x -> TwigEnviron x) -> ShadeTree x -> TwigEnviron x - twigsaveTrim f ct@(OverlappingBranches _ _ dbs) - = case Hask.mapM (\(i₀,dbr) -> noLeaf $ first(+i₀)<$>f dbr) - $ NE.zip ioffs dbs of - Just pqe -> Hask.fold pqe - _ -> [(0,ct)] - where noLeaf [(_,PlainLeaves _)] = empty - noLeaf bqs = pure bqs - ioffs = NE.scanl (\i -> (+i) . sum . fmap nLeaves . toList) 0 dbs - - purgeRemotes :: (Twig x, TwigEnviron x) -> (Twig x, TwigEnviron x) - purgeRemotes = id -- See 7d1f3a4 for the implementation; this didn't work reliable. - -completeTopShading :: ( WithField ℝ Manifold x, WithField ℝ Manifold y - , SimpleSpace (Needle x), SimpleSpace (Needle y) ) - => x`Shaded`y -> [Shade' (x,y)] -completeTopShading (PlainLeaves plvs) - = pointsShade's $ (_topological &&& _untopological) <$> plvs -completeTopShading (DisjointBranches _ bqs) - = take 1 . completeTopShading =<< NE.toList bqs -completeTopShading t = pointsCover's . map (_topological &&& _untopological) $ onlyLeaves t - - -transferAsNormsDo :: LSpace v => Norm v -> Variance v -> v-+>v -transferAsNormsDo (Norm m) (Norm n) = n . m - -flexTopShading :: ∀ x y f . ( WithField ℝ Manifold x, WithField ℝ Manifold y - , SimpleSpace (Needle x), SimpleSpace (Needle y) - , Applicative f (->) (->) ) - => (Shade' (x,y) -> f (x, (Shade' y, LocalLinear x y))) - -> x`Shaded`y -> f (x`Shaded`y) -flexTopShading f tr = seq (assert_onlyToplevDisjoint tr) - $ recst (completeTopShading tr) tr - where recst qsh@(_:_) (DisjointBranches n bqs) - = undefined -- DisjointBranches n $ NE.zipWith (recst . (:[])) (NE.fromList qsh) bqs - recst [sha@(Shade' (_,yc₀) expa₀)] t = fmap fts $ f sha - where expa'₀ = dualNorm expa₀ - j₀ :: LocalLinear x y - j₀ = dependence expa'₀ - (_,expay₀) = summandSpaceNorms expa₀ - fts (xc, (Shade' yc expay, jtg)) = unsafeFmapLeaves applδj t - where Option (Just δyc) = yc.-~.yc₀ - tfm = transferAsNormsDo expay₀ (dualNorm expay) - applδj (WithAny y x) - = WithAny (yc₀ .+~^ ((tfm$δy) ^+^ (jtg$δx) ^+^ δyc)) x - where Option (Just δx) = x.-~.xc - Option (Just δy) = y.-~.(yc₀.+~^(j₀$δx)) - - assert_onlyToplevDisjoint, assert_connected :: x`Shaded`y -> () - assert_onlyToplevDisjoint (DisjointBranches _ dp) = rnf (assert_connected<$>dp) - assert_onlyToplevDisjoint t = assert_connected t - assert_connected (OverlappingBranches _ _ dp) - = rnf (Hask.foldMap assert_connected<$>dp) - assert_connected (PlainLeaves _) = () - -flexTwigsShading :: ∀ x y f . ( WithField ℝ Manifold x, WithField ℝ Manifold y - , SimpleSpace (Needle x), SimpleSpace (Needle y) - , Hask.Applicative f ) - => (Shade' (x,y) -> f (x, (Shade' y, LocalLinear x y))) - -> x`Shaded`y -> f (x`Shaded`y) -flexTwigsShading f = traverseTwigsWithEnvirons locFlex - where locFlex :: ∀ μ . ((Int, x`Shaded`y), μ) -> f (x`Shaded`y) - locFlex ((_,lsh), _) = flexTopShading f lsh - - - - - - - - --- simplexFaces :: forall n x . Simplex (S n) x -> Triangulation n x --- simplexFaces (Simplex p (ZeroSimplex q)) = TriangVertices $ Arr.fromList [p, q] --- simplexFaces splx = carpent splx $ TriangVertices ps --- where ps = Arr.fromList $ p : splxVertices qs --- where carpent (ZeroSimplex (Simplex p qs@(Simplex _ _)) --- | Triangulation es <- simplexFaces qs = TriangSkeleton $ Simplex p <$> es - - - - -newtype BaryCoords n = BaryCoords { getBaryCoordsTail :: FreeVect n ℝ } - -instance (KnownNat n) => AffineSpace (BaryCoords n) where - type Diff (BaryCoords n) = FreeVect n ℝ - BaryCoords v .-. BaryCoords w = v ^-^ w - BaryCoords v .+^ w = BaryCoords $ v ^+^ w -instance (KnownNat n) => Semimanifold (BaryCoords n) where - type Needle (BaryCoords n) = FreeVect n ℝ - fromInterior = id - toInterior = pure - translateP = Tagged (.+~^) - (.+~^) = (.+^) - semimanifoldWitness = undefined -instance (KnownNat n) => PseudoAffine (BaryCoords n) where - (.-~.) = pure .: (.-.) - -getBaryCoords :: BaryCoords n -> ℝ ^ S n -getBaryCoords (BaryCoords (FreeVect bcs)) = FreeVect $ (1 - Arr.sum bcs) `Arr.cons` bcs - -getBaryCoords' :: BaryCoords n -> [ℝ] -getBaryCoords' (BaryCoords (FreeVect bcs)) = 1 - Arr.sum bcs : Arr.toList bcs - -getBaryCoord :: BaryCoords n -> Int -> ℝ -getBaryCoord (BaryCoords (FreeVect bcs)) 0 = 1 - Arr.sum bcs -getBaryCoord (BaryCoords (FreeVect bcs)) i = case bcs Arr.!? i of - Just a -> a - _ -> 0 - -mkBaryCoords :: KnownNat n => ℝ ^ S n -> BaryCoords n -mkBaryCoords (FreeVect bcs) = BaryCoords $ FreeVect (Arr.tail bcs) ^/ Arr.sum bcs - -mkBaryCoords' :: KnownNat n => [ℝ] -> Option (BaryCoords n) -mkBaryCoords' bcs = fmap (BaryCoords . (^/sum bcs)) . freeVector . Arr.fromList $ tail bcs - -newtype ISimplex n x = ISimplex { iSimplexBCCordEmbed :: Embedding (->) (BaryCoords n) x } - - - - -data TriangBuilder n x where - TriangVerticesSt :: [x] -> TriangBuilder Z x - TriangBuilder :: Triangulation (S n) x - -> [x] - -> [(Simplex n x, [x] -> Option x)] - -> TriangBuilder (S n) x - - - - -bottomExtendSuitability :: (KnownNat n, WithField ℝ Manifold x) - => ISimplex (S n) x -> x -> ℝ -bottomExtendSuitability (ISimplex emb) x = case getBaryCoord (emb >-$ x) 0 of - 0 -> 0 - r -> - recip r - -optimalBottomExtension :: (KnownNat n, WithField ℝ Manifold x) - => ISimplex (S n) x -> [x] -> Option Int -optimalBottomExtension s xs - = case filter ((>0).snd) - $ zipWith ((. bottomExtendSuitability s) . (,)) [0..] xs of - [] -> empty - qs -> pure . fst . maximumBy (comparing snd) $ qs - - - -leavesBarycenter :: WithField ℝ Manifold x => NonEmpty x -> x -leavesBarycenter (x :| xs) = x .+~^ sumV [x'–x | x'<-xs] ^/ (n+1) - where n = fromIntegral $ length xs - x' – x = case x'.-~.x of {Option(Just v)->v} - --- simplexShade :: forall x n . (KnownNat n, WithField ℝ Manifold x) -simplexBarycenter :: forall x n . (KnownNat n, WithField ℝ Manifold x) => Simplex n x -> x -simplexBarycenter = bc - where bc (ZS x) = x - bc (x :<| xs') = x .+~^ sumV [x'–x | x'<-splxVertices xs'] ^/ (n+1) - - Tagged n = theNatN :: Tagged n ℝ - x' – x = case x'.-~.x of {Option(Just v)->v} - - -fromISimplex :: forall x n . (KnownNat n, WithField ℝ Manifold x) - => ISimplex n x -> Simplex n x -fromISimplex (ISimplex emb) = s - where (Option (Just s)) - = makeSimplex' [ emb $-> jOnly - | j <- [0..n] - , let (Option (Just jOnly)) = mkBaryCoords' [ if k==j then 1 else 0 - | k<-[0..n] ] - ] - (Tagged n) = theNatN :: Tagged n Int - -iSimplexSideViews :: ∀ n x . KnownNat n => ISimplex n x -> [ISimplex n x] -iSimplexSideViews = \(ISimplex is) - -> take (n+1) $ [ISimplex $ rot j is | j<-[0..] ] - where rot j (Embedding emb proj) - = Embedding ( emb . mkBaryCoords . freeRotate j . getBaryCoords ) - ( mkBaryCoords . freeRotate (n-j) . getBaryCoords . proj ) - (Tagged n) = theNatN :: Tagged n Int - - -type FullTriang t n x = TriangT t n x - (State (Map.Map (SimplexIT t n x) (ISimplex n x))) - -type TriangBuild t n x = TriangT t (S n) x - ( State (Map.Map (SimplexIT t n x) (Metric x, ISimplex (S n) x) )) - -doTriangBuild :: KnownNat n => (∀ t . TriangBuild t n x ()) -> [Simplex (S n) x] -doTriangBuild t = runIdentity (fst <$> - doTriangT (unliftInTriangT (`evalStateT`mempty) t >> simplexITList >>= mapM lookSimplex)) - - - -hypotheticalSimplexScore :: ∀ t n n' x . (KnownNat n', WithField ℝ Manifold x, n~S n') - => SimplexIT t Z x - -> SimplexIT t n x - -> TriangBuild t n x ( Option Double ) -hypotheticalSimplexScore p b = do - altViews :: [(SimplexIT t Z x, SimplexIT t n x)] <- do - pSups <- lookSupersimplicesIT p - nOpts <- forM pSups $ \psup -> fmap (fmap $ \((bq,_p), _b') -> (bq,psup)) - $ distinctSimplices b psup - return $ catOptions nOpts - scores <- forM ((p,b) :| altViews) $ \(p',b') -> do - x <- lookVertexIT p' - q <- lift $ Map.lookup b' <$> get - return $ case q of - Just(_,is) | s<-bottomExtendSuitability is x, s>0 - -> pure s - _ -> empty - return . fmap sum $ Hask.sequence scores - - - - - -data AutoTriang n x where - AutoTriang :: { getAutoTriang :: ∀ t . TriangBuild t n x () } -> AutoTriang (S n) x - - - -breakdownAutoTriang :: ∀ n n' x . (KnownNat n', n ~ S n') => AutoTriang n x -> [Simplex n x] -breakdownAutoTriang (AutoTriang t) = doTriangBuild t - - --- where tr :: Triangulation n x --- outfc :: Map.Map (SimplexIT t n' x) (Metric x, ISimplex n x) --- (((), tr), outfc) = runState (doTriangT tb') mempty --- tb' :: ∀ t' . TriangT t' n x --- ( State ( Map.Map (SimplexIT t' n' x) --- (Metric x, ISimplex n x) ) ) () --- tb' = tb - - - - - --- primitiveTriangulation :: forall x n . (KnownNat n,WithField ℝ Manifold x) --- => [x] -> Triangulation n x --- primitiveTriangulation xs = head $ build <$> buildOpts --- where build :: ([x], [x]) -> Triangulation n x --- build (mainVerts, sideVerts) = Triangulation [mainSplx] --- where (Option (Just mainSplx)) = makeSimplex mainVerts --- -- mainFaces = Map.fromAscList . zip [0..] . getTriangulation --- -- $ simplexFaces mainSplx --- buildOpts = partitionsOfFstLength n xs --- (Tagged n) = theNatN :: Tagged n Int - -partitionsOfFstLength :: Int -> [a] -> [([a],[a])] -partitionsOfFstLength 0 l = [([],l)] -partitionsOfFstLength n [] = [] -partitionsOfFstLength n (x:xs) = ( first (x:) <$> partitionsOfFstLength (n-1) xs ) - ++ ( second (x:) <$> partitionsOfFstLength n xs ) - -splxVertices :: Simplex n x -> [x] -splxVertices (ZS x) = [x] -splxVertices (x :<| s') = x : splxVertices s' - - - - - - - --- | --- @ --- 'SimpleTree' x ≅ Maybe (x, 'Trees' x) --- @ -type SimpleTree = GenericTree Maybe [] --- | --- @ --- 'Trees' x ≅ [(x, 'Trees' x)] --- @ -type Trees = GenericTree [] [] --- | --- @ --- 'NonEmptyTree' x ≅ (x, 'Trees' x) --- @ -type NonEmptyTree = GenericTree NonEmpty [] - -newtype GenericTree c b x = GenericTree { treeBranches :: c (x,GenericTree b b x) } - deriving (Generic, Hask.Functor, Hask.Foldable, Hask.Traversable) -instance (NFData x, Hask.Foldable c, Hask.Foldable b) => NFData (GenericTree c b x) where - rnf (GenericTree t) = rnf $ toList t -instance (Hask.MonadPlus c) => Semigroup (GenericTree c b x) where - GenericTree b1 <> GenericTree b2 = GenericTree $ Hask.mplus b1 b2 -instance (Hask.MonadPlus c) => Monoid (GenericTree c b x) where - mempty = GenericTree Hask.mzero - mappend = (<>) -deriving instance Show (c (x, GenericTree b b x)) => Show (GenericTree c b x) - --- | Imitate the specialised 'ShadeTree' structure with a simpler, generic tree. -onlyNodes :: (WithField ℝ Manifold x, SimpleSpace (Needle x)) => ShadeTree x -> Trees x -onlyNodes (PlainLeaves []) = GenericTree [] -onlyNodes (PlainLeaves ps) = let (ctr,_) = pseudoECM $ NE.fromList ps - in GenericTree [ (ctr, GenericTree $ (,mempty) <$> ps) ] -onlyNodes (DisjointBranches _ brs) = Hask.foldMap onlyNodes brs -onlyNodes (OverlappingBranches _ (Shade ctr _) brs) - = GenericTree [ (ctr, Hask.foldMap (Hask.foldMap onlyNodes) brs) ] - - --- | Left (and, typically, also right) inverse of 'fromLeafNodes'. -onlyLeaves :: WithField ℝ Manifold x => ShadeTree x -> [x] -onlyLeaves tree = dismantle tree [] - where dismantle (PlainLeaves xs) = (xs++) - dismantle (OverlappingBranches _ _ brs) - = foldr ((.) . dismantle) id $ Hask.foldMap (Hask.toList) brs - dismantle (DisjointBranches _ brs) = foldr ((.) . dismantle) id $ NE.toList brs - - - - - - - - -data Sawbones x = Sawbones { sawnTrunk1, sawnTrunk2 :: [x]->[x] - , sawdust1, sawdust2 :: [x] } -instance Semigroup (Sawbones x) where - Sawbones st11 st12 sd11 sd12 <> Sawbones st21 st22 sd21 sd22 - = Sawbones (st11.st21) (st12.st22) (sd11<>sd21) (sd12<>sd22) -instance Monoid (Sawbones x) where - mempty = Sawbones id id [] [] - mappend = (<>) - - -chainsaw :: (WithField ℝ Manifold x, SimpleSpace (Needle x)) - => Cutplane x -> ShadeTree x -> Sawbones x -chainsaw cpln (PlainLeaves xs) = Sawbones (sd1++) (sd2++) sd2 sd1 - where (sd1,sd2) = partition (\x -> sideOfCut cpln x == Option(Just PositiveHalfSphere)) xs -chainsaw cpln (DisjointBranches _ brs) = Hask.foldMap (chainsaw cpln) brs -chainsaw cpln (OverlappingBranches _ (Shade _ bexpa) brs) = Sawbones t1 t2 d1 d2 - where (Sawbones t1 t2 subD1 subD2) - = Hask.foldMap (Hask.foldMap (chainsaw cpln) . boughContents) brs - [d1,d2] = map (foldl' go [] . foci) [subD1, subD2] - where go d' (dp,dqs) = case fathomCD dp of - Option (Just dpCD) | not $ any (shelter dpCD) dqs - -> dp:d' -- dp is close enough to cut plane to make dust. - _ -> d' -- some dq is actually closer than the cut plane => discard dp. - where shelter dpCutDist dq = case ptsDist dp dq of - Option (Just d) -> d < abs dpCutDist - _ -> False - ptsDist = fmap (dualNorm bexpa|$|) .: (.-~.) - fathomCD = fathomCutDistance cpln bexpa - - -type DList x = [x]->[x] - -data DustyEdges x = DustyEdges { sawChunk :: DList x, chunkDust :: DBranches' x [x] } -instance Semigroup (DustyEdges x) where - DustyEdges c1 d1 <> DustyEdges c2 d2 = DustyEdges (c1.c2) (d1<>d2) - -data Sawboneses x = SingleCut (Sawbones x) - | Sawboneses (DBranches' x (DustyEdges x)) - deriving (Generic) -instance Semigroup (Sawboneses x) where - SingleCut c <> SingleCut d = SingleCut $ c<>d - Sawboneses c <> Sawboneses d = Sawboneses $ c<>d - - - --- | Saw a tree into the domains covered by the respective branches of another tree. -sShSaw :: (WithField ℝ Manifold x, SimpleSpace (Needle x)) - => ShadeTree x -- ^ “Reference tree”, defines the cut regions. - -- Must be at least one level of 'OverlappingBranches' deep. - -> ShadeTree x -- ^ Tree to take the actual contents from. - -> Sawboneses x -- ^ All points within each region, plus those from the - -- boundaries of each neighbouring region. -sShSaw (OverlappingBranches _ (Shade sh _) (DBranch dir _ :| [])) src - = SingleCut $ chainsaw (Cutplane sh $ stiefel1Project dir) src -sShSaw (OverlappingBranches _ (Shade cctr _) cbrs) (PlainLeaves xs) - = Sawboneses . DBranches $ NE.fromList ngbsAdded - where brsEmpty = fmap (\(DBranch dir _)-> DBranch dir mempty) cbrs - srcDistrib = sShIdPartition' cctr xs brsEmpty - ngbsAdded = fmap (\(DBranch dir (Hourglass u l), othrs) - -> let [allOthr,allOthr'] - = map (DBranches . NE.fromList) - [othrs, fmap (\(DBranch d' o) - ->DBranch(negateV d') o) othrs] - in DBranch dir $ Hourglass (DustyEdges (u++) allOthr) - (DustyEdges (l++) allOthr') - ) $ foci (NE.toList srcDistrib) -sShSaw cuts@(OverlappingBranches _ (Shade sh _) cbrs) - (OverlappingBranches _ (Shade _ bexpa) brs) - = Sawboneses . DBranches $ ftr'd - where Option (Just (Sawboneses (DBranches recursed))) - = Hask.foldMap (Hask.foldMap (pure . sShSaw cuts) . boughContents) brs - ftr'd = fmap (\(DBranch dir1 ds) -> DBranch dir1 $ fmap ( - \(DustyEdges bk (DBranches dds)) - -> DustyEdges bk . DBranches $ fmap (obsFilter dir1) dds - ) ds ) recursed - obsFilter dir1 (DBranch dir2 (Hourglass pd2 md2)) - = DBranch dir2 $ Hourglass pd2' md2' - where cpln cpSgn = Cutplane sh . stiefel1Project $ dir1 ^+^ cpSgn*^dir2 - [pd2', md2'] = zipWith (occl . cpln) [-1, 1] [pd2, md2] - occl cpl = foldl' go [] . foci - where go d' (dp,dqs) = case fathomCD dp of - Option (Just dpCD) | not $ any (shelter dpCD) dqs - -> dp:d' - _ -> d' - where shelter dpCutDist dq = case ptsDist dp dq of - Option (Just d) -> d < abs dpCutDist - _ -> False - ptsDist = fmap (dualNorm bexpa|$|) .: (.-~.) - fathomCD = fathomCutDistance cpl bexpa -sShSaw _ _ = error "`sShSaw` is not supposed to cut anything else but `OverlappingBranches`" - - - --- | Essentially the same as @(x,y)@, but not considered as a product topology. --- The 'Semimanifold' etc. instances just copy the topology of @x@, ignoring @y@. -data x`WithAny`y - = WithAny { _untopological :: y - , _topological :: !x } - deriving (Hask.Functor, Show, Generic) - -instance (NFData x, NFData y) => NFData (WithAny x y) - -instance ∀ x y . (Semimanifold x) => Semimanifold (x`WithAny`y) where - type Needle (WithAny x y) = Needle x - type Interior (WithAny x y) = Interior x `WithAny` y - WithAny y x .+~^ δx = WithAny y $ x.+~^δx - fromInterior (WithAny y x) = WithAny y $ fromInterior x - toInterior (WithAny y x) = fmap (WithAny y) $ toInterior x - translateP = tpWD - where tpWD :: ∀ x y . Semimanifold x => Tagged (WithAny x y) - (Interior x`WithAny`y -> Needle x -> Interior x`WithAny`y) - tpWD = Tagged `id` \(WithAny y x) δx -> WithAny y $ tpx x δx - where Tagged tpx = translateP :: Tagged x (Interior x -> Needle x -> Interior x) - semimanifoldWitness = case semimanifoldWitness :: SemimanifoldWitness x of - SemimanifoldWitness -> SemimanifoldWitness - -instance (PseudoAffine x) => PseudoAffine (x`WithAny`y) where - WithAny _ x .-~. WithAny _ ξ = x.-~.ξ - -instance (AffineSpace x) => AffineSpace (x`WithAny`y) where - type Diff (WithAny x y) = Diff x - WithAny _ x .-. WithAny _ ξ = x.-.ξ - WithAny y x .+^ δx = WithAny y $ x.+^δx - -instance (VectorSpace x, Monoid y) => VectorSpace (x`WithAny`y) where - type Scalar (WithAny x y) = Scalar x - μ *^ WithAny y x = WithAny y $ μ*^x - -instance (AdditiveGroup x, Monoid y) => AdditiveGroup (x`WithAny`y) where - zeroV = WithAny mempty zeroV - negateV (WithAny y x) = WithAny y $ negateV x - WithAny y x ^+^ WithAny υ ξ = WithAny (mappend y υ) (x^+^ξ) - -instance (AdditiveGroup x) => Hask.Applicative (WithAny x) where - pure x = WithAny x zeroV - WithAny f x <*> WithAny t ξ = WithAny (f t) (x^+^ξ) - -instance (AdditiveGroup x) => Hask.Monad (WithAny x) where - return x = WithAny x zeroV - WithAny y x >>= f = WithAny r $ x^+^q - where WithAny r q = f y - -shadeWithAny :: y -> Shade x -> Shade (x`WithAny`y) -shadeWithAny y (Shade x xe) = Shade (WithAny y x) xe - -shadeWithoutAnything :: Shade (x`WithAny`y) -> Shade x -shadeWithoutAnything (Shade (WithAny _ b) e) = Shade b e - -constShaded :: y -> ShadeTree x -> x`Shaded`y -constShaded y = unsafeFmapTree (WithAny y<$>) id (shadeWithAny y) - -stripShadedUntopological :: x`Shaded`y -> ShadeTree x -stripShadedUntopological = unsafeFmapTree (fmap _topological) id shadeWithoutAnything - -fmapShaded :: (y -> υ) -> (x`Shaded`y) -> (x`Shaded`υ) -fmapShaded f = unsafeFmapTree (fmap $ \(WithAny y x) -> WithAny (f y) x) - id - (\(Shade yx shx) -> Shade (fmap f yx) shx) - --- | This is to 'ShadeTree' as 'Data.Map.Map' is to 'Data.Set.Set'. -type x`Shaded`y = ShadeTree (x`WithAny`y) - -stiWithDensity :: ( WithField ℝ Manifold x, WithField ℝ LinearManifold y - , SimpleSpace (Needle x) ) - => x`Shaded`y -> x -> Cℝay y -stiWithDensity (PlainLeaves lvs) - | [locShape@(Shade baryc expa)] <- pointsShades $ _topological <$> lvs - = let nlvs = fromIntegral $ length lvs :: ℝ - indiShapes = [(Shade p expa, y) | WithAny y p <- lvs] - in \x -> let lcCoeffs = [ occlusion psh x | (psh, _) <- indiShapes ] - dens = sum lcCoeffs - in mkCone dens . linearCombo . zip (snd<$>indiShapes) - $ (/dens)<$>lcCoeffs -stiWithDensity (DisjointBranches _ lvs) - = \x -> foldr1 qGather $ (`stiWithDensity`x)<$>lvs - where qGather (Cℝay 0 _) o = o - qGather o _ = o -stiWithDensity (OverlappingBranches n (Shade (WithAny _ bc) extend) brs) = ovbSWD - where ovbSWD x = case x .-~. bc of - Option (Just v) - | dist² <- normSq ε v - , dist² < 9 - , att <- exp(1/(dist²-9)+1/9) - -> qGather att $ fmap ($x) downPrepared - _ -> coneTip - ε = dualNorm extend - downPrepared = dp =<< brs - where dp (DBranch _ (Hourglass up dn)) - = fmap stiWithDensity $ up:|[dn] - qGather att contribs = mkCone (att*dens) - $ linearCombo [(v, d/dens) | Cℝay d v <- NE.toList contribs] - where dens = sum (hParamCℝay <$> contribs) - -stiAsIntervalMapping :: (x ~ ℝ, y ~ ℝ) - => x`Shaded`y -> [(x, ((y, Diff y), LinearMap ℝ x y))] -stiAsIntervalMapping = twigsWithEnvirons >=> pure.snd.fst >=> completeTopShading >=> pure. - \(Shade' (xloc, yloc) shd) - -> ( xloc, ( (yloc, recip $ shd|$|(0,1)) - , dependence (dualNorm shd) ) ) - -smoothInterpolate :: ( WithField ℝ Manifold x, WithField ℝ LinearManifold y - , SimpleSpace (Needle x) ) - => NonEmpty (x,y) -> x -> y -smoothInterpolate l = \x -> - case ltr x of - Cℝay 0 _ -> defy - Cℝay _ y -> y - where defy = linearCombo [(y, 1/n) | WithAny y _ <- l'] - n = fromIntegral $ length l' - l' = (uncurry WithAny . swap) <$> NE.toList l - ltr = stiWithDensity $ fromLeafPoints l' - - -spanShading :: ∀ x y . ( WithField ℝ Manifold x, WithField ℝ Manifold y - , SimpleSpace (Needle x), SimpleSpace (Needle y) ) - => (Shade x -> Shade y) -> ShadeTree x -> x`Shaded`y -spanShading f = unsafeFmapTree addYs id addYSh - where addYs :: NonEmpty x -> NonEmpty (x`WithAny`y) - addYs l = foldr (NE.<|) (fmap ( WithAny ymid) l ) - (fmap (`WithAny`xmid) yexamp) - where [xsh@(Shade xmid _)] = pointsCovers $ toList l - Shade ymid yexpa = f xsh - yexamp = [ ymid .+~^ σ*^δy - | δy <- normSpanningSystem yexpa, σ <- [-1,1] ] - addYSh :: Shade x -> Shade (x`WithAny`y) - addYSh xsh = shadeWithAny (_shadeCtr $ f xsh) xsh - - - -coneTip :: (AdditiveGroup v) => Cℝay v -coneTip = Cℝay 0 zeroV - -mkCone :: AdditiveGroup v => ℝ -> v -> Cℝay v -mkCone 0 _ = coneTip -mkCone h v = Cℝay h v - - -foci :: [a] -> [(a,[a])] -foci [] = [] -foci (x:xs) = (x,xs) : fmap (second (x:)) (foci xs) - -fociNE :: NonEmpty a -> NonEmpty (a,[a]) -fociNE (x:|xs) = (x,xs) :| fmap (second (x:)) (foci xs) - - -(.:) :: (c->d) -> (a->b->c) -> a->b->d -(.:) = (.) . (.) - - -catOptions :: [Option a] -> [a] -catOptions = catMaybes . map getOption +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LiberalTypeSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} + + +module Data.Manifold.TreeCover ( + -- * Shades + Shade(..), pattern(:±), Shade'(..), (|±|), IsShade + -- ** Lenses + , shadeCtr, shadeExpanse, shadeNarrowness + -- ** Construction + , fullShade, fullShade', pointsShades, pointsShade's + , pointsCovers, pointsCover's, coverAllAround + -- ** Evaluation + , occlusion + -- ** Misc + , factoriseShade, intersectShade's, linIsoTransformShade + , Refinable, subShade', refineShade', convolveShade', coerceShade + , mixShade's + -- * Shade trees + , ShadeTree(..), fromLeafPoints, onlyLeaves, indexShadeTree, positionIndex + -- * View helpers + , onlyNodes + -- ** Auxiliary types + , SimpleTree, Trees, NonEmptyTree, GenericTree(..) + -- * Misc + , HasFlatView(..), shadesMerge, smoothInterpolate + , allTwigs, twigsWithEnvirons, Twig, TwigEnviron, seekPotentialNeighbours + , completeTopShading, flexTwigsShading, coerceShadeTree + , WithAny(..), Shaded, fmapShaded, joinShaded + , constShaded, zipTreeWithList, stripShadedUntopological + , stiAsIntervalMapping, spanShading + , estimateLocalJacobian + , DifferentialEqn, LocalDifferentialEqn(..) + , propagateDEqnSolution_loc, LocalDataPropPlan(..) + , rangeOnGeodesic + -- ** Triangulation-builders + , TriangBuild, doTriangBuild + , AutoTriang, breakdownAutoTriang + ) where + + +import Data.List hiding (filter, all, elem, sum, foldr1) +import Data.Maybe +import qualified Data.Map as Map +import qualified Data.Vector as Arr +import Data.List.NonEmpty (NonEmpty(..)) +import Data.List.FastNub +import qualified Data.List.NonEmpty as NE +import Data.Semigroup +import Data.Ord (comparing) +import Control.DeepSeq + +import Data.VectorSpace +import Data.AffineSpace +import Math.LinearMap.Category +import Data.Tagged + +import Data.SimplicialComplex +import Data.Manifold.Types +import Data.Manifold.Types.Primitive ((^), empty) +import Data.Manifold.PseudoAffine +import Data.Manifold.Riemannian + +import Data.Embedding +import Data.CoNat + +import Control.Lens (Lens', (^.), (.~), (%~), (&), _2, swapped) +import Control.Lens.TH + +import qualified Prelude as Hask hiding(foldl, sum, sequence) +import qualified Control.Applicative as Hask +import qualified Control.Monad as Hask hiding(forM_, sequence) +import Data.Functor.Identity +import Control.Monad.Trans.State +import Control.Monad.Trans.Writer +import Control.Monad.Trans.OuterMaybe +import Control.Monad.Trans.Class +import qualified Data.Foldable as Hask +import Data.Foldable (all, elem, toList, sum, foldr1) +import qualified Data.Traversable as Hask +import Data.Traversable (forM) + +import Control.Category.Constrained.Prelude hiding + ((^), all, elem, sum, forM, Foldable(..), foldr1, Traversable, traverse) +import Control.Arrow.Constrained +import Control.Monad.Constrained hiding (forM) +import Data.Foldable.Constrained +import Data.Traversable.Constrained (traverse) + +import GHC.Generics (Generic) +import Data.Type.Coercion + + +-- | Possibly / Partially / asymPtotically singular metric. +data PSM x = PSM { + psmExpanse :: !(Metric' x) + , relevantEigenspan :: ![Needle' x] + } + + +-- | A 'Shade' is a very crude description of a region within a manifold. It +-- can be interpreted as either an ellipsoid shape, or as the Gaussian peak +-- of a normal distribution (use +-- for actually sampling from that distribution). +-- +-- For a /precise/ description of an arbitrarily-shaped connected subset of a manifold, +-- there is 'Region', whose implementation is vastly more complex. +data Shade x = Shade { _shadeCtr :: !(Interior x) + , _shadeExpanse :: !(Metric' x) } +deriving instance (Show (Interior x), Show (Metric' x), WithField ℝ PseudoAffine x) + => Show (Shade x) + +-- | A “co-shade” can describe ellipsoid regions as well, but unlike +-- 'Shade' it can be unlimited / infinitely wide in some directions. +-- It does OTOH need to have nonzero thickness, which 'Shade' needs not. +data Shade' x = Shade' { _shade'Ctr :: !(Interior x) + , _shade'Narrowness :: !(Metric x) } +deriving instance (Show (Interior x), Show (Metric x), WithField ℝ PseudoAffine x) + => Show (Shade' x) + +data LocalDifferentialEqn x y = LocalDifferentialEqn { + _predictDerivatives :: Maybe (Shade' (LocalLinear x y)) + , _rescanDerivatives :: Shade' (LocalLinear x y) -> Shade' y -> Maybe (Shade' y) + } +makeLenses ''LocalDifferentialEqn + +type DifferentialEqn x y = Shade (x,y) -> LocalDifferentialEqn x y + +data LocalDataPropPlan x y = LocalDataPropPlan + { _sourcePosition :: !(Interior x) + , _targetPosOffset :: !(Needle x) + , _sourceData, _targetAPrioriData :: !y + , _relatedData :: [(Needle x, y)] + } +deriving instance (Show (Interior x), Show y, Show (Needle x)) => Show (LocalDataPropPlan x y) + +makeLenses ''LocalDataPropPlan + +type Depth = Int +data Wall x = Wall { _wallID :: (Depth,(Int,Int)) + , _wallAnchor :: Interior x + , _wallNormal :: Needle' x + , _wallDistance :: Scalar (Needle x) + } +makeLenses ''Wall + + +class IsShade shade where +-- type (*) shade :: *->* + -- | Access the center of a 'Shade' or a 'Shade''. + shadeCtr :: Lens' (shade x) (Interior x) +-- -- | Convert between 'Shade' and 'Shade' (which must be neither singular nor infinite). +-- unsafeDualShade :: WithField ℝ Manifold x => shade x -> shade* x + -- | Check the statistical likelihood-density of a point being within a shade. + -- This is taken as a normal distribution. + occlusion :: ( PseudoAffine x, SimpleSpace (Needle x) + , s ~ (Scalar (Needle x)), RealDimension s ) + => shade x -> x -> s + factoriseShade :: ( Manifold x, SimpleSpace (Needle x) + , Manifold y, SimpleSpace (Needle y) + , Scalar (Needle x) ~ Scalar (Needle y) ) + => shade (x,y) -> (shade x, shade y) + coerceShade :: (Manifold x, Manifold y, LocallyCoercible x y) => shade x -> shade y + linIsoTransformShade :: ( LinearManifold x, LinearManifold y + , SimpleSpace x, SimpleSpace y, Scalar x ~ Scalar y ) + => (x+>y) -> shade x -> shade y + +instance IsShade Shade where + shadeCtr f (Shade c e) = fmap (`Shade`e) $ f c + occlusion = occ pseudoAffineWitness dualSpaceWitness + where occ :: ∀ x s . ( PseudoAffine x, SimpleSpace (Needle x) + , Scalar (Needle x) ~ s, RealDimension s ) + => PseudoAffineWitness x -> DualNeedleWitness x -> Shade x -> x -> s + occ (PseudoAffineWitness (SemimanifoldWitness _)) DualSpaceWitness (Shade p₀ δ) + = \p -> case toInterior p >>= (.-~.p₀) of + (Just vd) | mSq <- normSq δinv vd + , mSq == mSq -- avoid NaN + -> exp (negate mSq) + _ -> zeroV + where δinv = dualNorm δ + factoriseShade = fs dualSpaceWitness dualSpaceWitness + where fs :: ∀ x y . ( Manifold x, SimpleSpace (Needle x) + , Manifold y, SimpleSpace (Needle y) + , Scalar (Needle x) ~ Scalar (Needle y) ) + => DualNeedleWitness x -> DualNeedleWitness y + -> Shade (x,y) -> (Shade x, Shade y) + fs DualSpaceWitness DualSpaceWitness (Shade (x₀,y₀) δxy) + = (Shade x₀ δx, Shade y₀ δy) + where (δx,δy) = summandSpaceNorms δxy + coerceShade = cS dualSpaceWitness dualSpaceWitness + where cS :: ∀ x y . (LocallyCoercible x y) + => DualNeedleWitness x -> DualNeedleWitness y -> Shade x -> Shade y + cS DualSpaceWitness DualSpaceWitness + = \(Shade x δxym) -> Shade (internCoerce x) (tN δxym) + where tN = case oppositeLocalCoercion :: CanonicalDiffeomorphism y x of + CanonicalDiffeomorphism -> + transformNorm . arr $ coerceNeedle' ([]::[(y,x)]) + internCoerce = case interiorLocalCoercion ([]::[(x,y)]) of + CanonicalDiffeomorphism -> locallyTrivialDiffeomorphism + linIsoTransformShade = lits dualSpaceWitness dualSpaceWitness + where lits :: ∀ x y . ( LinearManifold x, LinearManifold y + , Scalar (Needle x) ~ Scalar (Needle y) ) + => DualSpaceWitness x -> DualSpaceWitness y + -> (x+>y) -> Shade x -> Shade y + lits DualSpaceWitness DualSpaceWitness f (Shade x δx) + = Shade (f $ x) (transformNorm (adjoint $ f) δx) + +instance ImpliesMetric Shade where + type MetricRequirement Shade x = (Manifold x, SimpleSpace (Needle x)) + inferMetric' (Shade _ e) = e + inferMetric = im dualSpaceWitness + where im :: (Manifold x, SimpleSpace (Needle x)) + => DualNeedleWitness x -> Shade x -> Metric x + im DualSpaceWitness (Shade _ e) = dualNorm e + +instance ImpliesMetric Shade' where + type MetricRequirement Shade' x = (Manifold x, SimpleSpace (Needle x)) + inferMetric (Shade' _ e) = e + inferMetric' (Shade' _ e) = dualNorm e + +shadeExpanse :: Lens' (Shade x) (Metric' x) +shadeExpanse f (Shade c e) = fmap (Shade c) $ f e + +instance IsShade Shade' where + shadeCtr f (Shade' c e) = fmap (`Shade'`e) $ f c + occlusion = occ pseudoAffineWitness + where occ :: ∀ x s . ( PseudoAffine x, SimpleSpace (Needle x) + , Scalar (Needle x) ~ s, RealDimension s ) + => PseudoAffineWitness x -> Shade' x -> x -> s + occ (PseudoAffineWitness (SemimanifoldWitness _)) (Shade' p₀ δinv) p + = case toInterior p >>= (.-~.p₀) of + (Just vd) | mSq <- normSq δinv vd + , mSq == mSq -- avoid NaN + -> exp (negate mSq) + _ -> zeroV + factoriseShade (Shade' (x₀,y₀) δxy) = (Shade' x₀ δx, Shade' y₀ δy) + where (δx,δy) = summandSpaceNorms δxy + coerceShade = cS + where cS :: ∀ x y . (LocallyCoercible x y) => Shade' x -> Shade' y + cS = \(Shade' x δxym) -> Shade' (internCoerce x) (tN δxym) + where tN = case oppositeLocalCoercion :: CanonicalDiffeomorphism y x of + CanonicalDiffeomorphism -> + transformNorm . arr $ coerceNeedle ([]::[(y,x)]) + internCoerce = case interiorLocalCoercion ([]::[(x,y)]) of + CanonicalDiffeomorphism -> locallyTrivialDiffeomorphism + linIsoTransformShade f (Shade' x δx) + = Shade' (f $ x) (transformNorm (pseudoInverse f) δx) + +shadeNarrowness :: Lens' (Shade' x) (Metric x) +shadeNarrowness f (Shade' c e) = fmap (Shade' c) $ f e + +instance ∀ x . (PseudoAffine x) => Semimanifold (Shade x) where + type Needle (Shade x) = Needle x + fromInterior = id + toInterior = pure + translateP = Tagged (.+~^) + (.+~^) = case semimanifoldWitness :: SemimanifoldWitness x of + SemimanifoldWitness BoundarylessWitness + -> \(Shade c e) v -> Shade (c.+~^v) e + (.-~^) = case semimanifoldWitness :: SemimanifoldWitness x of + SemimanifoldWitness BoundarylessWitness + -> \(Shade c e) v -> Shade (c.-~^v) e + semimanifoldWitness = case semimanifoldWitness :: SemimanifoldWitness x of + (SemimanifoldWitness BoundarylessWitness) + -> SemimanifoldWitness BoundarylessWitness + +instance (WithField ℝ PseudoAffine x, Geodesic (Interior x), SimpleSpace (Needle x)) + => Geodesic (Shade x) where + geodesicBetween = gb dualSpaceWitness + where gb :: DualNeedleWitness x -> Shade x -> Shade x -> Maybe (D¹ -> Shade x) + gb DualSpaceWitness (Shade c (Norm e)) (Shade ζ (Norm η)) = pure interp + where interp t@(D¹ q) = Shade (pinterp t) + (Norm . arr . lerp ed ηd $ (q+1)/2) + ed@(LinearMap _) = arr e + ηd@(LinearMap _) = arr η + Just pinterp = geodesicBetween c ζ + +instance (AffineManifold x) => Semimanifold (Shade' x) where + type Needle (Shade' x) = Diff x + fromInterior = id + toInterior = pure + translateP = Tagged (.+~^) + Shade' c e .+~^ v = Shade' (c.+^v) e + Shade' c e .-~^ v = Shade' (c.-^v) e + +instance (WithField ℝ AffineManifold x, Geodesic x, SimpleSpace (Needle x)) + => Geodesic (Shade' x) where + geodesicBetween (Shade' c e) (Shade' ζ η) = pure interp + where sharedSpan = sharedNormSpanningSystem e η + interp t = Shade' (pinterp t) + (spanNorm [ v ^/ (alerpB 1 (recip qη) t) + | (v,qη) <- sharedSpan ]) + Just pinterp = geodesicBetween c ζ + +fullShade :: WithField ℝ PseudoAffine x => Interior x -> Metric' x -> Shade x +fullShade ctr expa = Shade ctr expa + +fullShade' :: WithField ℝ PseudoAffine x => Interior x -> Metric x -> Shade' x +fullShade' ctr expa = Shade' ctr expa + + +-- | Span a 'Shade' from a center point and multiple deviation-vectors. +#if GLASGOW_HASKELL < 800 +pattern (:±) :: () +#else +pattern (:±) :: (WithField ℝ Manifold x, SimpleSpace (Needle x)) +#endif + => (WithField ℝ Manifold x, SimpleSpace (Needle x)) + => Interior x -> [Needle x] -> Shade x +pattern x :± shs <- Shade x (varianceSpanningSystem -> shs) + where x :± shs = fullShade x $ spanVariance shs + +-- | Similar to ':±', but instead of expanding the shade, each vector /restricts/ it. +-- Iff these form a orthogonal basis (in whatever sense applicable), then both +-- methods will be equivalent. +-- +-- Note that '|±|' is only possible, as such, in an inner-product space; in +-- general you need reciprocal vectors ('Needle'') to define a 'Shade''. +(|±|) :: WithField ℝ EuclidSpace x => x -> [Needle x] -> Shade' x +x |±| shs = Shade' x $ spanNorm [v^/(v<.>v) | v<-shs] + + + +subshadeId' :: ∀ x . (WithField ℝ PseudoAffine x, LinearSpace (Needle x)) + => x -> NonEmpty (Needle' x) -> x -> (Int, HourglassBulb) +subshadeId' c expvs x = case ( dualSpaceWitness :: DualNeedleWitness x + , x .-~. c ) of + (DualSpaceWitness, Just v) + -> let (iu,vl) = maximumBy (comparing $ abs . snd) + $ zip [0..] (map (v <.>^) $ NE.toList expvs) + in (iu, if vl>0 then UpperBulb else LowerBulb) + _ -> (-1, error "Trying to obtain the subshadeId of a point not actually included in the shade.") + +subshadeId :: ( WithField ℝ PseudoAffine x, LinearSpace (Needle x) + , FiniteDimensional (Needle' x) ) + => Shade x -> x -> (Int, HourglassBulb) +subshadeId (Shade c expa) = subshadeId' (fromInterior c) + . NE.fromList $ normSpanningSystem' expa + + + +-- | Attempt to find a 'Shade' that describes the distribution of given points. +-- At least in an affine space (and thus locally in any manifold), this can be used to +-- estimate the parameters of a normal distribution from which some points were +-- sampled. Note that some points will be “outside” of the shade, +-- as happens for a normal distribution with some statistical likelyhood. +-- (Use 'pointsCovers' if you need to prevent that.) +-- +-- For /nonconnected/ manifolds it will be necessary to yield separate shades +-- for each connected component. And for an empty input list, there is no shade! +-- Hence the result type is a list. +pointsShades :: (WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) + => [Interior x] -> [Shade x] +pointsShades = map snd . pointsShades' mempty . map fromInterior + +coverAllAround :: ∀ x . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) + => Interior x -> [Needle x] -> Shade x +coverAllAround x₀ offs = Shade x₀ + $ guaranteeIn dualSpaceWitness offs + (scaleNorm (1/fromIntegral (length offs)) $ spanVariance offs) + where guaranteeIn :: DualNeedleWitness x -> [Needle x] -> Metric' x -> Metric' x + guaranteeIn w@DualSpaceWitness offs ex + = case offs >>= \v -> guard ((ex'|$|v) > 1) >> [(v, spanVariance [v])] of + [] -> ex + outs -> guaranteeIn w (fst<$>outs) + ( densifyNorm $ + ex <> scaleNorm + (sqrt . recip . fromIntegral + $ 2 * length outs) + (mconcat $ snd<$>outs) + ) + where ex' = dualNorm ex + +-- | Like 'pointsShades', but ensure that all points are actually in +-- the shade, i.e. if @['Shade' x₀ ex]@ is the result then +-- @'metric' (recipMetric ex) (p-x₀) ≤ 1@ for all @p@ in the list. +pointsCovers :: ∀ x . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) + => [Interior x] -> [Shade x] +pointsCovers = case pseudoAffineWitness :: PseudoAffineWitness x of + (PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness)) -> + \ps -> map (\(ps', Shade x₀ _) + -> coverAllAround x₀ [v | p<-ps' + , let Just v + = p.-~.fromInterior x₀]) + (pointsShades' mempty (fromInterior<$>ps) :: [([x], Shade x)]) + +pointsShade's :: ∀ x . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) + => [Interior x] -> [Shade' x] +pointsShade's = case dualSpaceWitness :: DualNeedleWitness x of + DualSpaceWitness -> map (\(Shade c e :: Shade x) -> Shade' c $ dualNorm e) . pointsShades + +pointsCover's :: ∀ x . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) + => [Interior x] -> [Shade' x] +pointsCover's = case dualSpaceWitness :: DualNeedleWitness x of + DualSpaceWitness -> map (\(Shade c e :: Shade x) -> Shade' c $ dualNorm e) . pointsCovers + +pseudoECM :: ∀ x p . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x), Hask.Functor p) + => p x -> NonEmpty x -> (x, ([x],[x])) +pseudoECM = case semimanifoldWitness :: SemimanifoldWitness x of + SemimanifoldWitness _ -> + \_ (p₀ NE.:| psr) -> foldl' ( \(acc, (rb,nr)) (i,p) + -> case (p.-~.acc, toInterior acc) of + (Just δ, Just acci) + -> (acci .+~^ δ^/i, (p:rb, nr)) + _ -> (acc, (rb, p:nr)) ) + (p₀, mempty) + ( zip [1..] $ p₀:psr ) + +pointsShades' :: ∀ x . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) + => Metric' x -> [x] -> [([x], Shade x)] +pointsShades' _ [] = [] +pointsShades' minExt ps = case (expa, toInterior ctr) of + (Just e, Just c) + -> (ps, fullShade c e) : pointsShades' minExt unreachable + _ -> pointsShades' minExt inc'd + ++ pointsShades' minExt unreachable + where (ctr,(inc'd,unreachable)) = pseudoECM ([]::[x]) $ NE.fromList ps + expa = ( (<>minExt) . spanVariance . map (^/ fromIntegral (length ps)) ) + <$> mapM (.-~.ctr) ps + + +-- | Attempt to reduce the number of shades to fewer (ideally, a single one). +-- In the simplest cases these should guaranteed cover the same area; +-- for non-flat manifolds it only works in a heuristic sense. +shadesMerge :: ∀ x . (WithField ℝ Manifold x, SimpleSpace (Needle x)) + => ℝ -- ^ How near (inverse normalised distance, relative to shade expanse) + -- two shades must be to be merged. If this is zero, any shades + -- in the same connected region of a manifold are merged. + -> [Shade x] -- ^ A list of /n/ shades. + -> [Shade x] -- ^ /m/ ≤ /n/ shades which cover at least the same area. +shadesMerge fuzz (sh₁@(Shade c₁ e₁) : shs) + = case extractJust (tryMerge pseudoAffineWitness dualSpaceWitness) + shs of + (Just mg₁, shs') -> shadesMerge fuzz + $ shs'++[mg₁] -- Append to end to prevent undue weighting + -- of first shade and its mergers. + (_, shs') -> sh₁ : shadesMerge fuzz shs' + where tryMerge :: PseudoAffineWitness x -> DualNeedleWitness x + -> Shade x -> Maybe (Shade x) + tryMerge (PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness)) DualSpaceWitness + (Shade c₂ e₂) + | Just v <- c₁.-~.c₂ + , [e₁',e₂'] <- dualNorm<$>[e₁, e₂] + , b₁ <- e₂'|$|v + , b₂ <- e₁'|$|v + , fuzz*b₁*b₂ <= b₁ + b₂ + = Just $ let cc = c₂ .+~^ v ^/ 2 + Just cv₁ = c₁.-~.cc + Just cv₂ = c₂.-~.cc + in Shade cc $ e₁ <> e₂ <> spanVariance [cv₁, cv₂] + | otherwise = Nothing +shadesMerge _ shs = shs + +-- | Weakened version of 'intersectShade's'. What this function calculates is +-- rather the /weighted mean/ of ellipsoid regions. If you interpret the +-- shades as uncertain physical measurements with normal distribution, +-- it gives the maximum-likelyhood result for multiple measurements of the +-- same quantity. +mixShade's :: ∀ y . (WithField ℝ Manifold y, SimpleSpace (Needle y)) + => NonEmpty (Shade' y) -> Maybe (Shade' y) +mixShade's = ms pseudoAffineWitness dualSpaceWitness + where ms :: PseudoAffineWitness y -> DualNeedleWitness y + -> NonEmpty (Shade' y) -> Maybe (Shade' y) + ms (PseudoAffineWitness (SemimanifoldWitness _)) DualSpaceWitness + (Shade' c₀ (Norm e₁):|shs) = sequenceA ciso >> pure mixed + where ciso = [ci.-~.c₀ | Shade' ci shi <- shs] + cis = [v | Just v <- ciso] + σe = arr . sumV $ e₁ : (applyNorm . _shade'Narrowness<$>shs) + cc = σe \$ sumV [ei $ ci | ci <- cis + | Shade' _ (Norm ei) <- shs] + mixed = Shade' (c₀+^cc) $ densifyNorm ( mconcat + [ Norm $ ei ^/ (1+(normSq ni $ ci^-^cc)) + | ni@(Norm ei) <- Norm e₁ : (_shade'Narrowness<$>shs) + | ci <- zeroV : cis + ] ) + Tagged (+^) = translateP :: Tagged y (Interior y->Needle y->Interior y) + -- cc should minimise the quadratic form + -- β(cc) = ∑ᵢ ⟨cc−cᵢ|eᵢ|cc−cᵢ⟩ + -- = ⟨cc|e₁|cc⟩ + ∑ᵢ₌₁… ⟨cc−c₂|e₂|cc−c₂⟩ + -- = ⟨cc|e₁|cc⟩ + ∑ᵢ₌₁…( ⟨cc|eᵢ|cc⟩ − 2⋅⟨cᵢ|eᵢ|cc⟩ + ⟨cᵢ|eᵢ|cᵢ⟩ ) + -- It is thus + -- β(cc + δ⋅v) − β cc + -- = ⟨cc + δ⋅v|e₁|cc + δ⋅v⟩ + -- + ∑ᵢ₌₁…( ⟨cc + δ⋅v|eᵢ|cc + δ⋅v⟩ − 2⋅⟨cᵢ|eᵢ|cc + δ⋅v⟩ + ⟨cᵢ|eᵢ|cᵢ⟩ ) + -- − ⟨cc|e₁|cc⟩ + -- − ∑ᵢ₌₁…( ⟨cc|eᵢ|cc⟩ + 2⋅⟨cᵢ|eᵢ|cc⟩ − ⟨cᵢ|eᵢ|cᵢ⟩ ) + -- = ⟨cc + δ⋅v|e₁|cc + δ⋅v⟩ + -- + ∑ᵢ₌₁…( ⟨cc + δ⋅v|eᵢ|cc + δ⋅v⟩ − 2⋅⟨cᵢ|eᵢ|δ⋅v⟩ ) + -- − ⟨cc|e₁|cc⟩ + -- − ∑ᵢ₌₁…( ⟨cc|eᵢ|cc⟩ ) + -- = 2⋅⟨δ⋅v|e₁|cc⟩ + ⟨δ⋅v|e₁|δ⋅v⟩ + -- + ∑ᵢ₌₁…( 2⋅⟨δ⋅v|eᵢ|cc⟩ + ⟨δ⋅v|eᵢ|δ⋅v⟩ − 2⋅⟨cᵢ|eᵢ|δ⋅v⟩ ) + -- = 2⋅⟨δ⋅v|∑ᵢeᵢ|cc⟩ − 2⋅∑ᵢ₌₁… ⟨cᵢ|eᵢ|δ⋅v⟩ + 𝓞(δ²) + -- This should vanish for all v, which is fulfilled by + -- (∑ᵢeᵢ)|cc⟩ = ∑ᵢ₌₁… eᵢ|cᵢ⟩. + +-- | Evaluate the shade as a quadratic form; essentially +-- @ +-- minusLogOcclusion sh x = x <.>^ (sh^.shadeExpanse $ x - sh^.shadeCtr) +-- @ +-- where 'shadeExpanse' gives a metric (matrix) that characterises the +-- width of the shade. +minusLogOcclusion' :: ∀ x s . ( PseudoAffine x, LinearSpace (Needle x) + , s ~ (Scalar (Needle x)), RealDimension s ) + => Shade' x -> x -> s +minusLogOcclusion' (Shade' p₀ δinv) + = occ (pseudoAffineWitness :: PseudoAffineWitness x) + (dualSpaceWitness :: DualNeedleWitness x) + where occ (PseudoAffineWitness (SemimanifoldWitness _)) DualSpaceWitness + p = case toInterior p >>= (.-~.p₀) of + (Just vd) | mSq <- normSq δinv vd + , mSq == mSq -- avoid NaN + -> mSq + _ -> 1/0 +minusLogOcclusion :: ∀ x s . ( PseudoAffine x, SimpleSpace (Needle x) + , s ~ (Scalar (Needle x)), RealDimension s ) + => Shade x -> x -> s +minusLogOcclusion (Shade p₀ δ) + = occ (pseudoAffineWitness :: PseudoAffineWitness x) + (dualSpaceWitness :: DualNeedleWitness x) + where occ (PseudoAffineWitness (SemimanifoldWitness _)) DualSpaceWitness + = \p -> case toInterior p >>= (.-~.p₀) of + (Just vd) | mSq <- normSq δinv vd + , mSq == mSq -- avoid NaN + -> mSq + _ -> 1/0 + where δinv = dualNorm δ + + + + +rangeOnGeodesic :: ∀ i m . + ( WithField ℝ PseudoAffine m, Geodesic m, SimpleSpace (Needle m) + , WithField ℝ IntervalLike i, SimpleSpace (Needle i) ) + => m -> m -> Maybe (Shade i -> Shade m) +rangeOnGeodesic = case ( semimanifoldWitness :: SemimanifoldWitness i + , dualSpaceWitness :: DualNeedleWitness i + , dualSpaceWitness :: DualNeedleWitness m ) of + (SemimanifoldWitness _, DualSpaceWitness, DualSpaceWitness) -> + \p₀ p₁ -> (`fmap`(geodesicBetween p₀ p₁)) + $ \interp -> \(Shade t₀ et) + -> case pointsShades + . mapMaybe (toInterior + . interp . (toClosedInterval :: i -> D¹)) + $ fromInterior <$> t₀ : [ t₀+^v + | v<-normSpanningSystem et ] of + [sh] -> sh + _ -> case pointsShades $ mapMaybe (toInterior . interp . D¹) + [-0.999, 0.999] of + [sh] -> sh + where Tagged (+^) = translateP :: Tagged i (Interior i->Needle i->Interior i) + + + + +-- | Hourglass as the geometric shape (two opposing ~conical volumes, sharing +-- only a single point in the middle); has nothing to do with time. +data Hourglass s = Hourglass { upperBulb, lowerBulb :: !s } + deriving (Generic, Hask.Functor, Hask.Foldable, Show) +instance (NFData s) => NFData (Hourglass s) +instance (Semigroup s) => Semigroup (Hourglass s) where + Hourglass u l <> Hourglass u' l' = Hourglass (u<>u') (l<>l') + sconcat hgs = let (us,ls) = NE.unzip $ (upperBulb&&&lowerBulb) <$> hgs + in Hourglass (sconcat us) (sconcat ls) +instance (Monoid s, Semigroup s) => Monoid (Hourglass s) where + mempty = Hourglass mempty mempty; mappend = (<>) + mconcat hgs = let (us,ls) = unzip $ (upperBulb&&&lowerBulb) <$> hgs + in Hourglass (mconcat us) (mconcat ls) +instance Hask.Applicative Hourglass where + pure x = Hourglass x x + Hourglass f g <*> Hourglass x y = Hourglass (f x) (g y) +instance Foldable Hourglass (->) (->) where + ffoldl f (x, Hourglass a b) = f (f(x,a), b) + foldMap f (Hourglass a b) = f a `mappend` f b + +flipHour :: Hourglass s -> Hourglass s +flipHour (Hourglass u l) = Hourglass l u + +data HourglassBulb = UpperBulb | LowerBulb +oneBulb :: HourglassBulb -> (a->a) -> Hourglass a->Hourglass a +oneBulb UpperBulb f (Hourglass u l) = Hourglass (f u) l +oneBulb LowerBulb f (Hourglass u l) = Hourglass u (f l) + + + +data ShadeTree x = PlainLeaves [x] + | DisjointBranches !Int (NonEmpty (ShadeTree x)) + | OverlappingBranches !Int !(Shade x) (NonEmpty (DBranch x)) + deriving (Generic) +deriving instance ( WithField ℝ PseudoAffine x, Show x + , Show (Interior x), Show (Needle' x), Show (Metric' x) ) + => Show (ShadeTree x) + +data DBranch' x c = DBranch { boughDirection :: !(Needle' x) + , boughContents :: !(Hourglass c) } + deriving (Generic, Hask.Functor, Hask.Foldable) +type DBranch x = DBranch' x (ShadeTree x) +deriving instance ( WithField ℝ PseudoAffine x, Show (Needle' x), Show c ) + => Show (DBranch' x c) + +newtype DBranches' x c = DBranches (NonEmpty (DBranch' x c)) + deriving (Generic, Hask.Functor, Hask.Foldable) +deriving instance ( WithField ℝ PseudoAffine x, Show (Needle' x), Show c ) + => Show (DBranches' x c) + +-- ^ /Unsafe/: this assumes the direction information of both containers to be equivalent. +instance (Semigroup c) => Semigroup (DBranches' x c) where + DBranches b1 <> DBranches b2 = DBranches $ NE.zipWith (\(DBranch d1 c1) (DBranch _ c2) + -> DBranch d1 $ c1<>c2 ) b1 b2 + + +directionChoices :: WithField ℝ Manifold x + => [DBranch x] + -> [ ( (Needle' x, ShadeTree x) + ,[(Needle' x, ShadeTree x)] ) ] +directionChoices = map (snd *** map snd) . directionIChoices 0 + +directionIChoices :: (WithField ℝ PseudoAffine x, AdditiveGroup (Needle' x)) + => Int -> [DBranch x] + -> [ ( (Int, (Needle' x, ShadeTree x)) + ,[(Int, (Needle' x, ShadeTree x))] ) ] +directionIChoices _ [] = [] +directionIChoices i₀ (DBranch ѧ (Hourglass t b) : hs) + = ( top, bot : map fst uds ) + : ( bot, top : map fst uds ) + : map (second $ (top:) . (bot:)) uds + where top = (i₀,(ѧ,t)) + bot = (i₀+1,(negateV ѧ,b)) + uds = directionIChoices (i₀+2) hs + +traverseDirectionChoices :: ( WithField ℝ PseudoAffine x, LSpace (Needle x) + , Hask.Applicative f ) + => ( (Int, (Needle' x, ShadeTree x)) + -> [(Int, (Needle' x, ShadeTree x))] + -> f (ShadeTree x) ) + -> [DBranch x] + -> f [DBranch x] +traverseDirectionChoices f dbs + = td [] . scanLeafNums 0 + $ dbs >>= \(DBranch ѧ (Hourglass τ β)) + -> [(ѧ,τ), (negateV ѧ,β)] + where td pds (ѧt@(_,(ѧ,_)):vb:vds) + = liftA3 (\t' b' -> (DBranch ѧ (Hourglass t' b') :)) + (f ѧt $ vb:uds) + (f vb $ ѧt:uds) + $ td (ѧt:vb:pds) vds + where uds = pds ++ vds + td _ _ = pure [] + scanLeafNums _ [] = [] + scanLeafNums i₀ ((v,t):vts) = (i₀, (v,t)) : scanLeafNums (i₀ + nLeaves t) vts + + +indexDBranches :: NonEmpty (DBranch x) -> NonEmpty (DBranch' x (Int, ShadeTree x)) +indexDBranches (DBranch d (Hourglass t b) :| l) -- this could more concisely be written as a traversal + = DBranch d (Hourglass (0,t) (nt,b)) :| ixDBs (nt + nb) l + where nt = nLeaves t; nb = nLeaves b + ixDBs _ [] = [] + ixDBs i₀ (DBranch δ (Hourglass τ β) : l) + = DBranch δ (Hourglass (i₀,τ) (i₀+nτ,β)) : ixDBs (i₀ + nτ + nβ) l + where nτ = nLeaves τ; nβ = nLeaves β + +instance (NFData x, NFData (Needle' x)) => NFData (ShadeTree x) where + rnf (PlainLeaves xs) = rnf xs + rnf (DisjointBranches n bs) = n `seq` rnf (NE.toList bs) + rnf (OverlappingBranches n sh bs) = n `seq` sh `seq` rnf (NE.toList bs) +instance (NFData x, NFData (Needle' x)) => NFData (DBranch x) + +-- | Experimental. There might be a more powerful instance possible. +instance (AffineManifold x) => Semimanifold (ShadeTree x) where + type Needle (ShadeTree x) = Diff x + fromInterior = id + toInterior = pure + translateP = Tagged (.+~^) + PlainLeaves xs .+~^ v = PlainLeaves $ (.+^v)<$>xs + OverlappingBranches n sh br .+~^ v + = OverlappingBranches n (sh.+~^v) + $ fmap (\(DBranch d c) -> DBranch d $ (.+~^v)<$>c) br + DisjointBranches n br .+~^ v = DisjointBranches n $ (.+~^v)<$>br + +-- | WRT union. +instance (WithField ℝ Manifold x, SimpleSpace (Needle x)) => Semigroup (ShadeTree x) where + PlainLeaves [] <> t = t + t <> PlainLeaves [] = t + t <> s = fromLeafPoints $ onlyLeaves t ++ onlyLeaves s + -- Could probably be done more efficiently + sconcat = mconcat . NE.toList +instance (WithField ℝ Manifold x, SimpleSpace (Needle x)) => Monoid (ShadeTree x) where + mempty = PlainLeaves [] + mappend = (<>) + mconcat l = case filter ne l of + [] -> mempty + [t] -> t + l' -> fromLeafPoints $ onlyLeaves =<< l' + where ne (PlainLeaves []) = False; ne _ = True + + +-- | Build a quite nicely balanced tree from a cloud of points, on any real manifold. +-- +-- Example: https://nbviewer.jupyter.org/github/leftaroundabout/manifolds/blob/master/test/Trees-and-Webs.ipynb#pseudorandomCloudTree +-- +-- <> +fromLeafPoints :: ∀ x. (WithField ℝ Manifold x, SimpleSpace (Needle x)) + => [x] -> ShadeTree x +fromLeafPoints = fromLeafPoints' sShIdPartition + + +-- | The leaves of a shade tree are numbered. For a given index, this function +-- attempts to find the leaf with that ID, within its immediate environment. +indexShadeTree :: ∀ x . WithField ℝ Manifold x + => ShadeTree x -> Int -> Either Int ([ShadeTree x], x) +indexShadeTree _ i + | i<0 = Left i +indexShadeTree sh@(PlainLeaves lvs) i = case length lvs of + n | i Right ([sh], lvs!!i) + | otherwise -> Left $ i-n +indexShadeTree (DisjointBranches n brs) i + | i (`indexShadeTree`i') + result -> return result + ) (Left i) brs + | otherwise = Left $ i-n +indexShadeTree sh@(OverlappingBranches n _ brs) i + | i foldl (\case + Left i' -> (`indexShadeTree`i') + result -> return result + ) (Left i) (toList brs>>=toList) + | otherwise = Left $ i-n + + +-- | “Inverse indexing” of a tree. This is roughly a nearest-neighbour search, +-- but not guaranteed to give the correct result unless evaluated at the +-- precise position of a tree leaf. +positionIndex :: ∀ x . (WithField ℝ Manifold x, SimpleSpace (Needle x)) + => Maybe (Metric x) -- ^ For deciding (at the lowest level) what “close” means; + -- this is optional for any tree of depth >1. + -> ShadeTree x -- ^ The tree to index into + -> x -- ^ Position to look up + -> Maybe (Int, ([ShadeTree x], x)) + -- ^ Index of the leaf near to the query point, the “path” of + -- environment trees leading down to its position (in decreasing + -- order of size), and actual position of the found node. +positionIndex (Just m) sh@(PlainLeaves lvs) x + = case catMaybes [ ((i,p),) . normSq m <$> p.-~.x + | (i,p) <- zip [0..] lvs] of + [] -> empty + l | ((i,p),_) <- minimumBy (comparing snd) l + -> pure (i, ([sh], p)) +positionIndex m (DisjointBranches _ brs) x + = fst . foldl' (\case + (q@(Just _), i₀) -> const (q, i₀) + (_, i₀) -> \t' -> ( first (+i₀) <$> positionIndex m t' x + , i₀+nLeaves t' ) ) + (empty, 0) + $ brs +positionIndex _ sh@(OverlappingBranches n (Shade c ce) brs) x + | PseudoAffineWitness (SemimanifoldWitness _) + <- pseudoAffineWitness :: PseudoAffineWitness x + , Just vx <- toInterior x>>=(.-~.c) + = let (_,(i₀,t')) = maximumBy (comparing fst) + [ (σ*ω, t') + | DBranch d (Hourglass t'u t'd) <- NE.toList $ indexDBranches brs + , let ω = d<.>^vx + , (t',σ) <- [(t'u, 1), (t'd, -1)] ] + in ((+i₀) *** first (sh:)) + <$> positionIndex (return $ dualNorm' ce) t' x +positionIndex _ _ _ = empty + + + +fromFnGraphPoints :: ∀ x y . ( WithField ℝ Manifold x, WithField ℝ Manifold y + , SimpleSpace (Needle x), SimpleSpace (Needle y) ) + => [(x,y)] -> ShadeTree (x,y) +fromFnGraphPoints = case ( dualSpaceWitness :: DualNeedleWitness x + , boundarylessWitness :: BoundarylessWitness x + , dualSpaceWitness :: DualNeedleWitness y + , boundarylessWitness :: BoundarylessWitness y ) of + (DualSpaceWitness,BoundarylessWitness,DualSpaceWitness,BoundarylessWitness) + -> fromLeafPoints' $ + \(Shade c expa) xs -> case + [ DBranch (v, zeroV) mempty + | v <- normSpanningSystem' (transformNorm (id&&&zeroV) expa :: Metric' x) ] of + (b:bs) -> sShIdPartition' c xs $ b:|bs + +fromLeafPoints' :: ∀ x. (WithField ℝ Manifold x, SimpleSpace (Needle x)) => + (Shade x -> [x] -> NonEmpty (DBranch' x [x])) -> [x] -> ShadeTree x +fromLeafPoints' sShIdPart = go boundarylessWitness mempty + where go :: BoundarylessWitness x -> Metric' x -> [x] -> ShadeTree x + go bw@BoundarylessWitness preShExpa + = \xs -> case pointsShades' (scaleNorm (1/3) preShExpa) xs of + [] -> mempty + [(_,rShade)] -> let trials = sShIdPart rShade xs + in case reduce rShade trials of + Just redBrchs + -> OverlappingBranches + (length xs) rShade + (branchProc (_shadeExpanse rShade) redBrchs) + _ -> PlainLeaves xs + partitions -> DisjointBranches (length xs) + . NE.fromList + $ map (\(xs',pShade) -> go bw mempty xs') partitions + where + branchProc redSh = fmap (fmap $ go bw redSh) + + reduce :: Shade x -> NonEmpty (DBranch' x [x]) + -> Maybe (NonEmpty (DBranch' x [x])) + reduce sh@(Shade c _) brCandidates + = case findIndex deficient cards of + Just i | (DBranch _ reBr, o:ok) + <- amputateId i (NE.toList brCandidates) + -> reduce sh + $ sShIdPartition' c (fold reBr) (o:|ok) + | otherwise -> Nothing + _ -> Just brCandidates + where (cards, maxCard) = (NE.toList &&& maximum') + $ fmap (fmap length . boughContents) brCandidates + deficient (Hourglass u l) = any (\c -> c^2 <= maxCard + 1) [u,l] + maximum' = maximum . NE.toList . fmap (\(Hourglass u l) -> max u l) + + +sShIdPartition' :: (WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) + => Interior x -> [x] -> NonEmpty (DBranch' x [x])->NonEmpty (DBranch' x [x]) +sShIdPartition' c xs st + = foldr (\p -> let (i,h) = ssi p + in asList $ update_nth (\(DBranch d c) + -> DBranch d (oneBulb h (p:) c)) + i ) + st xs + where ssi = subshadeId' (fromInterior c) (boughDirection<$>st) +sShIdPartition :: (WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) + => Shade x -> [x] -> NonEmpty (DBranch' x [x]) +sShIdPartition (Shade c expa) xs + | b:bs <- [DBranch v mempty | v <- normSpanningSystem' expa] + = sShIdPartition' c xs $ b:|bs + + +asList :: ([a]->[b]) -> NonEmpty a->NonEmpty b +asList f = NE.fromList . f . NE.toList + +update_nth :: (a->a) -> Int -> [a] -> [a] +update_nth _ n l | n<0 = l +update_nth f 0 (c:r) = f c : r +update_nth f n [] = [] +update_nth f n (l:r) = l : update_nth f (n-1) r + + +amputateId :: Int -> [a] -> (a,[a]) +amputateId i l = let ([a],bs) = amputateIds [i] l in (a, bs) + +deleteIds :: [Int] -> [a] -> [a] +deleteIds kids = snd . amputateIds kids + +amputateIds :: [Int] -- ^ Sorted list of non-negative indices to extract + -> [a] -- ^ Input list + -> ([a],[a]) -- ^ (Extracted elements, remaining elements) +amputateIds = go 0 + where go _ _ [] = ([],[]) + go _ [] l = ([],l) + go i (k:ks) (x:xs) + | i==k = first (x:) $ go (i+1) ks xs + | otherwise = second (x:) $ go (i+1) (k:ks) xs + + + + +sortByKey :: Ord a => [(a,b)] -> [b] +sortByKey = map snd . sortBy (comparing fst) + + +trunks :: ∀ x. (WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) + => ShadeTree x -> [Shade x] +trunks t = case (pseudoAffineWitness :: PseudoAffineWitness x, t) of + (PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness), PlainLeaves lvs) + -> pointsCovers . catMaybes $ toInterior<$>lvs + (_, DisjointBranches _ brs) -> Hask.foldMap trunks brs + (_, OverlappingBranches _ sh _) -> [sh] + + +nLeaves :: ShadeTree x -> Int +nLeaves (PlainLeaves lvs) = length lvs +nLeaves (DisjointBranches n _) = n +nLeaves (OverlappingBranches n _ _) = n + + +instance ImpliesMetric ShadeTree where + type MetricRequirement ShadeTree x = (WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) + inferMetric = stInfMet + where stInfMet :: ∀ x . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) + => ShadeTree x -> Metric x + stInfMet (OverlappingBranches _ (Shade _ e) _) = dualNorm' e + stInfMet (PlainLeaves lvs) + = case pointsShades $ Hask.toList . toInterior =<< lvs :: [Shade x] of + (Shade _ sh:_) -> dualNorm' sh + _ -> mempty + stInfMet (DisjointBranches _ (br:|_)) = inferMetric br + inferMetric' = stInfMet + where stInfMet :: ∀ x . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) + => ShadeTree x -> Metric' x + stInfMet (OverlappingBranches _ (Shade _ e) _) = e + stInfMet (PlainLeaves lvs) + = case pointsShades $ Hask.toList . toInterior =<< lvs :: [Shade x] of + (Shade _ sh:_) -> sh + _ -> mempty + stInfMet (DisjointBranches _ (br:|_)) = inferMetric' br + + + +overlappingBranches :: Shade x -> NonEmpty (DBranch x) -> ShadeTree x +overlappingBranches shx brs = OverlappingBranches n shx brs + where n = sum $ fmap (sum . fmap nLeaves) brs + +unsafeFmapLeaves :: (x -> x) -> ShadeTree x -> ShadeTree x +unsafeFmapLeaves f (PlainLeaves lvs) = PlainLeaves $ fmap f lvs +unsafeFmapLeaves f (DisjointBranches n brs) + = DisjointBranches n $ unsafeFmapLeaves f <$> brs +unsafeFmapLeaves f (OverlappingBranches n sh brs) + = OverlappingBranches n sh $ fmap (unsafeFmapLeaves f) <$> brs + +unsafeFmapTree :: (NonEmpty x -> NonEmpty y) + -> (Needle' x -> Needle' y) + -> (Shade x -> Shade y) + -> ShadeTree x -> ShadeTree y +unsafeFmapTree _ _ _ (PlainLeaves []) = PlainLeaves [] +unsafeFmapTree f _ _ (PlainLeaves lvs) = PlainLeaves . toList . f $ NE.fromList lvs +unsafeFmapTree f fn fs (DisjointBranches n brs) + = let brs' = unsafeFmapTree f fn fs <$> brs + in DisjointBranches (sum $ nLeaves<$>brs') brs' +unsafeFmapTree f fn fs (OverlappingBranches n sh brs) + = let brs' = fmap (\(DBranch dir br) + -> DBranch (fn dir) (unsafeFmapTree f fn fs<$>br) + ) brs + in overlappingBranches (fs sh) brs' + +coerceShadeTree :: ∀ x y . (LocallyCoercible x y, Manifold x, Manifold y) + => ShadeTree x -> ShadeTree y +coerceShadeTree = case ( dualSpaceWitness :: DualNeedleWitness x + , dualSpaceWitness :: DualNeedleWitness y ) of + (DualSpaceWitness,DualSpaceWitness) + -> unsafeFmapTree (fmap locallyTrivialDiffeomorphism) + (coerceNeedle' ([]::[(x,y)]) $) + coerceShade + + +-- | Class of manifolds which can use 'Shade'' as a basic set type. +-- This is easily possible for vector spaces with the default implementations. +class (WithField ℝ PseudoAffine y, SimpleSpace (Needle y)) => Refinable y where + -- | @a `subShade'` b ≡ True@ means @a@ is fully contained in @b@, i.e. from + -- @'minusLogOcclusion'' a p < 1@ follows also @minusLogOcclusion' b p < 1@. + subShade' :: Shade' y -> Shade' y -> Bool + subShade' (Shade' ac ae) (Shade' tc te) + = case pseudoAffineWitness :: PseudoAffineWitness y of + PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness) + | Just v <- tc.-~.ac + , v² <- normSq te v + , v² <= 1 + -> all (\(y',μ) -> case μ of + Nothing -> True -- 'te' has infinite extension in this direction + Just ξ + | ξ<1 -> False -- 'ae' would be vaster than 'te' in this direction + | ω <- abs $ y'<.>^v + -> (ω + 1/ξ)^2 <= 1 - v² + ω^2 + -- See @images/constructions/subellipse-check-heuristic.svg@ + ) $ sharedSeminormSpanningSystem te ae + _ -> False + + -- | Intersection between two shades. + refineShade' :: Shade' y -> Shade' y -> Maybe (Shade' y) + refineShade' (Shade' c₀ (Norm e₁)) (Shade' c₀₂ (Norm e₂)) + = case ( dualSpaceWitness :: DualNeedleWitness y + , pseudoAffineWitness :: PseudoAffineWitness y ) of + (DualSpaceWitness, PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness)) + -> do + c₂ <- c₀₂.-~.c₀ + let σe = arr $ e₁^+^e₂ + e₁c₂ = e₁ $ c₂ + e₂c₂ = e₂ $ c₂ + cc = σe \$ e₂c₂ + cc₂ = cc ^-^ c₂ + e₁cc = e₁ $ cc + e₂cc = e₂ $ cc + α = 2 + e₂c₂<.>^cc₂ + guard (α > 0) + let ee = σe ^/ α + c₂e₁c₂ = e₁c₂<.>^c₂ + c₂e₂c₂ = e₂c₂<.>^c₂ + c₂eec₂ = (c₂e₁c₂ + c₂e₂c₂) / α + return $ case middle . sort + $ quadraticEqnSol c₂e₁c₂ + (2 * (e₁cc<.>^c₂)) + (e₁cc<.>^cc - 1) + ++quadraticEqnSol c₂e₂c₂ + (2 * (e₂cc<.>^c₂ - c₂e₂c₂)) + (e₂cc<.>^cc - 2 * (e₂c₂<.>^cc) + c₂e₂c₂ - 1) of + [γ₁,γ₂] | abs (γ₁+γ₂) < 2 -> let + cc' = cc ^+^ ((γ₁+γ₂)/2)*^c₂ + rγ = abs (γ₁ - γ₂) / 2 + η = if rγ * c₂eec₂ /= 0 && 1 - rγ^2 * c₂eec₂ > 0 + then sqrt (1 - rγ^2 * c₂eec₂) / (rγ * c₂eec₂) + else 0 + in Shade' (c₀.+~^cc') + (Norm (arr ee) <> spanNorm [ee $ c₂^*η]) + _ -> Shade' (c₀.+~^cc) (Norm $ arr ee) + where quadraticEqnSol a b c + | a == 0, b /= 0 = [-c/b] + | a /= 0 && disc == 0 = [- b / (2*a)] + | a /= 0 && disc > 0 = [ (σ * sqrt disc - b) / (2*a) + | σ <- [-1, 1] ] + | otherwise = [] + where disc = b^2 - 4*a*c + middle (_:x:y:_) = [x,y] + middle l = l + -- ⟨x−c₁|e₁|x−c₁⟩ < 1 ∧ ⟨x−c₂|e₂|x−c₂⟩ < 1 + -- We search (cc,ee) such that this implies + -- ⟨x−cc|ee|x−cc⟩ < 1. + -- Let WLOG c₁ = 0, so + -- ⟨x|e₁|x⟩ < 1. + -- cc should minimise the quadratic form + -- β(cc) = ⟨cc−c₁|e₁|cc−c₁⟩ + ⟨cc−c₂|e₂|cc−c₂⟩ + -- = ⟨cc|e₁|cc⟩ + ⟨cc−c₂|e₂|cc−c₂⟩ + -- = ⟨cc|e₁|cc⟩ + ⟨cc|e₂|cc⟩ − 2⋅⟨c₂|e₂|cc⟩ + ⟨c₂|e₂|c₂⟩ + -- It is thus + -- β(cc + δ⋅v) − β cc + -- = ⟨cc + δ⋅v|e₁|cc + δ⋅v⟩ + ⟨cc + δ⋅v|e₂|cc + δ⋅v⟩ − 2⋅⟨c₂|e₂|cc + δ⋅v⟩ + ⟨c₂|e₂|c₂⟩ + -- − ⟨cc|e₁|cc⟩ − ⟨cc|e₂|cc⟩ + 2⋅⟨c₂|e₂|cc⟩ − ⟨c₂|e₂|c₂⟩ + -- = ⟨cc + δ⋅v|e₁|cc + δ⋅v⟩ + ⟨cc + δ⋅v|e₂|cc + δ⋅v⟩ − 2⋅⟨c₂|e₂|δ⋅v⟩ + -- − ⟨cc|e₁|cc⟩ − ⟨cc|e₂|cc⟩ + -- = 2⋅⟨δ⋅v|e₁|cc⟩ + ⟨δ⋅v|e₁|δ⋅v⟩ + 2⋅⟨δ⋅v|e₂|cc⟩ + ⟨δ⋅v|e₂|δ⋅v⟩ − 2⋅⟨c₂|e₂|δ⋅v⟩ + -- = 2⋅δ⋅⟨v|e₁+e₂|cc⟩ − 2⋅δ⋅⟨v|e₂|c₂⟩ + 𝓞(δ²) + -- This should vanish for all v, which is fulfilled by + -- (e₁+e₂)|cc⟩ = e₂|c₂⟩. + -- + -- If we now choose + -- ee = (e₁+e₂) / α + -- then + -- ⟨x−cc|ee|x−cc⟩ ⋅ α + -- = ⟨x−cc|ee|x⟩ ⋅ α − ⟨x−cc|ee|cc⟩ ⋅ α + -- = ⟨x|ee|x−cc⟩ ⋅ α − ⟨x−cc|e₂|c₂⟩ + -- = ⟨x|ee|x⟩ ⋅ α − ⟨x|ee|cc⟩ ⋅ α − ⟨x−cc|e₂|c₂⟩ + -- = ⟨x|e₁+e₂|x⟩ − ⟨x|e₂|c₂⟩ − ⟨x−cc|e₂|c₂⟩ + -- = ⟨x|e₁|x⟩ + ⟨x|e₂|x⟩ − ⟨x|e₂|c₂⟩ − ⟨x−cc|e₂|c₂⟩ + -- < 1 + ⟨x|e₂|x−c₂⟩ − ⟨x−cc|e₂|c₂⟩ + -- = 1 + ⟨x−c₂|e₂|x−c₂⟩ + ⟨c₂|e₂|x−c₂⟩ − ⟨x−cc|e₂|c₂⟩ + -- < 2 + ⟨x−c₂−x+cc|e₂|c₂⟩ + -- = 2 + ⟨cc−c₂|e₂|c₂⟩ + -- Really we want + -- ⟨x−cc|ee|x−cc⟩ ⋅ α < α + -- So choose α = 2 + ⟨cc−c₂|e₂|c₂⟩. + -- + -- The ellipsoid "cc±√ee" captures perfectly the intersection + -- of the boundary of the shades, but it tends to significantly + -- overshoot the interior intersection in perpendicular direction, + -- i.e. in direction of c₂−c₁. E.g. + -- https://github.com/leftaroundabout/manifolds/blob/bc0460b9/manifolds/images/examples/ShadeCombinations/EllipseIntersections.png + -- 1. Really, the relevant points are those where either of the + -- intersector badnesses becomes 1. The intersection shade should + -- be centered between those points. We perform according corrections, + -- but only in c₂ direction, so this can be handled efficiently + -- as a 1D quadratic equation. + -- Consider + -- dⱼ c := ⟨c−cⱼ|eⱼ|c−cⱼ⟩ =! 1 + -- dⱼ (cc + γ⋅c₂) + -- = ⟨cc+γ⋅c₂−cⱼ|eⱼ|cc+γ⋅c₂−cⱼ⟩ + -- = ⟨cc−cⱼ|eⱼ|cc−cⱼ⟩ + 2⋅γ⋅⟨c₂|eⱼ|cc−cⱼ⟩ + γ²⋅⟨c₂|eⱼ|c₂⟩ + -- =! 1 + -- So + -- γⱼ = (- b ± √(b²−4⋅a⋅c)) / 2⋅a + -- where a = ⟨c₂|eⱼ|c₂⟩ + -- b = 2 ⋅ (⟨c₂|eⱼ|cc⟩ − ⟨c₂|eⱼ|cⱼ⟩) + -- c = ⟨cc|eⱼ|cc⟩ − 2⋅⟨cc|eⱼ|cⱼ⟩ + ⟨cⱼ|eⱼ|cⱼ⟩ − 1 + -- The ± sign should be chosen to get the smaller |γ| (otherwise + -- we end up on the wrong side of the shade), i.e. + -- γⱼ = (sgn bⱼ ⋅ √(bⱼ²−4⋅aⱼ⋅cⱼ) − bⱼ) / 2⋅aⱼ + -- 2. Trim the result in that direction to the actual + -- thickness of the lens-shaped intersection: we want + -- ⟨rγ⋅c₂|ee'|rγ⋅c₂⟩ = 1 + -- for a squeezed version of ee, + -- ee' = ee + ee|η⋅c₂⟩⟨η⋅c₂|ee + -- ee' = ee + η² ⋅ ee|c₂⟩⟨c₂|ee + -- ⟨rγ⋅c₂|ee'|rγ⋅c₂⟩ + -- = rγ² ⋅ (⟨c₂|ee|c₂⟩ + η² ⋅ ⟨c₂|ee|c₂⟩²) + -- = rγ² ⋅ ⟨c₂|ee|c₂⟩ + η² ⋅ rγ² ⋅ ⟨c₂|ee|c₂⟩² + -- η² = (1 − rγ²⋅⟨c₂|ee|c₂⟩) / (rγ² ⋅ ⟨c₂|ee|c₂⟩²) + -- η = √(1 − rγ²⋅⟨c₂|ee|c₂⟩) / (rγ ⋅ ⟨c₂|ee|c₂⟩) + -- With ⟨c₂|ee|c₂⟩ = (⟨c₂|e₁|c₂⟩ + ⟨c₂|e₂|c₂⟩)/α. + + + -- | If @p@ is in @a@ (red) and @δ@ is in @b@ (green), + -- then @p.+~^δ@ is in @convolveShade' a b@ (blue). + -- +-- Example: https://nbviewer.jupyter.org/github/leftaroundabout/manifolds/blob/master/test/ShadeCombinations.ipynb#shadeConvolutions +-- +-- <> + convolveMetric :: Hask.Functor p => p y -> Metric y -> Metric y -> Metric y + convolveMetric _ ey eδ = spanNorm [ f ^* ζ crl + | (f,crl) <- eδsp ] + where eδsp = sharedSeminormSpanningSystem ey eδ + ζ = case filter (>0) . catMaybes $ snd<$>eδsp of + [] -> const 0 + nzrelap + -> let cre₁ = 1/minimum nzrelap + cre₂ = maximum nzrelap + edgeFactor = sqrt ( (1 + cre₁)^2 + (1 + cre₂)^2 ) + / (sqrt (1 + cre₁^2) + sqrt (1 + cre₂^2)) + in \case + Nothing -> 0 + Just 0 -> 0 + Just sq -> edgeFactor / (recip sq + 1) + + convolveShade' :: Shade' y -> Shade' (Needle y) -> Shade' y + convolveShade' = defaultConvolveShade' + +defaultConvolveShade' :: ∀ y . Refinable y => Shade' y -> Shade' (Needle y) -> Shade' y +defaultConvolveShade' = case (pseudoAffineWitness :: PseudoAffineWitness y) of + PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness) + -> \(Shade' y₀ ey) (Shade' δ₀ eδ) -> Shade' (y₀.+~^δ₀) + $ convolveMetric ([]::[y]) ey eδ + +instance Refinable ℝ where + refineShade' (Shade' cl el) (Shade' cr er) + = case (normSq el 1, normSq er 1) of + (0, _) -> return $ Shade' cr er + (_, 0) -> return $ Shade' cl el + (ql,qr) | ql>0, qr>0 + -> let [rl,rr] = sqrt . recip <$> [ql,qr] + b = maximum $ zipWith (-) [cl,cr] [rl,rr] + t = minimum $ zipWith (+) [cl,cr] [rl,rr] + in guard (b> + let cm = (b+t)/2 + rm = (t-b)/2 + in return $ Shade' cm (spanNorm [recip rm]) +-- convolveShade' (Shade' y₀ ey) (Shade' δ₀ eδ) +-- = case (metricSq ey 1, metricSq eδ 1) of +-- (wy,wδ) | wy>0, wδ>0 +-- -> Shade' (y₀.+~^δ₀) +-- ( projector . recip +-- $ recip (sqrt wy) + recip (sqrt wδ) ) +-- (_ , _) -> Shade' y₀ zeroV + +instance ( Refinable a, Interior a ~ a, Refinable b, Interior b ~ b + , Scalar (DualVector (DualVector (Needle b))) + ~ Scalar (DualVector (DualVector (Needle a))) ) + => Refinable (a,b) + +instance Refinable ℝ⁰ +instance Refinable ℝ¹ +instance Refinable ℝ² +instance Refinable ℝ³ +instance Refinable ℝ⁴ + +instance ( SimpleSpace a, SimpleSpace b + , Scalar a ~ ℝ, Scalar b ~ ℝ + , Scalar (DualVector a) ~ ℝ, Scalar (DualVector b) ~ ℝ + , Scalar (DualVector (DualVector a)) ~ ℝ, Scalar (DualVector (DualVector b)) ~ ℝ ) + => Refinable (LinearMap ℝ a b) + +intersectShade's :: ∀ y . Refinable y => NonEmpty (Shade' y) -> Maybe (Shade' y) +intersectShade's (sh:|shs) = Hask.foldrM refineShade' sh shs + + +estimateLocalJacobian :: ∀ x y . ( WithField ℝ Manifold x, Refinable y + , SimpleSpace (Needle x), SimpleSpace (Needle y) ) + => Metric x -> [(Local x, Shade' y)] + -> Maybe (Shade' (LocalLinear x y)) +estimateLocalJacobian = elj ( pseudoAffineWitness :: PseudoAffineWitness x + , pseudoAffineWitness :: PseudoAffineWitness y ) + where elj ( PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness) + , PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness) ) + mex [(Local x₁, Shade' y₁ ey₁),(Local x₀, Shade' y₀ ey₀)] + = return $ Shade' (dx-+|>δy) + (Norm . LinearFunction $ \δj -> δx ⊗ (σey<$|δj $ δx)) + where Just δx = x₁.-~.x₀ + δx' = (mex<$|δx) + dx = δx'^/(δx'<.>^δx) + Just δy = y₁.-~.y₀ + σey = convolveMetric ([]::[y]) ey₀ ey₁ + elj _ mex (po:ps) + | DualSpaceWitness <- dualSpaceWitness :: DualNeedleWitness y + , length ps > 1 + = mixShade's =<< (:|) <$> estimateLocalJacobian mex ps + <*> sequenceA [estimateLocalJacobian mex [po,pi] | pi<-ps] + elj _ _ _ = return $ Shade' zeroV mempty + + + +propagateDEqnSolution_loc :: ∀ x y . ( WithField ℝ Manifold x + , Refinable y, Geodesic (Interior y) + , SimpleSpace (Needle x) ) + => DifferentialEqn x y + -> LocalDataPropPlan x (Shade' y) + -> Maybe (Shade' y) +propagateDEqnSolution_loc f propPlan + = pdesl (dualSpaceWitness :: DualNeedleWitness x) + (dualSpaceWitness :: DualNeedleWitness y) + (boundarylessWitness :: BoundarylessWitness x) + (pseudoAffineWitness :: PseudoAffineWitness y) + where pdesl DualSpaceWitness DualSpaceWitness BoundarylessWitness + (PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness)) + | Nothing <- jacobian = Nothing + | otherwise = pure result + where jacobian = f shxy ^. predictDerivatives + Just (Shade' j₀ jExpa) = jacobian + + mx = propPlan^.sourcePosition .+~^ propPlan^.targetPosOffset ^/ 2 + Just my = middleBetween (propPlan^.sourceData.shadeCtr) + (propPlan^.targetAPrioriData.shadeCtr) + shxy = coverAllAround (mx, my) + [ (δx ^-^ propPlan^.targetPosOffset ^/ 2, py ^+^ v) + | (δx,ney) <- (zeroV, propPlan^.sourceData) + : (propPlan^.relatedData) + , let Just py = ney^.shadeCtr .-~. my + , v <- normSpanningSystem' (ney^.shadeNarrowness) + ] + (Shade _ expax' :: Shade x) + = coverAllAround (propPlan^.sourcePosition) + [δx | (δx,_) <- propPlan^.relatedData] + expax = dualNorm expax' + result :: Shade' y + result = convolveShade' + (propPlan^.sourceData) + (Shade' δyb $ applyLinMapNorm jExpa dx) + where δyb = j₀ $ δx + δx = propPlan^.targetPosOffset + dx = δx'^/(δx'<.>^δx) + where δx' = expax<$|δx + +applyLinMapNorm :: ∀ x y . (LSpace x, LSpace y, Scalar x ~ Scalar y) + => Norm (x+>y) -> DualVector x -> Norm y +applyLinMapNorm = case dualSpaceWitness :: DualSpaceWitness y of + DualSpaceWitness -> \n dx -> transformNorm (arr $ LinearFunction (dx-+|>)) n + +ignoreDirectionalDependence :: ∀ x y . (LSpace x, LSpace y, Scalar x ~ Scalar y) + => (x, DualVector x) -> Norm (x+>y) -> Norm (x+>y) +ignoreDirectionalDependence = case dualSpaceWitness :: DualSpaceWitness y of + DualSpaceWitness -> \(v,v') -> transformNorm . arr . LinearFunction $ + \j -> j . arr (LinearFunction $ \x -> x ^-^ v^*(v'<.>^x)) + +type Twig x = (Int, ShadeTree x) +type TwigEnviron x = [Twig x] + +allTwigs :: ∀ x . WithField ℝ PseudoAffine x => ShadeTree x -> [Twig x] +allTwigs tree = go 0 tree [] + where go n₀ (DisjointBranches _ dp) + = snd (foldl' (\(n₀',prev) br -> (n₀'+nLeaves br, prev . go n₀' br)) (n₀,id) dp) + go n₀ (OverlappingBranches _ _ dp) + = snd (foldl' (\(n₀',prev) (DBranch _ (Hourglass top bot)) + -> ( n₀'+nLeaves top+nLeaves bot + , prev . go n₀' top . go (n₀'+nLeaves top) bot) ) + (n₀,id) $ NE.toList dp) + go n₀ twig = ((n₀,twig):) + +-- Formerly, 'twigsWithEnvirons' what has now become 'traverseTwigsWithEnvirons'. +-- The simple list-yielding version (see rev. b4a427d59ec82889bab2fde39225b14a57b694df) +-- may well be more efficient than the current traversal-derived version. + +-- | Example: https://nbviewer.jupyter.org/github/leftaroundabout/manifolds/blob/master/test/Trees-and-Webs.ipynb#pseudorandomCloudTree +-- +-- <> +twigsWithEnvirons :: ∀ x. (WithField ℝ Manifold x, SimpleSpace (Needle x)) + => ShadeTree x -> [(Twig x, TwigEnviron x)] +twigsWithEnvirons = execWriter . traverseTwigsWithEnvirons (writer . (snd.fst&&&pure)) + +traverseTwigsWithEnvirons :: ∀ x f . + (WithField ℝ PseudoAffine x, SimpleSpace (Needle x), Hask.Applicative f) + => ( (Twig x, TwigEnviron x) -> f (ShadeTree x) ) -> ShadeTree x -> f (ShadeTree x) +traverseTwigsWithEnvirons f = fst . go pseudoAffineWitness [] . (0,) + where go :: PseudoAffineWitness x -> TwigEnviron x -> Twig x -> (f (ShadeTree x), Bool) + go sw _ (i₀, DisjointBranches nlvs djbs) = ( fmap (DisjointBranches nlvs) + . Hask.traverse (fst . go sw []) + $ NE.zip ioffs djbs + , False ) + where ioffs = NE.scanl (\i -> (+i) . nLeaves) i₀ djbs + go sw@(PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness)) envi + ct@(i₀, (OverlappingBranches nlvs rob@(Shade robc _) brs)) + = ( case descentResult of + OuterNothing -> f + $ purgeRemotes + (ct, Hask.foldMap (\(io,te) + -> first (+io) <$> twigProximæ sw robc te) envi) + OuterJust dR -> fmap (OverlappingBranches nlvs rob . NE.fromList) dR + , False ) + where descentResult = traverseDirectionChoices tdc $ NE.toList brs + tdc (io, (vy, ty)) alts = case go sw envi'' (i₀+io, ty) of + (_, True) -> OuterNothing + (down, _) -> OuterJust down + where envi'' = filter (snd >>> trunks >>> \(Shade ce _:_) + -> let Just δyenv = ce.-~.robc + qq = vy<.>^δyenv + in qq > -1 + ) envi' + ++ map ((+i₀)***snd) alts + envi' = approach =<< envi + approach (i₀e, apt@(OverlappingBranches _ (Shade envc _) _)) + = first (+i₀e) <$> twigsaveTrim hither apt + where Just δxenv = robc .-~. envc + hither (DBranch bdir (Hourglass bdc₁ bdc₂)) + = [(0 , bdc₁) | overlap > -1] + ++ [(nLeaves bdc₁, bdc₂) | overlap < 1] + where overlap = bdir<.>^δxenv + approach q = [q] + go (PseudoAffineWitness (SemimanifoldWitness _)) envi plvs@(i₀, (PlainLeaves _)) + = (f $ purgeRemotes (plvs, envi), True) + + twigProximæ :: PseudoAffineWitness x -> Interior x -> ShadeTree x -> TwigEnviron x + twigProximæ sw x₀ (DisjointBranches _ djbs) + = Hask.foldMap (\(i₀,st) -> first (+i₀) <$> twigProximæ sw x₀ st) + $ NE.zip ioffs djbs + where ioffs = NE.scanl (\i -> (+i) . nLeaves) 0 djbs + twigProximæ sw@(PseudoAffineWitness (SemimanifoldWitness _)) + x₀ ct@(OverlappingBranches _ (Shade xb qb) brs) + = twigsaveTrim hither ct + where Just δxb = x₀ .-~. xb + hither (DBranch bdir (Hourglass bdc₁ bdc₂)) + = ((guard (overlap > -1)) >> twigProximæ sw x₀ bdc₁) + ++ ((guard (overlap < 1)) >> first (+nLeaves bdc₁)<$>twigProximæ sw x₀ bdc₂) + where overlap = bdir<.>^δxb + twigProximæ _ _ plainLeaves = [(0, plainLeaves)] + + twigsaveTrim :: (DBranch x -> TwigEnviron x) -> ShadeTree x -> TwigEnviron x + twigsaveTrim f ct@(OverlappingBranches _ _ dbs) + = case Hask.mapM (\(i₀,dbr) -> noLeaf $ first(+i₀)<$>f dbr) + $ NE.zip ioffs dbs of + Just pqe -> Hask.fold pqe + _ -> [(0,ct)] + where noLeaf [(_,PlainLeaves _)] = empty + noLeaf bqs = pure bqs + ioffs = NE.scanl (\i -> (+i) . sum . fmap nLeaves . toList) 0 dbs + + purgeRemotes :: (Twig x, TwigEnviron x) -> (Twig x, TwigEnviron x) + purgeRemotes = id -- See 7d1f3a4 for the implementation; this didn't work reliable. + +completeTopShading :: ∀ x y . ( WithField ℝ PseudoAffine x, WithField ℝ PseudoAffine y + , SimpleSpace (Needle x), SimpleSpace (Needle y) ) + => x`Shaded`y -> [Shade' (x,y)] +completeTopShading (PlainLeaves plvs) = case ( dualSpaceWitness :: DualNeedleWitness x + , dualSpaceWitness :: DualNeedleWitness y ) of + (DualSpaceWitness, DualSpaceWitness) + -> pointsShade's . catMaybes + $ toInterior . (_topological &&& _untopological) <$> plvs +completeTopShading (DisjointBranches _ bqs) + = take 1 . completeTopShading =<< NE.toList bqs +completeTopShading t = case ( dualSpaceWitness :: DualNeedleWitness x + , dualSpaceWitness :: DualNeedleWitness y ) of + (DualSpaceWitness, DualSpaceWitness) + -> pointsCover's . catMaybes + . map (toInterior <<< _topological &&& _untopological) $ onlyLeaves t + + +transferAsNormsDo :: ∀ v . LSpace v => Norm v -> Variance v -> v-+>v +transferAsNormsDo = case dualSpaceWitness :: DualSpaceWitness v of + DualSpaceWitness -> \(Norm m) (Norm n) -> n . m + +flexTopShading :: ∀ x y f . ( WithField ℝ Manifold x, WithField ℝ Manifold y + , SimpleSpace (Needle x), SimpleSpace (Needle y) + , Applicative f (->) (->) ) + => (Shade' (x,y) -> f (x, (Shade' y, LocalLinear x y))) + -> x`Shaded`y -> f (x`Shaded`y) +flexTopShading f tr = seq (assert_onlyToplevDisjoint tr) + $ recst (dualSpaceWitness::DualNeedleWitness x + ,dualSpaceWitness::DualNeedleWitness y + ,pseudoAffineWitness::PseudoAffineWitness y) + (completeTopShading tr) tr + where recst _ qsh@(_:_) (DisjointBranches n bqs) + = undefined -- DisjointBranches n $ NE.zipWith (recst . (:[])) (NE.fromList qsh) bqs + recst (DualSpaceWitness,DualSpaceWitness,PseudoAffineWitness (SemimanifoldWitness _)) + [sha@(Shade' (_,yc₀) expa₀)] t = fmap fts $ f sha + where expa'₀ = dualNorm expa₀ + j₀ :: LocalLinear x y + j₀ = dependence expa'₀ + (_,expay₀) = summandSpaceNorms expa₀ + fts (xc, (Shade' yc expay, jtg)) = unsafeFmapLeaves applδj t + where Just δyc = yc.-~.yc₀ + tfm = transferAsNormsDo expay₀ (dualNorm expay) + applδj (WithAny y x) + = WithAny (yc₀ .+~^ ((tfm $ δy) ^+^ (jtg $ δx) ^+^ δyc)) x + where Just δx = x.-~.xc + Just δy = y.-~.(yc₀.+~^(j₀ $ δx)) + + assert_onlyToplevDisjoint, assert_connected :: x`Shaded`y -> () + assert_onlyToplevDisjoint (DisjointBranches _ dp) = rnf (assert_connected<$>dp) + assert_onlyToplevDisjoint t = assert_connected t + assert_connected (OverlappingBranches _ _ dp) + = rnf (Hask.foldMap assert_connected<$>dp) + assert_connected (PlainLeaves _) = () + +flexTwigsShading :: ∀ x y f . ( WithField ℝ Manifold x, WithField ℝ Manifold y + , SimpleSpace (Needle x), SimpleSpace (Needle y) + , Hask.Applicative f ) + => (Shade' (x,y) -> f (x, (Shade' y, LocalLinear x y))) + -> x`Shaded`y -> f (x`Shaded`y) +flexTwigsShading f = traverseTwigsWithEnvirons locFlex + where locFlex :: ∀ μ . ((Int, x`Shaded`y), μ) -> f (x`Shaded`y) + locFlex ((_,lsh), _) = flexTopShading f lsh + + + +seekPotentialNeighbours :: ∀ x . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) + => ShadeTree x -> x`Shaded`[Int] +seekPotentialNeighbours tree = zipTreeWithList tree + $ snd<$>leavesWithPotentialNeighbours tree + +leavesWithPotentialNeighbours :: ∀ x . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) + => ShadeTree x -> [(x, [Int])] +leavesWithPotentialNeighbours = map (second snd) . go pseudoAffineWitness 0 0 [] + where go :: PseudoAffineWitness x -> Depth -> Int -> [Wall x] -> ShadeTree x + -> [(x, ([Wall x], [Int]))] + go (PseudoAffineWitness (SemimanifoldWitness _)) depth n₀ walls (PlainLeaves lvs) + = [ (x, ( [ wall & wallDistance .~ d + | wall <- walls + , Just vw <- [toInterior x>>=(.-~.wall^.wallAnchor)] + , let d = (wall^.wallNormal)<.>^vw + , d < wall^.wallDistance ] + , [] )) + | x <- lvs ] + go pw depth n₀ walls (DisjointBranches _ dp) + = snd (foldl' (\(n₀',prev) br -> ( n₀'+nLeaves br + , prev . (go pw depth n₀' walls br++))) + (n₀,id) dp) [] + go pw@(PseudoAffineWitness (SemimanifoldWitness _)) + depth n₀ walls (OverlappingBranches _ (Shade brCtr _) dp) + = reassemble $ snd + (foldl' assignWalls (n₀,id) . directionIChoices 0 $ NE.toList dp) [] + where assignWalls :: (Int, DList (x, ([Wall x],[Int]))) + -> ((Int,(Needle' x, ShadeTree x)), [(Int,(Needle' x, ShadeTree x))]) + -> (Int, DList (x, ([Wall x], [Int]))) + assignWalls (n₀',prev) ((iDir,(thisDir,br)),otherDirs) + = ( n₀'+nLeaves br + , prev . (go pw (depth+1) n₀' + (newWalls ++ (updWall<$>walls)) + br ++) ) + where newWalls = [ Wall (depth,(iDir,iDir')) + brCtr + (thisDir^-^otherDir) + (1/0) + | (iDir',(otherDir,_)) <- otherDirs ] + updWall wall = wall & wallDistance %~ min bcDist + where Just vbw = brCtr.-~.wall^.wallAnchor + bcDist = (wall^.wallNormal)<.>^vbw + reassemble :: [(x, ([Wall x],[Int]))] -> [(x, ([Wall x],[Int]))] + reassemble pts = [ (x, (higherWalls, newGroups++deeperGroups)) + | (x, (allWalls, deeperGroups)) <- pts + , let (levelWalls,higherWalls) + = break (( Map.fromListWith (.) + [ (wall^.wallID._2, (i:)) + | (i,(_, (gsc,_))) <- zip [n₀..] pts + , wall <- takeWhile ((==depth) . fst . _wallID) gsc ] + + + + + + +newtype BaryCoords n = BaryCoords { getBaryCoordsTail :: FreeVect n ℝ } + +instance (KnownNat n) => AffineSpace (BaryCoords n) where + type Diff (BaryCoords n) = FreeVect n ℝ + BaryCoords v .-. BaryCoords w = v ^-^ w + BaryCoords v .+^ w = BaryCoords $ v ^+^ w +instance (KnownNat n) => Semimanifold (BaryCoords n) where + type Needle (BaryCoords n) = FreeVect n ℝ + fromInterior = id + toInterior = pure + translateP = Tagged (.+~^) + (.+~^) = (.+^) + semimanifoldWitness = undefined +instance (KnownNat n) => PseudoAffine (BaryCoords n) where + (.-~.) = pure .: (.-.) + +getBaryCoords :: BaryCoords n -> ℝ ^ S n +getBaryCoords (BaryCoords (FreeVect bcs)) = FreeVect $ (1 - Arr.sum bcs) `Arr.cons` bcs + +getBaryCoords' :: BaryCoords n -> [ℝ] +getBaryCoords' (BaryCoords (FreeVect bcs)) = 1 - Arr.sum bcs : Arr.toList bcs + +getBaryCoord :: BaryCoords n -> Int -> ℝ +getBaryCoord (BaryCoords (FreeVect bcs)) 0 = 1 - Arr.sum bcs +getBaryCoord (BaryCoords (FreeVect bcs)) i = case bcs Arr.!? i of + Just a -> a + _ -> 0 + +mkBaryCoords :: KnownNat n => ℝ ^ S n -> BaryCoords n +mkBaryCoords (FreeVect bcs) = BaryCoords $ FreeVect (Arr.tail bcs) ^/ Arr.sum bcs + +newtype ISimplex n x = ISimplex { iSimplexBCCordEmbed :: Embedding (->) (BaryCoords n) x } + + + + +data TriangBuilder n x where + TriangVerticesSt :: [x] -> TriangBuilder Z x + TriangBuilder :: Triangulation (S n) x + -> [x] + -> [(Simplex n x, [x] -> Maybe x)] + -> TriangBuilder (S n) x + + + + +bottomExtendSuitability :: (KnownNat n, WithField ℝ Manifold x) + => ISimplex (S n) x -> x -> ℝ +bottomExtendSuitability (ISimplex emb) x = case getBaryCoord (emb >-$ x) 0 of + 0 -> 0 + r -> - recip r + +optimalBottomExtension :: (KnownNat n, WithField ℝ Manifold x) + => ISimplex (S n) x -> [x] -> Maybe Int +optimalBottomExtension s xs + = case filter ((>0).snd) + $ zipWith ((. bottomExtendSuitability s) . (,)) [0..] xs of + [] -> empty + qs -> pure . fst . maximumBy (comparing snd) $ qs + + + + +iSimplexSideViews :: ∀ n x . KnownNat n => ISimplex n x -> [ISimplex n x] +iSimplexSideViews = \(ISimplex is) + -> take (n+1) $ [ISimplex $ rot j is | j<-[0..] ] + where rot j (Embedding emb proj) + = Embedding ( emb . mkBaryCoords . freeRotate j . getBaryCoords ) + ( mkBaryCoords . freeRotate (n-j) . getBaryCoords . proj ) + (Tagged n) = theNatN :: Tagged n Int + + +type FullTriang t n x = TriangT t n x + (State (Map.Map (SimplexIT t n x) (ISimplex n x))) + +type TriangBuild t n x = TriangT t (S n) x + ( State (Map.Map (SimplexIT t n x) (Metric x, ISimplex (S n) x) )) + +doTriangBuild :: KnownNat n => (∀ t . TriangBuild t n x ()) -> [Simplex (S n) x] +doTriangBuild t = runIdentity (fst <$> + doTriangT (unliftInTriangT (`evalStateT`mempty) t >> simplexITList >>= mapM lookSimplex)) + + + + + + + + +data AutoTriang n x where + AutoTriang :: { getAutoTriang :: ∀ t . TriangBuild t n x () } -> AutoTriang (S n) x + + + +breakdownAutoTriang :: ∀ n n' x . (KnownNat n', n ~ S n') => AutoTriang n x -> [Simplex n x] +breakdownAutoTriang (AutoTriang t) = doTriangBuild t + + + + + + + + +partitionsOfFstLength :: Int -> [a] -> [([a],[a])] +partitionsOfFstLength 0 l = [([],l)] +partitionsOfFstLength n [] = [] +partitionsOfFstLength n (x:xs) = ( first (x:) <$> partitionsOfFstLength (n-1) xs ) + ++ ( second (x:) <$> partitionsOfFstLength n xs ) + +splxVertices :: Simplex n x -> [x] +splxVertices (ZS x) = [x] +splxVertices (x :<| s') = x : splxVertices s' + + + + + + + +-- | +-- @ +-- 'SimpleTree' x ≅ Maybe (x, 'Trees' x) +-- @ +type SimpleTree = GenericTree Maybe [] +-- | +-- @ +-- 'Trees' x ≅ [(x, 'Trees' x)] +-- @ +type Trees = GenericTree [] [] +-- | +-- @ +-- 'NonEmptyTree' x ≅ (x, 'Trees' x) +-- @ +type NonEmptyTree = GenericTree NonEmpty [] + +newtype GenericTree c b x = GenericTree { treeBranches :: c (x,GenericTree b b x) } + deriving (Generic, Hask.Functor, Hask.Foldable, Hask.Traversable) +instance (NFData x, Hask.Foldable c, Hask.Foldable b) => NFData (GenericTree c b x) where + rnf (GenericTree t) = rnf $ toList t +instance (Hask.MonadPlus c) => Semigroup (GenericTree c b x) where + GenericTree b1 <> GenericTree b2 = GenericTree $ Hask.mplus b1 b2 +instance (Hask.MonadPlus c) => Monoid (GenericTree c b x) where + mempty = GenericTree Hask.mzero + mappend = (<>) +deriving instance Show (c (x, GenericTree b b x)) => Show (GenericTree c b x) + +-- | Imitate the specialised 'ShadeTree' structure with a simpler, generic tree. +onlyNodes :: ∀ x . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) + => ShadeTree x -> Trees x +onlyNodes (PlainLeaves []) = GenericTree [] +onlyNodes (PlainLeaves ps) = let (ctr,_) = pseudoECM ([]::[x]) $ NE.fromList ps + in GenericTree [ (ctr, GenericTree $ (,mempty) <$> ps) ] +onlyNodes (DisjointBranches _ brs) = Hask.foldMap onlyNodes brs +onlyNodes (OverlappingBranches _ (Shade ctr _) brs) + = GenericTree [ ( fromInterior ctr + , Hask.foldMap (Hask.foldMap onlyNodes) brs ) ] + + +-- | Left (and, typically, also right) inverse of 'fromLeafNodes'. +onlyLeaves :: WithField ℝ PseudoAffine x => ShadeTree x -> [x] +onlyLeaves tree = dismantle tree [] + where dismantle (PlainLeaves xs) = (xs++) + dismantle (OverlappingBranches _ _ brs) + = foldr ((.) . dismantle) id $ Hask.foldMap (Hask.toList) brs + dismantle (DisjointBranches _ brs) = foldr ((.) . dismantle) id $ NE.toList brs + + + + + + + + +data Sawbones x = Sawbones { sawnTrunk1, sawnTrunk2 :: [x]->[x] + , sawdust1, sawdust2 :: [x] } +instance Semigroup (Sawbones x) where + Sawbones st11 st12 sd11 sd12 <> Sawbones st21 st22 sd21 sd22 + = Sawbones (st11.st21) (st12.st22) (sd11<>sd21) (sd12<>sd22) +instance Monoid (Sawbones x) where + mempty = Sawbones id id [] [] + mappend = (<>) + + + +type DList x = [x]->[x] + +data DustyEdges x = DustyEdges { sawChunk :: DList x, chunkDust :: DBranches' x [x] } +instance Semigroup (DustyEdges x) where + DustyEdges c1 d1 <> DustyEdges c2 d2 = DustyEdges (c1.c2) (d1<>d2) + +data Sawboneses x = SingleCut (Sawbones x) + | Sawboneses (DBranches' x (DustyEdges x)) + deriving (Generic) +instance Semigroup (Sawboneses x) where + SingleCut c <> SingleCut d = SingleCut $ c<>d + Sawboneses c <> Sawboneses d = Sawboneses $ c<>d + + + + + + +-- | Essentially the same as @(x,y)@, but not considered as a product topology. +-- The 'Semimanifold' etc. instances just copy the topology of @x@, ignoring @y@. +data x`WithAny`y + = WithAny { _untopological :: y + , _topological :: !x } + deriving (Hask.Functor, Show, Generic) + +instance (NFData x, NFData y) => NFData (WithAny x y) + +instance ∀ x y . (Semimanifold x) => Semimanifold (x`WithAny`y) where + type Needle (WithAny x y) = Needle x + type Interior (WithAny x y) = Interior x `WithAny` y + WithAny y x .+~^ δx = WithAny y $ x.+~^δx + fromInterior (WithAny y x) = WithAny y $ fromInterior x + toInterior (WithAny y x) = fmap (WithAny y) $ toInterior x + translateP = tpWD + where tpWD :: ∀ x y . Semimanifold x => Tagged (WithAny x y) + (Interior x`WithAny`y -> Needle x -> Interior x`WithAny`y) + tpWD = Tagged `id` \(WithAny y x) δx -> WithAny y $ tpx x δx + where Tagged tpx = translateP :: Tagged x (Interior x -> Needle x -> Interior x) + semimanifoldWitness = case semimanifoldWitness :: SemimanifoldWitness x of + SemimanifoldWitness BoundarylessWitness -> SemimanifoldWitness BoundarylessWitness + +instance (PseudoAffine x) => PseudoAffine (x`WithAny`y) where + WithAny _ x .-~. WithAny _ ξ = x.-~.ξ + pseudoAffineWitness = case pseudoAffineWitness :: PseudoAffineWitness x of + PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness) + -> PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness) + +instance (AffineSpace x) => AffineSpace (x`WithAny`y) where + type Diff (WithAny x y) = Diff x + WithAny _ x .-. WithAny _ ξ = x.-.ξ + WithAny y x .+^ δx = WithAny y $ x.+^δx + +instance (VectorSpace x, Monoid y) => VectorSpace (x`WithAny`y) where + type Scalar (WithAny x y) = Scalar x + μ *^ WithAny y x = WithAny y $ μ*^x + +instance (AdditiveGroup x, Monoid y) => AdditiveGroup (x`WithAny`y) where + zeroV = WithAny mempty zeroV + negateV (WithAny y x) = WithAny y $ negateV x + WithAny y x ^+^ WithAny υ ξ = WithAny (mappend y υ) (x^+^ξ) + +instance (AdditiveGroup x) => Hask.Applicative (WithAny x) where + pure x = WithAny x zeroV + WithAny f x <*> WithAny t ξ = WithAny (f t) (x^+^ξ) + +instance (AdditiveGroup x) => Hask.Monad (WithAny x) where + return x = WithAny x zeroV + WithAny y x >>= f = WithAny r $ x^+^q + where WithAny r q = f y + +shadeWithAny :: y -> Shade x -> Shade (x`WithAny`y) +shadeWithAny y (Shade x xe) = Shade (WithAny y x) xe + +shadeWithoutAnything :: Shade (x`WithAny`y) -> Shade x +shadeWithoutAnything (Shade (WithAny _ b) e) = Shade b e + +constShaded :: y -> ShadeTree x -> x`Shaded`y +constShaded y = unsafeFmapTree (WithAny y<$>) id (shadeWithAny y) + +stripShadedUntopological :: x`Shaded`y -> ShadeTree x +stripShadedUntopological = unsafeFmapTree (fmap _topological) id shadeWithoutAnything + +fmapShaded :: (y -> υ) -> (x`Shaded`y) -> (x`Shaded`υ) +fmapShaded f = unsafeFmapTree (fmap $ \(WithAny y x) -> WithAny (f y) x) + id + (\(Shade yx shx) -> Shade (fmap f yx) shx) + +joinShaded :: (x`WithAny`y)`Shaded`z -> x`Shaded`(y,z) +joinShaded = unsafeFmapTree (fmap $ \(WithAny z (WithAny y x)) -> WithAny (y,z) x) + id + (\(Shade (WithAny z (WithAny y x)) shx) + -> Shade (WithAny (y,z) x) shx ) + +zipTreeWithList :: ShadeTree x -> [y] -> (x`Shaded`y) +zipTreeWithList tree = go tree . cycle + where go (PlainLeaves lvs) ys = PlainLeaves $ zipWith WithAny ys lvs + go (DisjointBranches n brs) ys + = DisjointBranches n . NE.fromList + $ snd (foldl (\(ys',prev) br -> + (drop (nLeaves br) ys', prev . (go br ys':)) ) + (ys,id) $ NE.toList brs) [] + go (OverlappingBranches n (Shade xoc shx) brs) ys + = OverlappingBranches n (Shade (WithAny (head ys) xoc) shx) . NE.fromList + $ snd (foldl (\(ys',prev) (DBranch dir (Hourglass top bot)) + -> case drop (nLeaves top) ys' of + ys'' -> ( drop (nLeaves bot) ys'' + , prev . (DBranch dir (Hourglass (go top ys') + (go bot ys'')):) + ) ) + (ys,id) $ NE.toList brs) [] + +-- | This is to 'ShadeTree' as 'Data.Map.Map' is to 'Data.Set.Set'. +type x`Shaded`y = ShadeTree (x`WithAny`y) + +stiWithDensity :: ∀ x y . ( WithField ℝ PseudoAffine x, WithField ℝ LinearManifold y + , SimpleSpace (Needle x) ) + => x`Shaded`y -> x -> Cℝay y +stiWithDensity (PlainLeaves lvs) + | [Shade baryc expa :: Shade x] <- pointsShades . catMaybes + $ toInterior . _topological <$> lvs + = let nlvs = fromIntegral $ length lvs :: ℝ + indiShapes = [(Shade pi expa, y) | WithAny y p <- lvs + , Just pi <- [toInterior p]] + in \x -> let lcCoeffs = [ occlusion psh x | (psh, _) <- indiShapes ] + dens = sum lcCoeffs + in mkCone dens . linearCombo . zip (snd<$>indiShapes) + $ (/dens)<$>lcCoeffs +stiWithDensity (DisjointBranches _ lvs) + = \x -> foldr1 qGather $ (`stiWithDensity`x)<$>lvs + where qGather (Cℝay 0 _) o = o + qGather o _ = o +stiWithDensity (OverlappingBranches n (Shade (WithAny _ bc) extend) brs) + = ovbSWD (dualSpaceWitness, pseudoAffineWitness) + where ovbSWD :: (DualNeedleWitness x, PseudoAffineWitness x) -> x -> Cℝay y + ovbSWD (DualSpaceWitness, PseudoAffineWitness (SemimanifoldWitness _)) x + = case toInterior x>>=(.-~.bc) of + Just v + | dist² <- normSq ε v + , dist² < 9 + , att <- exp(1/(dist²-9)+1/9) + -> qGather att $ fmap ($ x) downPrepared + _ -> coneTip + ε = dualNorm' extend :: Norm (Needle x) + downPrepared = dp =<< brs + where dp (DBranch _ (Hourglass up dn)) + = fmap stiWithDensity $ up:|[dn] + qGather att contribs = mkCone (att*dens) + $ linearCombo [(v, d/dens) | Cℝay d v <- NE.toList contribs] + where dens = sum (hParamCℝay <$> contribs) + +stiAsIntervalMapping :: (x ~ ℝ, y ~ ℝ) + => x`Shaded`y -> [(x, ((y, Diff y), LinearMap ℝ x y))] +stiAsIntervalMapping = twigsWithEnvirons >=> pure.snd.fst >=> completeTopShading >=> pure. + \(Shade' (xloc, yloc) shd) + -> ( xloc, ( (yloc, recip $ shd|$|(0,1)) + , dependence (dualNorm shd) ) ) + +smoothInterpolate :: ∀ x y . ( WithField ℝ Manifold x, WithField ℝ LinearManifold y + , SimpleSpace (Needle x) ) + => NonEmpty (x,y) -> x -> y +smoothInterpolate = si boundarylessWitness + where si :: BoundarylessWitness x -> NonEmpty (x,y) -> x -> y + si BoundarylessWitness l = \x -> + case ltr x of + Cℝay 0 _ -> defy + Cℝay _ y -> y + where defy = linearCombo [(y, 1/n) | WithAny y _ <- l'] + n = fromIntegral $ length l' + l' = (uncurry WithAny . swap) <$> NE.toList l + ltr = stiWithDensity $ fromLeafPoints l' + + +spanShading :: ∀ x y . ( WithField ℝ Manifold x, WithField ℝ Manifold y + , SimpleSpace (Needle x), SimpleSpace (Needle y) ) + => (Shade x -> Shade y) -> ShadeTree x -> x`Shaded`y +spanShading f = unsafeFmapTree addYs id addYSh + where addYs :: NonEmpty x -> NonEmpty (x`WithAny`y) + addYs l = foldr (NE.<|) (fmap (WithAny $ fromInterior ymid) l ) + (fmap (`WithAny` fromInterior xmid) yexamp) + where [xsh@(Shade xmid _)] = pointsCovers . catMaybes . toList + $ toInterior<$>l + Shade ymid yexpa = f xsh + yexamp = [ ymid .+~^ σ*^δy + | δy <- varianceSpanningSystem yexpa, σ <- [-1,1] ] + addYSh :: Shade x -> Shade (x`WithAny`y) + addYSh xsh = shadeWithAny (fromInterior . _shadeCtr $ f xsh) xsh + + + +coneTip :: (AdditiveGroup v) => Cℝay v +coneTip = Cℝay 0 zeroV + +mkCone :: AdditiveGroup v => ℝ -> v -> Cℝay v +mkCone 0 _ = coneTip +mkCone h v = Cℝay h v + + +foci :: [a] -> [(a,[a])] +foci [] = [] +foci (x:xs) = (x,xs) : fmap (second (x:)) (foci xs) + +fociNE :: NonEmpty a -> NonEmpty (a,[a]) +fociNE (x:|xs) = (x,xs) :| fmap (second (x:)) (foci xs) + + +(.:) :: (c->d) -> (a->b->c) -> a->b->d +(.:) = (.) . (.) + diff --git a/Data/Manifold/Types.hs b/Data/Manifold/Types.hs --- a/Data/Manifold/Types.hs +++ b/Data/Manifold/Types.hs @@ -68,7 +68,6 @@ import Data.Basis import Data.Fixed import Data.Tagged -import Data.Semigroup import qualified Data.Vector.Generic as Arr import qualified Data.Vector import qualified Data.Vector.Unboxed as UArr @@ -164,9 +163,11 @@ deriveAffine((FiniteFreeSpace v, UArr.Unbox (Scalar v)), Stiefel1Needle v) -instance ∀ v . (FiniteFreeSpace v, UArr.Unbox (Scalar v)) +instance ∀ v . (LSpace v, FiniteFreeSpace v, UArr.Unbox (Scalar v)) => TensorSpace (Stiefel1Needle v) where type TensorProduct (Stiefel1Needle v) w = Array w + scalarSpaceWitness = case scalarSpaceWitness :: ScalarSpaceWitness v of + ScalarSpaceWitness -> ScalarSpaceWitness zeroTensor = Tensor $ Arr.replicate (freeDimension ([]::[v]) - 1) zeroV toFlatTensor = LinearFunction $ Tensor . Arr.convert . getStiefel1Tangent fromFlatTensor = LinearFunction $ Stiefel1Needle . Arr.convert . getTensorProduct @@ -176,29 +177,39 @@ tensorProduct = bilinearFunction $ \(Stiefel1Needle n) w -> Tensor $ Arr.map (*^w) $ Arr.convert n transposeTensor = LinearFunction $ \(Tensor a) -> Arr.foldl' (^+^) zeroV - $ Arr.imap ( \i w -> (tensorProduct $ w) $ Stiefel1Needle + $ Arr.imap ( \i w -> (getLinearFunction tensorProduct w) $ Stiefel1Needle $ UArr.generate d (\j -> if i==j then 1 else 0) ) a where d = freeDimension ([]::[v]) - 1 fmapTensor = bilinearFunction $ \f (Tensor a) -> Tensor $ Arr.map (f$) a fzipTensorWith = bilinearFunction $ \f (Tensor a, Tensor b) -> Tensor $ Arr.zipWith (curry $ arr f) a b coerceFmapTensorProduct _ Coercion = Coercion + +asTensor :: Coercion (LinearMap s a b) (Tensor s (DualVector a) b) +asTensor = Coercion +asLinearMap :: Coercion (Tensor s (DualVector a) b) (LinearMap s a b) +asLinearMap = Coercion +infixr 0 +$> +(+$>) :: (LinearSpace a, TensorSpace b, Scalar a ~ s, Scalar b ~ s) + => LinearMap s a b -> a -> b +(+$>) = getLinearFunction . getLinearFunction applyLinear -instance ∀ v . (FiniteFreeSpace v, UArr.Unbox (Scalar v), Num''' (Scalar v)) +instance ∀ v . (LSpace v, FiniteFreeSpace v, UArr.Unbox (Scalar v)) => LinearSpace (Stiefel1Needle v) where type DualVector (Stiefel1Needle v) = Stiefel1Needle v linearId = LinearMap . Arr.generate d $ \i -> Stiefel1Needle . Arr.generate d $ \j -> if i==j then 1 else 0 where d = freeDimension ([]::[v]) - 1 + tensorId = ti dualSpaceWitness + where ti :: ∀ w . (LinearSpace w, Scalar w ~ Scalar v) + => DualSpaceWitness w -> (Stiefel1Needle v ⊗ w) +> (Stiefel1Needle v ⊗ w) + ti DualSpaceWitness = LinearMap . Arr.generate d + $ \i -> fmap (LinearFunction $ \w -> Tensor . Arr.generate d $ + \j -> if i==j then w else zeroV) $ asTensor $ id + d = freeDimension ([]::[v]) - 1 + dualSpaceWitness = case dualSpaceWitness :: DualSpaceWitness v of + DualSpaceWitness -> DualSpaceWitness coerceDoubleDual = Coercion - blockVectSpan = LinearFunction $ \w -> Tensor . Arr.generate d - $ \i -> LinearMap . Arr.generate d - $ \j -> if i==j then w else zeroV - where d = freeDimension ([]::[v]) - 1 - blockVectSpan'= LinearFunction $ \w -> LinearMap . Arr.generate d - $ \i -> Tensor . Arr.generate d - $ \j -> if i==j then w else zeroV - where d = freeDimension ([]::[v]) - 1 contractTensorMap = LinearFunction $ \(LinearMap m) -> Arr.ifoldl' (\acc i (Tensor t) -> acc ^+^ t Arr.! i) zeroV m contractMapTensor = LinearFunction $ \(Tensor m) @@ -210,56 +221,70 @@ -> UArr.sum $ UArr.zipWith (*) v w applyLinear = bilinearFunction $ \(LinearMap m) (Stiefel1Needle v) -> Arr.ifoldl' (\acc i w -> acc ^+^ v UArr.! i *^ w) zeroV m - composeLinear = bilinearFunction $ \f (LinearMap g) -> LinearMap $ Arr.map (f$) g + applyTensorFunctional = bilinearFunction $ \(LinearMap f) (Tensor t) + -> Arr.ifoldl' (\acc i u -> acc + u <.>^ t Arr.! i) 0 f + applyTensorLinMap = bilinearFunction $ \(LinearMap f) (Tensor t) + -> Arr.ifoldl' (\w i u -> w ^+^ ((asLinearMap $ f Arr.! i) +$> u)) zeroV t + composeLinear = bilinearFunction $ \f (LinearMap g) + -> LinearMap $ Arr.map (getLinearFunction applyLinear f$) g -instance ( WithField k LinearManifold v, FiniteFreeSpace v, FiniteFreeSpace (DualVector v) - , RealFloat k, UArr.Unbox k - ) => Semimanifold (Stiefel1 v) where +instance ∀ k v . + ( WithField k LinearManifold v, FiniteFreeSpace v, FiniteFreeSpace (DualVector v) + , RealFloat k, UArr.Unbox k ) => Semimanifold (Stiefel1 v) where type Needle (Stiefel1 v) = Stiefel1Needle v fromInterior = id toInterior = pure translateP = Tagged (.+~^) - Stiefel1 s .+~^ Stiefel1Needle n = Stiefel1 . unsafeFromFullUnboxVect . uarrScale (signum s'i) - $ if| ν==0 -> s' -- ν'≡0 is a special case of this, so we can otherwise assume ν'>0. - | ν<=2 -> let m = uarrScale ιmν spro `uarrAdd` uarrScale ((1-abs ιmν)/ν') n - ιmν = 1-ν - in insi ιmν m - | otherwise -> let m = uarrScale ιmν spro `uarrAdd` uarrScale ((abs ιmν-1)/ν') n - ιmν = ν-3 - in insi ιmν m - where d = UArr.length s' - s'= toFullUnboxVect s - ν' = l2norm n - quop = signum s'i / ν' - ν = ν' `mod'` 4 - im = UArr.maxIndex $ UArr.map abs s' - s'i = s' UArr.! im - spro = let v = deli s' in uarrScale (recip s'i) v - deli v = Arr.take im v Arr.++ Arr.drop (im+1) v - insi ti v = Arr.generate d $ \i -> if | i v Arr.! i - | i>im -> v Arr.! (i-1) - | otherwise -> ti -instance ( WithField k LinearManifold v, FiniteFreeSpace v, FiniteFreeSpace (DualVector v) - , RealFloat k, UArr.Unbox k - ) => PseudoAffine (Stiefel1 v) where - Stiefel1 s .-~. Stiefel1 t = pure . Stiefel1Needle $ case s' UArr.! im of - 0 -> uarrScale (recip $ l2norm delis) delis - s'i | v <- uarrScale (recip s'i) delis `uarrSubtract` tpro - , absv <- l2norm v - , absv > 0 - -> let μ = (signum (t'i/s'i) - recip(absv + 1)) / absv - in uarrScale μ v - | t'i/s'i > 0 -> samePoint - | otherwise -> antipode - where d = UArr.length t' - s'= toFullUnboxVect s; t' = toFullUnboxVect t - im = UArr.maxIndex $ UArr.map abs t' - t'i = t' UArr.! im - tpro = let v = deli t' in uarrScale (recip t'i) v - delis = deli s' - deli v = Arr.take im v Arr.++ Arr.drop (im+1) v - samePoint = UArr.replicate (d-1) 0 - antipode = (d-1) `UArr.fromListN` (2 : repeat 0) + (.+~^) = tpst dualSpaceWitness + where tpst :: DualSpaceWitness v -> Stiefel1 v -> Stiefel1Needle v -> Stiefel1 v + tpst DualSpaceWitness (Stiefel1 s) (Stiefel1Needle n) + = Stiefel1 . unsafeFromFullUnboxVect . uarrScale (signum s'i) + $ if| ν==0 -> s' -- ν'≡0 is a special case of this, so if not ν=0 + -- we can otherwise assume ν'>0. + | ν<=2 -> let m = uarrScale ιmν spro + `uarrAdd` uarrScale ((1-abs ιmν)/ν') n + ιmν = 1-ν + in insi ιmν m + | otherwise -> let m = uarrScale ιmν spro + `uarrAdd` uarrScale ((abs ιmν-1)/ν') n + ιmν = ν-3 + in insi ιmν m + where d = UArr.length s' + s'= toFullUnboxVect s + ν' = l2norm n + quop = signum s'i / ν' + ν = ν' `mod'` 4 + im = UArr.maxIndex $ UArr.map abs s' + s'i = s' UArr.! im + spro = let v = deli s' in uarrScale (recip s'i) v + deli v = Arr.take im v Arr.++ Arr.drop (im+1) v + insi ti v = Arr.generate d $ \i -> if | i v Arr.! i + | i>im -> v Arr.! (i-1) + | otherwise -> ti +instance ∀ k v . + ( WithField k LinearManifold v, FiniteFreeSpace v, FiniteFreeSpace (DualVector v) + , RealFloat k, UArr.Unbox k ) => PseudoAffine (Stiefel1 v) where + (.-~.) = dpst dualSpaceWitness + where dpst :: DualSpaceWitness v -> Stiefel1 v -> Stiefel1 v -> Maybe (Stiefel1Needle v) + dpst DualSpaceWitness (Stiefel1 s) (Stiefel1 t) + = pure . Stiefel1Needle $ case s' UArr.! im of + 0 -> uarrScale (recip $ l2norm delis) delis + s'i | v <- uarrScale (recip s'i) delis `uarrSubtract` tpro + , absv <- l2norm v + , absv > 0 + -> let μ = (signum (t'i/s'i) - recip(absv + 1)) / absv + in uarrScale μ v + | t'i/s'i > 0 -> samePoint + | otherwise -> antipode + where d = UArr.length t' + s'= toFullUnboxVect s; t' = toFullUnboxVect t + im = UArr.maxIndex $ UArr.map abs t' + t'i = t' UArr.! im + tpro = let v = deli t' in uarrScale (recip t'i) v + delis = deli s' + deli v = Arr.take im v Arr.++ Arr.drop (im+1) v + samePoint = UArr.replicate (d-1) 0 + antipode = (d-1) `UArr.fromListN` (2 : repeat 0) -- instance ( WithField ℝ HilbertManifold x ) => ConeSemimfd (Stiefel1 x) where @@ -288,48 +313,53 @@ -sideOfCut :: WithField ℝ Manifold x => Cutplane x -> x -> Option S⁰ -sideOfCut (Cutplane sh (Stiefel1 cn)) p = decideSide . (cn<.>^) =<< p .-~. sh +sideOfCut :: (WithField ℝ PseudoAffine x, LinearSpace (Needle x)) + => Cutplane x -> x -> Maybe S⁰ +sideOfCut (Cutplane sh (Stiefel1 cn)) p + = decideSide . (cn<.>^) =<< p.-~.sh where decideSide 0 = mzero decideSide μ | μ > 0 = pure PositiveHalfSphere | otherwise = pure NegativeHalfSphere -fathomCutDistance :: WithField ℝ Manifold x - => Cutplane x -- ^ Hyperplane to measure the distance from. - -> Metric' x -- ^ Metric to use for measuring that distance. - -- This can only be accurate if the metric - -- is valid both around the cut-plane's 'sawHandle', and - -- around the points you measure. - -- (Strictly speaking, we would need /parallel transport/ - -- to ensure this). - -> x -- ^ Point to measure the distance to. - -> Option ℝ -- ^ A signed number, giving the distance from plane - -- to point with indication on which side the point lies. - -- 'Nothing' if the point isn't reachable from the plane. -fathomCutDistance (Cutplane sh (Stiefel1 cn)) met = \x -> fmap fathom $ x .-~. sh - where fathom v = (cn <.>^ v) / scaleDist - scaleDist = met|$|cn +fathomCutDistance :: ∀ x . (WithField ℝ PseudoAffine x, LinearSpace (Needle x)) + => Cutplane x -- ^ Hyperplane to measure the distance from. + -> Metric' x -- ^ Metric to use for measuring that distance. + -- This can only be accurate if the metric + -- is valid both around the cut-plane's 'sawHandle', and + -- around the points you measure. + -- (Strictly speaking, we would need /parallel transport/ + -- to ensure this). + -> x -- ^ Point to measure the distance to. + -> Maybe ℝ -- ^ A signed number, giving the distance from plane + -- to point with indication on which side the point lies. + -- 'Nothing' if the point isn't reachable from the plane. +fathomCutDistance = fcd dualSpaceWitness + where fcd (DualSpaceWitness :: DualSpaceWitness (Needle x)) + (Cutplane sh (Stiefel1 cn)) met + = \x -> fmap fathom $ x .-~. sh + where fathom v = (cn <.>^ v) / scaleDist + scaleDist = met|$|cn -cutPosBetween :: WithField ℝ Manifold x => Cutplane x -> (x,x) -> Option D¹ +cutPosBetween :: WithField ℝ Manifold x => Cutplane x -> (x,x) -> Maybe D¹ cutPosBetween (Cutplane h (Stiefel1 cn)) (x₀,x₁) - | Option (Just [d₀,d₁]) <- map (cn<.>^) <$> sequenceA [x₀.-~.h, x₁.-~.h] - , d₀*d₁ < 0 - = pure . D¹ $ d₁ / (d₁ - d₀) - | otherwise = empty + | Just [d₀,d₁] <- map (cn<.>^) <$> sequenceA [x₀.-~.h, x₁.-~.h] + , d₀*d₁ < 0 = pure . D¹ $ 2 * d₀ / (d₀ - d₁) - 1 + | otherwise = empty -lineAsPlaneIntersection :: +lineAsPlaneIntersection :: ∀ x . (WithField ℝ Manifold x, FiniteDimensional (Needle' x)) => Line x -> [Cutplane x] -lineAsPlaneIntersection (Line h (Stiefel1 dir)) - = [ Cutplane h . Stiefel1 - $ candidate ^-^ worstCandidate ^* (overlap/worstOvlp) - | (i, (candidate, overlap)) <- zip [0..] $ zip candidates overlaps - , i /= worstId ] - where candidates = enumerateSubBasis entireBasis - overlaps = (<.>^dir) <$> candidates - (worstId, worstOvlp) = maximumBy (comparing $ abs . snd) $ zip [0..] overlaps - worstCandidate = candidates !! worstId +lineAsPlaneIntersection = lapi dualSpaceWitness + where lapi (DualSpaceWitness :: DualSpaceWitness (Needle x)) (Line h (Stiefel1 dir)) + = [ Cutplane h . Stiefel1 + $ candidate ^-^ worstCandidate ^* (overlap/worstOvlp) + | (i, (candidate, overlap)) <- zip [0..] $ zip candidates overlaps + , i /= worstId ] + where candidates = enumerateSubBasis entireBasis + overlaps = (<.>^dir) <$> candidates + (worstId, worstOvlp) = maximumBy (comparing $ abs . snd) $ zip [0..] overlaps + worstCandidate = candidates !! worstId diff --git a/Data/Manifold/Types/Primitive.hs b/Data/Manifold/Types/Primitive.hs --- a/Data/Manifold/Types/Primitive.hs +++ b/Data/Manifold/Types/Primitive.hs @@ -16,7 +16,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} --- {-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleContexts #-} @@ -48,7 +48,7 @@ , ℝay , CD¹(..), Cℝay(..) -- * Tensor products - , (⊗)(..) + , type (⊗)(..) -- * Utility (deprecated) , NaturallyEmbedded(..) , GraphWindowSpec(..), Endomorphism, (^), (^.), EqFloating @@ -56,6 +56,8 @@ ) where +import Math.Manifold.Core.Types + import Data.VectorSpace import Data.VectorSpace.Free import Linear.V2 @@ -65,11 +67,11 @@ import Data.Basis import Data.Void import Data.Monoid -import Math.LinearMap.Category ((⊗)()) +import Math.LinearMap.Category (type (⊗)()) import Control.Applicative (Const(..), Alternative(..)) -import Lens.Micro ((^.)) +import Control.Lens ((^.)) import qualified Prelude @@ -95,18 +97,7 @@ --- | The zero-dimensional sphere is actually just two points. Implementation might --- therefore change to @ℝ⁰ 'Control.Category.Constrained.+' ℝ⁰@: the disjoint sum of two --- single-point spaces. -data S⁰ = PositiveHalfSphere | NegativeHalfSphere deriving(Eq, Show) -otherHalfSphere :: S⁰ -> S⁰ -otherHalfSphere PositiveHalfSphere = NegativeHalfSphere -otherHalfSphere NegativeHalfSphere = PositiveHalfSphere - --- | The unit circle. -newtype S¹ = S¹ { φParamS¹ :: Double -- ^ Must be in range @[-π, π[@. - } deriving (Show) -- | The ordinary unit sphere. data S² = S² { ϑParamS² :: !Double -- ^ Range @[0, π[@. , φParamS² :: !Double -- ^ Range @[-π, π[@. @@ -114,9 +105,6 @@ - -type ℝP¹ = S¹ - -- | The two-dimensional real projective space, implemented as a unit disk with -- opposing points on the rim glued together. data ℝP² = ℝP² { rParamℝP² :: !Double -- ^ Range @[0, 1]@. @@ -125,15 +113,6 @@ --- | The “one-dimensional disk” – really just the line segment between --- the two points -1 and 1 of 'S⁰', i.e. this is simply a closed interval. -newtype D¹ = D¹ { xParamD¹ :: Double -- ^ Range @[-1, 1]@. - } -fromIntv0to1 :: ℝ -> D¹ -fromIntv0to1 x | x<0 = D¹ (-1) - | x>1 = D¹ 1 - | otherwise = D¹ $ (x+1)/2 - -- | The standard, closed unit disk. Homeomorphic to the cone over 'S¹', but not in the -- the obvious, “flat” way. (And not at all, despite -- the identical ADT definition, to the projective space 'ℝP²'!) @@ -149,7 +128,7 @@ -- special case @x = 'S¹'@. data CD¹ x = CD¹ { hParamCD¹ :: !Double -- ^ Range @[0, 1]@ , pParamCD¹ :: !x -- ^ Irrelevant at @h = 0@. - } + } deriving (Show) -- | An open cone is homeomorphic to a closed cone without the “lid”, @@ -158,7 +137,7 @@ -- more natural to express it as the entire real ray, hence the name. data Cℝay x = Cℝay { hParamCℝay :: !Double -- ^ Range @[0, ∞[@ , pParamCℝay :: !x -- ^ Irrelevant at @h = 0@. - } + } deriving (Show) @@ -208,8 +187,6 @@ type Endomorphism a = a->a -type ℝ = Double -type ℝ⁰ = ZeroDim ℝ type ℝ¹ = V1 ℝ type ℝ² = V2 ℝ type ℝ³ = V3 ℝ @@ -243,18 +220,6 @@ type OpenCone = Cℝay - -instance VectorSpace () where - type Scalar () = ℝ - _ *^ () = () - -instance HasBasis () where - type Basis () = Void - basisValue = absurd - decompose () = [] - decompose' () = absurd -instance InnerSpace () where - () <.> () = 0 infixr 8 ^ diff --git a/Data/Manifold/Types/Stiefel.hs b/Data/Manifold/Types/Stiefel.hs --- a/Data/Manifold/Types/Stiefel.hs +++ b/Data/Manifold/Types/Stiefel.hs @@ -25,7 +25,6 @@ import Data.Maybe import qualified Data.Vector as Arr -import Data.Semigroup import Data.VectorSpace import Data.AffineSpace diff --git a/Data/Manifold/Web.hs b/Data/Manifold/Web.hs --- a/Data/Manifold/Web.hs +++ b/Data/Manifold/Web.hs @@ -41,26 +41,32 @@ , nearestNeighbour, indexWeb, webEdges, toGraph -- ** Decomposition , sliceWeb_lin -- , sampleWebAlongLine_lin + , sampleWeb_2Dcartesian_lin, sampleEntireWeb_2Dcartesian_lin -- ** Local environments , localFocusWeb + -- * Uncertain functions + , differentiateUncertainWebFunction -- * Differential equations -- ** Fixed resolution , filterDEqnSolution_static, iterateFilterDEqn_static -- ** Automatic resolution , filterDEqnSolutions_adaptive, iterateFilterDEqn_adaptive + -- ** Configuration + , InconsistencyStrategy(..) -- * Misc - , ConvexSet(..), ellipsoid + , ConvexSet(..), ellipsoid, coerceWebDomain ) where -import Data.List hiding (filter, all, elem, sum, foldr1) +import Data.List hiding (filter, all, foldr1) import Data.Maybe import qualified Data.Set as Set import qualified Data.Vector as Arr +import qualified Data.Vector.Mutable as MArr import qualified Data.Vector.Unboxed as UArr import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE -import Data.List.FastNub (fastNubBy) +import Data.List.FastNub (fastNub,fastNubBy) import Data.Ord (comparing) import Data.Semigroup import Control.DeepSeq @@ -82,8 +88,11 @@ import qualified Prelude as Hask hiding(foldl, sum, sequence) import qualified Control.Applicative as Hask import qualified Control.Monad as Hask hiding(forM_, sequence) +import Control.Monad.ST (runST) +import Data.STRef (newSTRef, modifySTRef, readSTRef) import Control.Monad.Trans.State import Control.Monad.Trans.List +import Data.Functor.Identity (Identity(..)) import qualified Data.Foldable as Hask import Data.Foldable (all, toList) import qualified Data.Traversable as Hask @@ -98,8 +107,8 @@ import Data.Traversable.Constrained (Traversable, traverse) import Control.Comonad (Comonad(..)) -import Lens.Micro ((&), (%~), (^.), (.~)) -import Lens.Micro.TH +import Control.Lens ((&), (%~), (^.), (.~), (+~)) +import Control.Lens.TH import GHC.Generics (Generic) @@ -107,11 +116,36 @@ type WebNodeId = Int data Neighbourhood x = Neighbourhood { - neighbours :: UArr.Vector WebNodeId - , localScalarProduct :: Metric x + _neighbours :: UArr.Vector WebNodeId + , _localScalarProduct :: Metric x } deriving (Generic) +makeLenses ''Neighbourhood +deriving instance ( WithField ℝ PseudoAffine x + , SimpleSpace (Needle x), Show (Needle' x) ) + => Show (Neighbourhood x) + +data WebLocally x y = LocalWebInfo { + _thisNodeCoord :: x + , _thisNodeData :: y + , _thisNodeId :: WebNodeId + , _nodeNeighbours :: [(WebNodeId, (Needle x, WebLocally x y))] + , _nodeLocalScalarProduct :: Metric x + , _nodeIsOnBoundary :: Bool + } deriving (Generic) +makeLenses ''WebLocally + +data NeighbourhoodVector x = NeighbourhoodVector + { _nvectId :: Int + , _theNVect :: Needle x + , _nvectNormal :: Needle' x + , _nvectLength :: Scalar (Needle x) + , _otherNeighboursOverlap :: Scalar (Needle x) + } +makeLenses ''NeighbourhoodVector + + instance (NFData x, NFData (Metric x)) => NFData (Neighbourhood x) -- | A 'PointsWeb' is almost, but not quite a mesh. It is a stongly connected† @@ -144,15 +178,19 @@ fromWebNodes :: ∀ x y . (WithField ℝ Manifold x, SimpleSpace (Needle x)) => (MetricChoice x) -> [(x,y)] -> PointsWeb x y -fromWebNodes mf = fromShaded mf . fromLeafPoints . map (uncurry WithAny . swap) +fromWebNodes = case boundarylessWitness :: BoundarylessWitness x of + BoundarylessWitness -> + \mf -> fromShaded mf . fromLeafPoints . map (uncurry WithAny . swap) fromTopWebNodes :: ∀ x y . (WithField ℝ Manifold x, SimpleSpace (Needle x)) - => (MetricChoice x) -> [((x,[Needle x]),y)] -> PointsWeb x y -fromTopWebNodes mf = fromTopShaded mf . fromLeafPoints + => (MetricChoice x) -> [((x,[Int+Needle x]),y)] -> PointsWeb x y +fromTopWebNodes = case boundarylessWitness :: BoundarylessWitness x of + BoundarylessWitness -> + \mf -> fromTopShaded mf . fromLeafPoints . map (uncurry WithAny . swap . regroup') fromShadeTree_auto :: ∀ x . (WithField ℝ Manifold x, SimpleSpace (Needle x)) => ShadeTree x -> PointsWeb x () -fromShadeTree_auto = fromShaded (dualNorm . _shadeExpanse) . constShaded () +fromShadeTree_auto = fromShaded (dualNorm' . _shadeExpanse) . constShaded () fromShadeTree :: ∀ x . (WithField ℝ Manifold x, SimpleSpace (Needle x)) => (Shade x -> Metric x) -> ShadeTree x -> PointsWeb x () @@ -165,70 +203,164 @@ -- Riemannian metric). -> (x`Shaded`y) -- ^ Source tree. -> PointsWeb x y -fromShaded metricf = fromTopShaded metricf . fmapShaded ([],) +fromShaded metricf = smoothenWebTopology metricf + . fromTopShaded metricf . fmapShaded (first (map Left) . swap) + . joinShaded . seekPotentialNeighbours +toShaded :: WithField ℝ PseudoAffine x => PointsWeb x y -> (x`Shaded`y) +toShaded (PointsWeb shd asd) = zipTreeWithList shd $ Arr.toList (fst<$>asd) + fromTopShaded :: ∀ x y . (WithField ℝ Manifold x, SimpleSpace (Needle x)) => (MetricChoice x) - -> (x`Shaded`([Needle x], y)) -- ^ Source tree, with a priori topology information - -- (needles pointing to already-known neighbour candidates) + -> (x`Shaded`([Int+Needle x], y)) + -- ^ Source tree, with topology information + -- (IDs of neighbour-candidates, or needles pointing to them) -> PointsWeb x y fromTopShaded metricf shd = PointsWeb shd' assocData where shd' = stripShadedUntopological shd - assocData = Hask.foldMap locMesh $ twigsWithEnvirons shd + assocData = Hask.foldMap locMesh $ allTwigs shd - locMesh :: ( (Int, ShadeTree (x`WithAny`([Needle x], y))) - , [(Int, ShadeTree (x`WithAny`([Needle x], y)))]) + locMesh :: (Int, ShadeTree (x`WithAny`([Int+Needle x], y))) -> Arr.Vector (y, Neighbourhood x) - locMesh ((i₀, locT), neighRegions) = Arr.map findNeighbours $ Arr.fromList locLeaves - where locLeaves :: [ (Int, x`WithAny`([Needle x], y)) ] + locMesh (i₀, locT) = Arr.map findNeighbours $ Arr.fromList locLeaves + where locLeaves :: [ (Int, x`WithAny`([Int+Needle x], y)) ] locLeaves = map (first (+i₀)) . zip [0..] $ onlyLeaves locT - vicinityLeaves :: [(Int, x)] - vicinityLeaves = Hask.foldMap - (\(i₀n, ngbR) -> map ((+i₀n) *** _topological) - . zip [0..] - $ onlyLeaves ngbR - ) neighRegions - findNeighbours :: (Int, x`WithAny`([Needle x], y)) -> (y, Neighbourhood x) + findNeighbours :: (Int, x`WithAny`([Int+Needle x], y)) -> (y, Neighbourhood x) findNeighbours (i, WithAny (vns,y) x) - = (y, Neighbourhood - (UArr.fromList $ fst<$>execState seek mempty) - locRieM ) - where seek :: State [(Int, (Needle x, Needle' x))] () - seek = do - Hask.forM_ ( fastNubBy (comparing fst) - $ map (second _topological) locLeaves - ++ vicinityLeaves ++ aprioriNgbs ) - $ \(iNgb, xNgb) -> - when (iNgb/=i) `id`do - let (Option (Just v)) = xNgb.-~.x - oldNgbs <- get - when (all (\(_,(_,nw)) -> visibleOverlap nw v) oldNgbs) `id`do - let w = w₀ ^/ (w₀<.>^v) - where w₀ = locRieM<$|v - put $ (iNgb, (v,w)) - : [ neighbour - | neighbour@(_,(nv,_))<-oldNgbs - , visibleOverlap w nv - ] - aprioriNgbs :: [(Int, x)] + = (y, cullNeighbours locRieM + (i, WithAny([ (i,v) + | (i,WithAny _ xN) <- locLeaves + , Just v <- [xN.-~.x] ] + ++ aprioriNgbs) + x)) + where aprioriNgbs :: [(Int, Needle x)] aprioriNgbs = catMaybes - [ getOption $ (second $ const xN) <$> + [ (second $ const v) <$> positionIndex (pure locRieM) shd' xN - | v <- vns - , let xN = x.+~^v :: x ] - - visibleOverlap :: Needle' x -> Needle x -> Bool - visibleOverlap w v = o < 1 - where o = w<.>^v + | Right v <- vns + , let xN = xi.+~^v :: x ] + ++ [ (i,v) | Left i <- vns + , Right (_,xN) <- [indexShadeTree shd' i] + , Just v <- [xN.-~.x] ] + Just xi = toInterior x locRieM :: Metric x - locRieM = case pointsCovers . map _topological - $ onlyLeaves locT - ++ Hask.foldMap (onlyLeaves . snd) neighRegions of + locRieM = case pointsCovers . catMaybes . map (toInterior . _topological) + $ onlyLeaves locT of [sh₀] -> metricf sh₀ +cullNeighbours :: ∀ x . (WithField ℝ PseudoAffine x, SimpleSpace (Needle x)) + => Metric x -> (Int, x`WithAny`[(Int,Needle x)]) -> Neighbourhood x +cullNeighbours locRieM (i, WithAny vns x) + = Neighbourhood (UArr.fromList . sort $ _nvectId<$>execState seek mempty) + locRieM + where seek :: State [NeighbourhoodVector x] () + seek = do + Hask.forM_ ( fastNubBy (comparing fst) $ vns ) + $ \(iNgb, v) -> + when (iNgb/=i) `id`do + oldNgbs <- get + let w₀ = locRieM<$|v + l = sqrt $ w₀<.>^v + onOverlap = sum [ o^2 | nw<-oldNgbs + , let o = (nw^.nvectNormal)<.>^v + , o > 0 ] + when (l > onOverlap) `id`do + let w = w₀^/sqrt l^3 + newCandidates + = NeighbourhoodVector iNgb v w l 0 + : [ ongb & otherNeighboursOverlap .~ 0 + | ongb <- oldNgbs + , let o = w<.>^(ongb^.theNVect) + newOverlap = (if o > 0 then (o^2+) else id) + $ ongb^.otherNeighboursOverlap + , newOverlap < ongb^.nvectLength ] + put $ recalcOverlaps newCandidates + recalcOverlaps [] = [] + recalcOverlaps (ngb:ngbs) + = (ngb & otherNeighboursOverlap +~ furtherOvl) + : recalcOverlaps [ ngb' & otherNeighboursOverlap +~ max 0 o ^ 2 + | ngb' <- ngbs + , let o = (ngb^.nvectNormal)<.>^(ngb'^.theNVect) ] + where furtherOvl = sum [ o^2 | nw<-ngbs + , let o = (nw^.nvectNormal)<.>^(ngb^.theNVect) + , o > 0 ] + + +-- | Re-calculate the links in a web, so as to give each point a satisfyingly +-- “complete-spanning” environment. +smoothenWebTopology :: (WithField ℝ Manifold x, SimpleSpace (Needle x)) + => MetricChoice x -> PointsWeb x y -> PointsWeb x y +smoothenWebTopology mc = swt + where swt (PointsWeb shd net) = PointsWeb shd . go allNodes Set.empty + . fst $ makeIndexLinksSymmetric net + where allNodes = Set.fromList . Arr.toList $ fst <$> Arr.indexed net + go activeSet pastLinks asd + | all (isNothing.fst) refined + , Set.null (Set.difference symmetryTouched pastLinks) + = Arr.imap finalise asd' + | otherwise = go (Set.fromList + [ j | (Just i, (_,Neighbourhood ngbs' _)) + <-refined + , j <- i : UArr.toList ngbs' ] + `Set.union` (Set.map fst symmetryTouched)) + updtLinks + asd' + where refined = reseek<$>Set.toList activeSet + where reseek i = ( guard isNews >> pure i + , (y, Neighbourhood newNgbs locRieM) ) + where isNews = newNgbs /= oldNgbs + && or [ not $ Set.member (i,j) pastLinks + | j <- UArr.toList newNgbs ] + (y,Neighbourhood oldNgbs locRieM) = asd Arr.! i + nextNeighbours = fastNub + $ UArr.toList oldNgbs + ++ (UArr.toList._neighbours.snd.(asd Arr.!) + =<< UArr.toList oldNgbs) + x = xLookup Arr.! i + Neighbourhood newNgbs _ + = cullNeighbours locRieM + ( i, WithAny [ (j,v) + | j <- nextNeighbours + , Just v + <- [x .-~. xLookup Arr.! j] ] + x ) + (asd', symmetryTouched) = makeIndexLinksSymmetric + $ asd Arr.// [(i,n) | (Just i,n) <- refined] + updtLinks = Set.unions + [ pastLinks + , Set.fromList + [ (i,j) | (Just i,(_,Neighbourhood n _)) <- refined + , j<-UArr.toList n ] + , symmetryTouched ] + finalise i (y, Neighbourhood n em) + = (y, cullNeighbours em (i, WithAny [ (j,v) + | j<-UArr.toList n + , let xN = xLookup Arr.! j + , Just v <- [xN.-~.x] ] + x )) + where x = xLookup Arr.! i + xLookup = Arr.fromList $ onlyLeaves shd + +makeIndexLinksSymmetric + :: Arr.Vector (y, Neighbourhood x) + -> (Arr.Vector (y, Neighbourhood x), Set.Set (WebNodeId,WebNodeId)) +makeIndexLinksSymmetric orig = runST (do + result <- Arr.thaw orig + touched <- newSTRef $ Set.empty + (`Arr.imapM_`orig) $ \i (_,Neighbourhood ngbs _) -> do + UArr.forM_ ngbs $ \j -> do + (yn, Neighbourhood nngbs lsc) <- MArr.read result j + when (not $ i`UArr.elem`nngbs) `id`do + MArr.write result j (yn, Neighbourhood (UArr.snoc nngbs i) lsc) + modifySTRef touched $ Set.insert (j,i) + final <- Arr.freeze result + allTouched <- readSTRef touched + return (final, allTouched) + ) + indexWeb :: (WithField ℝ Manifold x, SimpleSpace (Needle x)) - => PointsWeb x y -> WebNodeId -> Option (x,y) + => PointsWeb x y -> WebNodeId -> Maybe (x,y) indexWeb (PointsWeb rsc assocD) i | i>=0, i Set.fromList [(min i i', max i i') | i'<-UArr.toList ngbs ] ) $ Arr.indexed assoc - lookId i | Option (Just xy) <- indexWeb web i = xy + lookId i | Just xy <- indexWeb web i = xy +coerceWebDomain :: ∀ a b y . (Manifold a, Manifold b, LocallyCoercible a b) + => PointsWeb a y -> PointsWeb b y +coerceWebDomain (PointsWeb rsc assoc) + = case oppositeLocalCoercion :: CanonicalDiffeomorphism b a of + CanonicalDiffeomorphism + -> PointsWeb ( coerceShadeTree rsc ) + ( fmap (second $ localScalarProduct + %~transformNorm (arr $ coerceNeedle ([]::[(b,a)]))) + assoc ) + + data InterpolationIv y = InterpolationIv { _interpolationSegRange :: (ℝ,ℝ) , _interpolationFunction :: ℝ -> y @@ -262,7 +405,7 @@ (xψ,xω) (\x -> let drel = fromIntv0to1 $ (x-xψ)/(xω-xψ) in yio drel ) - where Option (Just yio) = geodesicBetween yψ yω + where Just yio = geodesicBetween yψ yω mkInterpolationSeq_lin (p₀:p₁:ps) = mkInterpolationSeq_lin [p₀,p₁] <> mkInterpolationSeq_lin (p₁:ps) mkInterpolationSeq_lin _ = [] @@ -278,14 +421,11 @@ where edgs = webEdges web sliceEdgs cp = [ (xi d, yi d) -- Brute-force search through all edges | ((x₀,y₀), (x₁,y₁)) <- edgs - , Option (Just d) <- [cutPosBetween cp (x₀,x₁)] - , Option (Just xi) <- [geodesicBetween x₀ x₁] - , Option (Just yi) <- [geodesicBetween y₀ y₁] + , Just d <- [cutPosBetween cp (x₀,x₁)] + , Just xi <- [geodesicBetween x₀ x₁] + , Just yi <- [geodesicBetween y₀ y₁] ] --- sampleWebAlongLine_lin :: ∀ x y . (WithField ℝ Manifold x, Geodesic x, Geodesic y) --- => PointsWeb x y -> x -> Needle x -> [(x,y)] --- sampleWebAlongLine_lin web x₀ dir = sampleWebAlongLines_lin web x₀ [(dir, maxBound)] data GridPlanes x = GridPlanes { @@ -293,15 +433,19 @@ , _gridPlaneSpacing :: Needle x , _gridPlanesCount :: Int } +deriving instance (Show x, Show (Needle x), Show (Needle' x)) => Show (GridPlanes x) data GridSetup x = GridSetup { _gridStartCorner :: x , _gridSplitDirs :: [GridPlanes x] } +deriving instance (Show x, Show (Needle x), Show (Needle' x)) => Show (GridSetup x) cartesianGrid2D :: (x~ℝ, y~ℝ) => ((x,x), Int) -> ((y,y), Int) -> GridSetup (x,y) cartesianGrid2D ((x₀,x₁), nx) ((y₀,y₁), ny) - = GridSetup (x₀,y₀) [ GridPlanes (0,1) (0, (y₁-y₀)/fromIntegral ny) ny - , GridPlanes (1,0) ((x₁-x₀)/fromIntegral nx, 0) ny ] + = GridSetup (x₀+dx/2, y₀+dy/2) + [ GridPlanes (0,1) (0, dy) ny, GridPlanes (1,0) (dx, 0) nx ] + where dx = (x₁-x₀)/fromIntegral nx + dy = (y₁-y₀)/fromIntegral ny splitToGridLines :: ( WithField ℝ Manifold x, SimpleSpace (Needle x) , Geodesic x, Geodesic y ) @@ -309,27 +453,32 @@ splitToGridLines web (GridSetup x₀ [GridPlanes dirΩ spcΩ nΩ, linePln]) = [ ((x₀', linePln), sliceWeb_lin web $ Cutplane x₀' (Stiefel1 dirΩ)) | k <- [0 .. nΩ-1] - , let x₀' = x₀.+~^(fromIntegral k *^ spcΩ) ] + , let x₀' = x₀i.+~^(fromIntegral k *^ spcΩ) ] + where Just x₀i = toInterior x₀ sampleWebAlongGrid_lin :: ∀ x y . ( WithField ℝ Manifold x, SimpleSpace (Needle x) , Geodesic x, Geodesic y ) - => PointsWeb x y -> GridSetup x -> [(x,Option y)] -sampleWebAlongGrid_lin web grid = finalLine =<< splitToGridLines web grid - where finalLine :: ((x, GridPlanes x), [(x,y)]) -> [(x,Option y)] - finalLine ((x₀, GridPlanes _ dir nSpl), verts) + => PointsWeb x y -> GridSetup x -> [(x,Maybe y)] +sampleWebAlongGrid_lin web grid = finalLine boundarylessWitness + =<< splitToGridLines web grid + where finalLine :: BoundarylessWitness x -> ((x, GridPlanes x), [(x,y)]) -> [(x,Maybe y)] + finalLine BoundarylessWitness ((x₀, GridPlanes _ dir nSpl), verts) | length verts < 2 = take nSpl $ (,empty)<$>iterate (.+~^dir) x₀ - finalLine ((x₀, GridPlanes _ dir nSpl), verts) = take nSpl $ go (x₀,0) intpseq - where intpseq = mkInterpolationSeq_lin - [ (metr |$| x.-~!x₀, y) | (x,y) <- verts ] + finalLine BoundarylessWitness ((x₀, GridPlanes dx dir nSpl), verts) + = take nSpl $ go (x₀,0) intpseq + where intpseq = mkInterpolationSeq_lin $ sortBy (comparing fst) + [ (dx <.>^ (x.-~!x₀), y) | (x,y) <- verts ] go (x,_) [] = (,empty)<$>iterate (.+~^dir) x - go xt (InterpolationIv (_,te) f:fs) - = case break (( ((id***pure.f)<$>thisRange) ++ go xtn fs - metr = inferMetric $ webNodeRsc web + -> [ (x, if t^dir sampleWeb_2Dcartesian_lin :: (x~ℝ, y~ℝ, Geodesic z) - => PointsWeb (x,y) z -> ((x,x),Int) -> ((y,y),Int) -> [(y,[(x,Option z)])] + => PointsWeb (x,y) z -> ((x,x),Int) -> ((y,y),Int) -> [(y,[(x,Maybe z)])] sampleWeb_2Dcartesian_lin web (xspec@(_,nx)) yspec = go . sampleWebAlongGrid_lin web $ cartesianGrid2D xspec yspec where go [] = [] @@ -337,7 +486,7 @@ in (y, map (\((x,_),z) -> (x,z)) ln) : go l' sampleEntireWeb_2Dcartesian_lin :: (x~ℝ, y~ℝ, Geodesic z) - => PointsWeb (x,y) z -> Int -> Int -> [(y,[(x,Option z)])] + => PointsWeb (x,y) z -> Int -> Int -> [(y,[(x,Maybe z)])] sampleEntireWeb_2Dcartesian_lin web nx ny = sampleWeb_2Dcartesian_lin web ((x₀,x₁),nx) ((y₀,y₁),ny) where x₀ = minimum (fst<$>pts) @@ -356,11 +505,14 @@ = ( LocalWebInfo { _thisNodeCoord = x , _thisNodeData = y - , _containingWeb = result , _thisNodeId = i - , _nodeNeighbours = zip (UArr.toList $ neighbours ngbH) ngbCo - , _nodeLocalScalarProduct = localScalarProduct ngbH - , _nodeIsOnBoundary = anyUnopposed (localScalarProduct ngbH) ngbCo + , _nodeNeighbours = [ (iNgb, (δx, neighbour)) + | iNgb <- UArr.toList $ ngbH^.neighbours + , let neighbour = unsafeIndexWebData result iNgb + Just δx = _thisNodeCoord neighbour.-~.x + ] + , _nodeLocalScalarProduct = ngbH^.localScalarProduct + , _nodeIsOnBoundary = anyUnopposed (ngbH^.localScalarProduct) ngbCo }, ngbH ) anyUnopposed rieM ngbCo = (`any`ngbCo) $ \(v,_) -> not $ (`any`ngbCo) $ \(v',_) @@ -373,16 +525,16 @@ Right (_,x) -> ((x,y),n) ) asd asd''= Arr.map (\((x,y),n) -> (((x,y), [ ( case x'.-~.x of - Option (Just v) -> v + Just v -> v , y') - | j<-UArr.toList (neighbours n) + | j<-UArr.toList (n^.neighbours) , let ((x',y'),_) = asd' Arr.! j ]), n) ) asd' nearestNeighbour :: (WithField ℝ Manifold x, SimpleSpace (Needle x)) - => PointsWeb x y -> x -> Option (x,y) + => PointsWeb x y -> x -> Maybe (x,y) nearestNeighbour (PointsWeb rsc asd) x = fmap lkBest $ positionIndex empty rsc x where lkBest (iEst, (_, xEst)) = (xProx, yProx) where (iProx, (xProx, _)) = minimumBy (comparing $ snd . snd) @@ -393,38 +545,89 @@ neighbours = [ (i, (xNgb, normSq locMetr v)) | i <- UArr.toList neighbourIds , let Right (_, xNgb) = indexShadeTree rsc i - Option (Just v) = xNgb.-~.x + Just v = xNgb.-~.x ] - Option (Just vEst) = xEst.-~.x + Just vEst = xEst.-~.x -data WebLocally x y = LocalWebInfo { - _thisNodeCoord :: x - , _thisNodeData :: y - , _containingWeb :: PointsWeb x (WebLocally x y) - , _thisNodeId :: WebNodeId - , _nodeNeighbours :: [(WebNodeId, (Needle x, y))] - , _nodeLocalScalarProduct :: Metric x - , _nodeIsOnBoundary :: Bool - } deriving (Generic) -makeLenses ''WebLocally - instance Hask.Functor (WebLocally x) where - fmap f (LocalWebInfo co dt wb id ng sp bn) - = LocalWebInfo co (f dt) (fmap (fmap f) wb) id (map (second $ second f) ng) sp bn + fmap f (LocalWebInfo co dt id ng sp bn) + = LocalWebInfo co (f dt) id (map (second . second $ fmap f) ng) sp bn instance WithField ℝ Manifold x => Comonad (WebLocally x) where extract = _thisNodeData - duplicate lweb = unsafeIndexWebData deepened $ _thisNodeId lweb - where deepened = webLocalInfo $ _containingWeb lweb + extend f this@(LocalWebInfo co _ id ng sp bn) + = LocalWebInfo co (f this) id (map (second . second $ extend f) ng) sp bn + duplicate this@(LocalWebInfo co _ id ng sp bn) + = LocalWebInfo co this id (map (second $ second duplicate) ng) sp bn +-- ^ 'fmap' from the co-Kleisli category of 'WebLocally'. +localFmapWeb :: WithField ℝ Manifold x + => (WebLocally x y -> z) -> PointsWeb x y -> PointsWeb x z +localFmapWeb f = webLocalInfo >>> fmap f +traverseWebWithStrategy :: ( WithField ℝ Manifold x, Hask.Applicative m ) + => InconsistencyStrategy m x y -> (WebLocally x y -> Maybe y) + -> PointsWeb x y -> m (PointsWeb x y) +traverseWebWithStrategy strat f = webLocalInfo + >>> traverse (\info -> handleInconsistency strat + (info^.thisNodeData) (f info)) +differentiateUncertainWebLocally :: ∀ x y + . ( WithField ℝ Manifold x, SimpleSpace (Needle x) + , WithField ℝ Refinable y, SimpleSpace (Needle y) ) + => WebLocally x (Shade' y) + -> Shade' (LocalLinear x y) +differentiateUncertainWebLocally info + = case estimateLocalJacobian + (info^.nodeLocalScalarProduct) + [ ( Local δx :: Local x, ngb^.thisNodeData ) + | (δx,ngb) <- (zeroV, info) + : (snd<$>info^.nodeNeighbours) + ] of + Just j -> j + _ -> Shade' zeroV mempty +differentiateUncertainWebFunction :: ∀ x y + . ( WithField ℝ Manifold x, SimpleSpace (Needle x) + , WithField ℝ Manifold y, SimpleSpace (Needle y), Refinable y ) + => PointsWeb x (Shade' y) + -> PointsWeb x (Shade' (LocalLinear x y)) +differentiateUncertainWebFunction = localFmapWeb differentiateUncertainWebLocally +rescanPDELocally :: ∀ x y . + ( WithField ℝ Manifold x, SimpleSpace (Needle x) + , WithField ℝ Refinable y, SimpleSpace (Needle y) ) + => DifferentialEqn x y -> WebLocally x (Shade' y) + -> Maybe (Shade' y) +rescanPDELocally = case ( dualSpaceWitness :: DualNeedleWitness x + , dualSpaceWitness :: DualNeedleWitness y + , boundarylessWitness :: BoundarylessWitness x + , pseudoAffineWitness :: PseudoAffineWitness y ) of + ( DualSpaceWitness,DualSpaceWitness,BoundarylessWitness + , PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness) ) + -> \f info -> let xc = info^.thisNodeCoord + yc = info^.thisNodeData.shadeCtr + in case f $ coverAllAround (xc, yc) + [ (δx, (ngb^.thisNodeData.shadeCtr.-~!yc) ^+^ v) + | (_,(δx,ngb))<-info^.nodeNeighbours + , v <- normSpanningSystem' + (ngb^.thisNodeData.shadeNarrowness)] of + LocalDifferentialEqn _ rescan + -> rescan (differentiateUncertainWebLocally info) + (info^.thisNodeData) + +rescanPDEOnWeb :: ( WithField ℝ Manifold x, SimpleSpace (Needle x) + , WithField ℝ Refinable y, SimpleSpace (Needle y) + , Hask.Applicative m ) + => InconsistencyStrategy m x (Shade' y) + -> DifferentialEqn x y -> PointsWeb x (Shade' y) + -> m (PointsWeb x (Shade' y)) +rescanPDEOnWeb strat = traverseWebWithStrategy strat . rescanPDELocally + toGraph :: (WithField ℝ Manifold x, SimpleSpace (Needle x)) => PointsWeb x y -> (Graph, Vertex -> (x, y)) -toGraph wb = second (>>> \(i,_,_) -> case indexWeb wb i of {Option (Just xy) -> xy}) +toGraph wb = second (>>> \(i,_,_) -> case indexWeb wb i of {Just xy -> xy}) (graphFromEdges' edgs) where edgs :: [(Int, Int, [Int])] edgs = Arr.toList @@ -441,11 +644,13 @@ -- ^ If @p@ is in all intersectors, it must also be in the hull. , convexSetIntersectors :: [Shade' x] } +deriving instance ( WithField ℝ Manifold x, SimpleSpace (Needle x) + , Show (Interior x), Show (Needle' x) ) => Show (ConvexSet x) ellipsoid :: Shade' x -> ConvexSet x ellipsoid s = ConvexSet s [s] -intersectors :: ConvexSet x -> Option (NonEmpty (Shade' x)) +intersectors :: ConvexSet x -> Maybe (NonEmpty (Shade' x)) intersectors (ConvexSet h []) = pure (h:|[]) intersectors (ConvexSet _ (i:sts)) = pure (i:|sts) intersectors _ = empty @@ -454,9 +659,9 @@ instance Refinable x => Semigroup (ConvexSet x) where a<>b = sconcat (a:|[b]) sconcat csets - | Option (Just allIntersectors) <- sconcat <$> Hask.traverse intersectors csets + | Just allIntersectors <- sconcat <$> Hask.traverse intersectors csets , IntersectT ists <- rmTautologyIntersect perfectRefine $ IntersectT allIntersectors - , Option (Just hull') <- intersectShade's ists + , Just hull' <- intersectShade's ists = ConvexSet hull' (NE.toList ists) | otherwise = EmptyConvex where perfectRefine sh₁ sh₂ @@ -466,201 +671,325 @@ -itWhileJust :: (a -> Option a) -> a -> [a] -itWhileJust f x | Option (Just y) <- f x = x : itWhileJust f y -itWhileJust _ x = [x] +itWhileJust :: InconsistencyStrategy m x y -> (a -> m a) -> a -> [a] +itWhileJust AbortOnInconsistency f x + | Just y <- f x = x : itWhileJust AbortOnInconsistency f y +itWhileJust IgnoreInconsistencies f x + | Identity y <- f x = x : itWhileJust IgnoreInconsistencies f y +itWhileJust (HighlightInconsistencies yh) f x + | Identity y <- f x = x : itWhileJust (HighlightInconsistencies yh) f y +itWhileJust _ _ x = [x] dupHead :: NonEmpty a -> NonEmpty a dupHead (x:|xs) = x:|x:xs + +data InconsistencyStrategy m x y where + AbortOnInconsistency :: InconsistencyStrategy Maybe x y + IgnoreInconsistencies :: InconsistencyStrategy Identity x y + HighlightInconsistencies :: y -> InconsistencyStrategy Identity x y +deriving instance Hask.Functor (InconsistencyStrategy m x) + + iterateFilterDEqn_static :: ( WithField ℝ Manifold x, SimpleSpace (Needle x) - , Refinable y ) - => DifferentialEqn x y -> PointsWeb x (Shade' y) -> [PointsWeb x (Shade' y)] -iterateFilterDEqn_static f = map (fmap convexSetHull) - . itWhileJust (filterDEqnSolutions_static f) + , Refinable y, Geodesic (Interior y) + , Hask.Applicative m ) + => InconsistencyStrategy m x (Shade' y) -> DifferentialEqn x y + -> PointsWeb x (Shade' y) -> [PointsWeb x (Shade' y)] +iterateFilterDEqn_static strategy f + = map (fmap convexSetHull) + . itWhileJust strategy + (filterDEqnSolutions_static (ellipsoid<$>strategy) f) . fmap (`ConvexSet`[]) -filterDEqnSolution_static :: ( WithField ℝ Manifold x, SimpleSpace (Needle x) - , Refinable y ) - => DifferentialEqn x y -> PointsWeb x (Shade' y) -> Option (PointsWeb x (Shade' y)) -filterDEqnSolution_static f = localFocusWeb >>> Hask.traverse `id` - \((x,shy), ngbs) -> if null ngbs - then pure shy - else refineShade' shy +filterDEqnSolution_static :: ∀ x y m . ( WithField ℝ Manifold x, SimpleSpace (Needle x) + , Refinable y, Geodesic (Interior y) ) + => InconsistencyStrategy m x (Shade' y) -> DifferentialEqn x y + -> PointsWeb x (Shade' y) -> m (PointsWeb x (Shade' y)) +filterDEqnSolution_static strat@AbortOnInconsistency f + = case boundarylessWitness :: BoundarylessWitness x of + BoundarylessWitness -> + rescanPDEOnWeb strat f >=> webLocalInfo + >>> Hask.traverse `id`\me -> case me^.nodeNeighbours of + [] -> return $ me^.thisNodeData + ngbs -> refineShade' (me^.thisNodeData) =<< intersectShade's - ( propagateDEqnSolution_loc f ((x,shy), NE.fromList ngbs) ) + =<< ( sequenceA $ NE.fromList + [ propagateDEqnSolution_loc + f (LocalDataPropPlan + (ngbInfo^.thisNodeCoord) + (negateV δx) + (ngbInfo^.thisNodeData) + (me^.thisNodeData) + (fmap (second _thisNodeData . snd) + $ ngbInfo^.nodeNeighbours) + ) + | (_, (δx, ngbInfo)) <- ngbs + ] ) -filterDEqnSolutions_static :: ( WithField ℝ Manifold x, SimpleSpace (Needle x) - , Refinable y ) - => DifferentialEqn x y -> PointsWeb x (ConvexSet y) -> Option (PointsWeb x (ConvexSet y)) -filterDEqnSolutions_static f = localFocusWeb >>> Hask.traverse `id` - \((x, shy@(ConvexSet hull _)), ngbs) -> if null ngbs - then pure shy - else ((shy<>) . ellipsoid) - <$> intersectShade's - ( propagateDEqnSolution_loc f - ((x,hull), second convexSetHull<$>NE.fromList ngbs) ) - >>= \case EmptyConvex -> empty - c -> pure c +filterDEqnSolutions_static :: ∀ x y m . + ( WithField ℝ Manifold x, SimpleSpace (Needle x) + , Refinable y, Geodesic (Interior y) + , Hask.Applicative m ) + => InconsistencyStrategy m x (ConvexSet y) -> DifferentialEqn x y + -> PointsWeb x (ConvexSet y) -> m (PointsWeb x (ConvexSet y)) +filterDEqnSolutions_static strategy f + = webLocalInfo + >>> fmap (id &&& rescanPDELocally f . fmap convexSetHull) + >>> localFocusWeb >>> Hask.traverse `id`\((_,(me,updShy)), ngbs) + -> let oldValue = me^.thisNodeData :: ConvexSet y + in case updShy of + Just shy -> case ngbs of + [] -> pure oldValue + _:_ | BoundarylessWitness <- (boundarylessWitness::BoundarylessWitness x) + -> handleInconsistency strategy oldValue + $ ( sequenceA $ NE.fromList + [ sj >>= \ngbShy -> + propagateDEqnSolution_loc + f (LocalDataPropPlan + (ngbInfo^.thisNodeCoord) + (negateV δx) + ngbShy + shy + (fmap (second (convexSetHull . _thisNodeData) + . snd) $ ngbInfo^.nodeNeighbours) + ) + | (δx, (ngbInfo,sj)) <- ngbs + ] ) + >>= intersectShade's + >>= pure . ((oldValue<>) . ellipsoid) + >>= \case EmptyConvex -> empty + c -> pure c + _ -> handleInconsistency strategy oldValue empty +handleInconsistency :: InconsistencyStrategy m x a -> a -> Maybe a -> m a +handleInconsistency AbortOnInconsistency _ i = i +handleInconsistency IgnoreInconsistencies _ (Just v) = Identity v +handleInconsistency IgnoreInconsistencies b _ = Identity b +handleInconsistency (HighlightInconsistencies _) _ (Just v) = Identity v +handleInconsistency (HighlightInconsistencies b) _ _ = Identity b -data SolverNodeState y = SolverNodeInfo { +data SolverNodeState x y = SolverNodeInfo { _solverNodeStatus :: ConvexSet y + , _solverNodeJacobian :: Shade' (LocalLinear x y) , _solverNodeBadness :: ℝ , _solverNodeAge :: Int } makeLenses ''SolverNodeState -type OldAndNew d = (Option d, [d]) +type OldAndNew d = (Maybe d, [d]) oldAndNew :: OldAndNew d -> [d] -oldAndNew (Option (Just x), l) = x : l +oldAndNew (Just x, l) = x : l oldAndNew (_, l) = l oldAndNew' :: OldAndNew d -> [(Bool, d)] -oldAndNew' (Option (Just x), l) = (True, x) : fmap (False,) l +oldAndNew' (Just x, l) = (True, x) : fmap (False,) l oldAndNew' (_, l) = (False,) <$> l -filterDEqnSolutions_adaptive :: ∀ x y badness - . (WithField ℝ Manifold x, SimpleSpace (Needle x), Refinable y, badness ~ ℝ) +filterDEqnSolutions_adaptive :: ∀ x y badness m + . ( WithField ℝ Manifold x, SimpleSpace (Needle x) + , WithField ℝ AffineManifold y, Refinable y, Geodesic y + , badness ~ ℝ, Hask.Monad m ) => MetricChoice x -- ^ Scalar product on the domain, for regularising the web. + -> InconsistencyStrategy m x (Shade' y) -> DifferentialEqn x y -> (x -> Shade' y -> badness) - -> PointsWeb x (SolverNodeState y) - -> Option (PointsWeb x (SolverNodeState y)) -filterDEqnSolutions_adaptive mf f badness' oldState - = fmap (fromTopWebNodes mf . concat . fmap retraceBonds - . Hask.toList . webLocalInfo . webLocalInfo) - $ Hask.traverse (uncurry localChange) preproc'd - where preproc'd :: PointsWeb x ((WebLocally x (SolverNodeState y), [(Shade' y, badness)])) - preproc'd = fmap addPropagation $ webLocalInfo oldState + -> PointsWeb x (SolverNodeState x y) + -> m (PointsWeb x (SolverNodeState x y)) +filterDEqnSolutions_adaptive mf strategy f badness' oldState + = fmap recomputeJacobian $ filterGo boundarylessWitness + =<< tryPreproc boundarylessWitness + where tryPreproc :: BoundarylessWitness x + -> m (PointsWeb x ( (WebLocally x (SolverNodeState x y) + , [(Shade' y, badness)]) )) + tryPreproc BoundarylessWitness = traverse addPropagation $ webLocalInfo oldState where addPropagation wl - | null neighbourHulls = (wl, []) - | otherwise = (wl, map (id&&&badness undefined) propFromNgbs) - where propFromNgbs = NE.toList $ propagateDEqnSolution_loc f - ( (thisPos, thisShy), NE.fromList neighbourHulls ) + | null neighbourInfo = pure (wl, []) + | otherwise = (wl,) . map (id&&&badness undefined) + <$> propFromNgbs + where propFromNgbs :: m [Shade' y] + propFromNgbs = mapM (handleInconsistency strategy thisShy) [ + propagateDEqnSolution_loc f + (LocalDataPropPlan + (neigh^.thisNodeCoord) + (negateV δx) + (convexSetHull $ neigh^.thisNodeData + .solverNodeStatus) + (thisShy) + [ second (convexSetHull + . _solverNodeStatus . _thisNodeData) nn + | (_,nn)<-neigh^.nodeNeighbours ] ) + | (δx, neigh) <- neighbourInfo ] -- ( (thisPos, thisShy), NE.fromList neighbourHulls ) thisPos = _thisNodeCoord wl :: x thisShy = convexSetHull . _solverNodeStatus $ _thisNodeData wl - neighbourHulls = second (convexSetHull . _solverNodeStatus) . snd - <$> _nodeNeighbours wl - smallBadnessGradient, largeBadnessGradient :: ℝ - (smallBadnessGradient, largeBadnessGradient) - = ( badnessGradRated!!(n`div`4), badnessGradRated!!(n*3`div`4) ) - where n = case length badnessGradRated of - 0 -> error "No neighbours available for badness-grading." - l -> l - badnessGradRated = sort [ ngBad / bad - | ( LocalWebInfo { - _thisNodeData - = SolverNodeInfo _ bad _ - , _nodeNeighbours=ngbs } - , ngbProps) <- Hask.toList preproc'd - , (_, ngBad) <- ngbProps - , ngBad>bad ] - localChange :: WebLocally x (SolverNodeState y) -> [(Shade' y, badness)] - -> Option (OldAndNew (x, SolverNodeState y)) - localChange localInfo@LocalWebInfo{ - _thisNodeCoord = x - , _thisNodeData = SolverNodeInfo - shy@(ConvexSet hull _) prevBadness age - , _nodeNeighbours = ngbs - } - ngbProps - | null ngbs = return (pure (x, SolverNodeInfo shy prevBadness (age+1)), []) - | otherwise = do - let neighbourHulls = second (convexSetHull . _solverNodeStatus) . snd - <$> NE.fromList ngbs - (environAge, unfreshness) - = maximum&&&minimum $ age : (_solverNodeAge . snd . snd <$> ngbs) - case find (\(_, badnessN) - -> badnessN / prevBadness > smallBadnessGradient) - $ ngbProps of - Nothing | age < environAge -- point is an obsolete step-stone; - -> return (empty,empty) -- do not further use it. - _otherwise -> do - shy' <- ((shy<>) . ellipsoid) - <$> intersectShade's (fst <$> NE.fromList ngbProps) - newBadness <- case shy' of - EmptyConvex -> empty - ConvexSet hull' _ -> return $ badness x hull' - let updatedNode = SolverNodeInfo shy' newBadness (age+1) - stepStones <- - if unfreshness < 3 - then return [] - else fmap concat . forM (zip (snd<$>ngbs) ngbProps) - $ \( (vN, SolverNodeInfo (ConvexSet hullN _) - _ ageN) - , (_, nBadnessProp'd) ) -> do - case ageN of - _ | ageN > 0 - , badnessGrad <- nBadnessProp'd / prevBadness - , badnessGrad > largeBadnessGradient -> do - let stepV = vN^/2 - xStep = x .+~^ stepV - shyStep <- intersectShade's $ - propagateDEqnSolution_loc f - ( (xStep, hull) - , NE.cons (negateV stepV, hull) - $ fmap (\(vN',hullN') - -> (vN'^-^stepV, hullN') ) - neighbourHulls ) - return [( xStep - , SolverNodeInfo (ellipsoid shyStep) - (badness xStep shyStep) 1 - )] - _otherwise -> return [] - let updated = (x, updatedNode) - return $ (pure updated, stepStones) - - totalAge = maximum $ _solverNodeAge . _thisNodeData . fst <$> preproc'd + neighbourInfo = snd <$> _nodeNeighbours wl + + totalAge = maximum $ _solverNodeAge <$> oldState errTgtModulation = (1-) . (`mod'`1) . negate . sqrt $ fromIntegral totalAge badness x = badness' x . (shadeNarrowness %~ (scaleNorm errTgtModulation)) - - retraceBonds :: WebLocally x (WebLocally x (OldAndNew (x, SolverNodeState y))) - -> [((x, [Needle x]), SolverNodeState y)] - retraceBonds locWeb@LocalWebInfo{ _thisNodeId = myId - , _thisNodeCoord = xOld - , _nodeLocalScalarProduct = locMetr } - = [ ( (x, fst<$>neighbourCandidates), snsy) - | (isOld, (x, snsy)) <- focused - , let neighbourCandidates - = [ (v,nnId) - | (_,ngb) <- knownNgbs - , (Option (Just v), nnId) - <- case oldAndNew $ ngb^.thisNodeData of - [] -> [ (xN.-~.x, nnId) - | (nnId, (_,nnWeb)) <- ngb^.nodeNeighbours - , nnId /= myId - , (xN,_) <- oldAndNew nnWeb ] - l -> [(xN.-~.x, ngb^.thisNodeId) | (xN,_) <- l] - ] - possibleConflicts = [ normSq locMetr v - | (v,nnId)<-neighbourCandidates - , nnId > myId ] - , isOld || null possibleConflicts - || minimum possibleConflicts > oldMinDistSq / 4 - ] - where focused = oldAndNew' $ locWeb^.thisNodeData^.thisNodeData - knownNgbs = snd <$> locWeb^.nodeNeighbours - oldMinDistSq = minimum [ normSq locMetr vOld - | (_,ngb) <- knownNgbs - , let Option (Just vOld) = ngb^.thisNodeCoord .-~. xOld - ] + + filterGo :: BoundarylessWitness x + -> (PointsWeb x ( (WebLocally x (SolverNodeState x y) + , [(Shade' y, badness)]) )) + -> m (PointsWeb x (SolverNodeState x y)) + filterGo BoundarylessWitness preproc'd = fmap (smoothenWebTopology mf + . fromTopWebNodes mf . concat . fmap retraceBonds + . Hask.toList . webLocalInfo . webLocalInfo) + $ Hask.traverse (uncurry localChange) preproc'd + where smallBadnessGradient, largeBadnessGradient :: ℝ + (smallBadnessGradient, largeBadnessGradient) + = ( badnessGradRated!!(n`div`4), badnessGradRated!!(n*3`div`4) ) + where n = case length badnessGradRated of + 0 -> error "No statistics available for badness-grading." + l -> l + badnessGradRated :: [badness] + badnessGradRated = sort [ ngBad / bad + | ( LocalWebInfo { + _thisNodeData + = SolverNodeInfo _ _ bad _ + , _nodeNeighbours=ngbs } + , ngbProps) <- Hask.toList preproc'd + , (_, ngBad) <- ngbProps + , ngBad>bad ] + localChange :: WebLocally x (SolverNodeState x y) -> [(Shade' y, badness)] + -> m (OldAndNew (x, SolverNodeState x y)) + localChange localInfo@LocalWebInfo{ + _thisNodeCoord = x + , _thisNodeData = SolverNodeInfo + shy@(ConvexSet hull _) prevJacobi + prevBadness age + , _nodeNeighbours = ngbs + } + ngbProps + | null ngbs = return ( pure (x, SolverNodeInfo shy prevJacobi + prevBadness (age+1)) + , [] ) + | otherwise = do + let (environAge, unfreshness) + = maximum&&&minimum $ age : (_solverNodeAge . _thisNodeData + . snd . snd <$> ngbs) + case find (\(_, badnessN) + -> badnessN / prevBadness > smallBadnessGradient) + $ ngbProps of + Nothing | age < environAge -- point is an obsolete step-stone; + -> return (empty,empty) -- do not further use it. + _otherwise -> do + shy' <- handleInconsistency (ellipsoid<$>strategy) shy + $ ((shy<>) . ellipsoid) + <$> intersectShade's (fst <$> NE.fromList ngbProps) + newBadness + <- handleInconsistency (badness x<$>strategy) prevBadness + $ case shy' of + EmptyConvex -> empty + ConvexSet hull' _ -> return $ badness x hull' + let updatedNode = SolverNodeInfo shy' prevJacobi + newBadness (age+1) + stepStones <- + if unfreshness < 3 + then return [] + else fmap concat . forM (zip (second _thisNodeData.snd<$>ngbs) + ngbProps) + $ \( (vN, SolverNodeInfo (ConvexSet hullN _) + _ _ ageN) + , (_, nBadnessProp'd) ) -> do + case ageN of + _ | ageN > 0 + , badnessGrad <- nBadnessProp'd / prevBadness + , badnessGrad > largeBadnessGradient -> do + let stepV = vN^/2 + xStep = x .+~^ stepV + aprioriInterpolate :: Shade' y + Just aprioriInterpolate + = middleBetween hull hullN + case intersectShade's =<< + (sequenceA $ NE.fromList + [ propagateDEqnSolution_loc f + (LocalDataPropPlan + (n^.thisNodeCoord) + (stepV ^-^ δx) + (convexSetHull $ + n^.thisNodeData.solverNodeStatus) + (aprioriInterpolate) + (second (convexSetHull + ._solverNodeStatus + ._thisNodeData) + . snd + <$> n^.nodeNeighbours) ) + -- ( (xStep, hull) + -- , NE.cons (negateV stepV, hull) + -- $ fmap (\(vN',hullN') + -- -> (vN'^-^stepV, hullN') ) ) + | (_, (δx, n)) <- ngbs ]) of + Just shyStep -> return + [( xStep + , SolverNodeInfo (ellipsoid shyStep) + prevJacobi (badness xStep shyStep) 1 + )] + _ -> return [] + _otherwise -> return [] + let updated = (x, updatedNode) + return $ (pure updated, stepStones) + + retraceBonds :: WebLocally x (WebLocally x (OldAndNew (x, SolverNodeState x y))) + -> [((x, [Int+Needle x]), SolverNodeState x y)] + retraceBonds locWeb@LocalWebInfo{ _thisNodeId = myId + , _thisNodeCoord = xOld + , _nodeLocalScalarProduct = locMetr } + = [ ( (x, Right . fst<$>neighbourCandidates), snsy) + | (isOld, (x, snsy)) <- focused + , let neighbourCandidates + = [ (v,nnId) + | (_,ngb) <- knownNgbs + , (Just v, nnId) + <- case oldAndNew $ ngb^.thisNodeData of + [] -> [ (xN.-~.x, nnId) + | (nnId, (_,nnWeb)) <- ngb^.nodeNeighbours + , nnId /= myId + , (xN,_) <- oldAndNew $ nnWeb^.thisNodeData ] + l -> [(xN.-~.x, ngb^.thisNodeId) | (xN,_) <- l] + ] + possibleConflicts = [ normSq locMetr v + | (v,nnId)<-neighbourCandidates + , nnId > myId ] + , isOld || null possibleConflicts + || minimum possibleConflicts > oldMinDistSq / 4 + ] + where focused = oldAndNew' $ locWeb^.thisNodeData^.thisNodeData + knownNgbs = second _thisNodeData . snd <$> locWeb^.nodeNeighbours + oldMinDistSq = minimum [ normSq locMetr vOld + | (_,ngb) <- knownNgbs + , let Just vOld = ngb^.thisNodeCoord .-~. xOld + ] +recomputeJacobian :: ( WithField ℝ Manifold x, SimpleSpace (Needle x) + , WithField ℝ Manifold y, SimpleSpace (Needle y), Refinable y ) + => PointsWeb x (SolverNodeState x y) + -> PointsWeb x (SolverNodeState x y) +recomputeJacobian = webLocalInfo + >>> fmap ((_thisNodeData + &&& differentiateUncertainWebLocally + . fmap (convexSetHull . _solverNodeStatus)) + >>> \(nst, shj) -> nst & solverNodeJacobian .~ shj ) -iterateFilterDEqn_adaptive :: (WithField ℝ Manifold x, SimpleSpace (Needle x), Refinable y) +iterateFilterDEqn_adaptive + :: ( WithField ℝ Manifold x, SimpleSpace (Needle x) + , WithField ℝ AffineManifold y, Refinable y, Geodesic y, Hask.Monad m ) => MetricChoice x -- ^ Scalar product on the domain, for regularising the web. + -> InconsistencyStrategy m x (Shade' y) -> DifferentialEqn x y -> (x -> Shade' y -> ℝ) -- ^ Badness function for local results. -> PointsWeb x (Shade' y) -> [PointsWeb x (Shade' y)] -iterateFilterDEqn_adaptive mf f badness +iterateFilterDEqn_adaptive mf strategy f badness = map (fmap (convexSetHull . _solverNodeStatus)) - . itWhileJust (filterDEqnSolutions_adaptive mf f badness) + . itWhileJust strategy (filterDEqnSolutions_adaptive mf strategy f badness) + . recomputeJacobian . fmap (\((x,shy),_) -> SolverNodeInfo (ellipsoid shy) + (Shade' zeroV mempty) (badness x shy) 1 ) diff --git a/Data/SetLike/Intersection.hs b/Data/SetLike/Intersection.hs --- a/Data/SetLike/Intersection.hs +++ b/Data/SetLike/Intersection.hs @@ -12,7 +12,6 @@ module Data.SetLike.Intersection where -import Data.Semigroup import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty(..)) @@ -24,14 +23,14 @@ singleIntersect = IntersectT . pure rmTautologyIntersect :: - (s x -> s x -> Option (s x)) -- ^ Subset-finder + (s x -> s x -> Maybe (s x)) -- ^ Subset-finder -> IntersectT s x -> IntersectT s x rmTautologyIntersect smaller (IntersectT isoa) = IntersectT $ rti isoa where rti (s₀:|ss) = reduce [] ss where reduce [] [] = s₀:|[] reduce (sp₀:sp) [] = NE.cons s₀ $ rti (sp₀:|sp) reduce sp (s₁:sr) = case smaller s₀ s₁ of - Option (Just si) -> rti $ si :| (sp ++ sr) - Option Nothing -> reduce (s₁:sp) sr + Just si -> rti $ si :| (sp ++ sr) + Nothing -> reduce (s₁:sp) sr diff --git a/images/examples/ShadeCombinations/2Dconvolution-skewed.png b/images/examples/ShadeCombinations/2Dconvolution-skewed.png Binary files a/images/examples/ShadeCombinations/2Dconvolution-skewed.png and b/images/examples/ShadeCombinations/2Dconvolution-skewed.png differ diff --git a/images/examples/TreesAndWebs/2D-cartesian-strangeaspect.png b/images/examples/TreesAndWebs/2D-cartesian-strangeaspect.png new file mode 100644 Binary files /dev/null and b/images/examples/TreesAndWebs/2D-cartesian-strangeaspect.png differ diff --git a/images/examples/TreesAndWebs/2D-cartesiandisk.png b/images/examples/TreesAndWebs/2D-cartesiandisk.png Binary files a/images/examples/TreesAndWebs/2D-cartesiandisk.png and b/images/examples/TreesAndWebs/2D-cartesiandisk.png differ diff --git a/images/examples/TreesAndWebs/2D-normaldistrib.png b/images/examples/TreesAndWebs/2D-normaldistrib.png Binary files a/images/examples/TreesAndWebs/2D-normaldistrib.png and b/images/examples/TreesAndWebs/2D-normaldistrib.png differ diff --git a/images/examples/TreesAndWebs/2D-scatter.png b/images/examples/TreesAndWebs/2D-scatter.png Binary files a/images/examples/TreesAndWebs/2D-scatter.png and b/images/examples/TreesAndWebs/2D-scatter.png differ diff --git a/manifolds.cabal b/manifolds.cabal --- a/manifolds.cabal +++ b/manifolds.cabal @@ -1,5 +1,5 @@ Name: manifolds -Version: 0.3.0.0 +Version: 0.4.0.0 Category: Math Synopsis: Coordinate-free hypersurfaces Description: Manifolds, a generalisation of the notion of “smooth curves” or surfaces, @@ -40,21 +40,21 @@ Library Build-Depends: base>=4.5 && < 6 + , manifolds-core == 0.4.0.0 , transformers , vector-space>=0.8 , free-vector-spaces>=0.1.1 , linear , MemoTrie , vector - , linearmap-category > 0.1 && < 0.2 + , linearmap-category > 0.3 && < 0.4 , containers , comonad , semigroups , void , tagged , deepseq - , microlens >= 0.4 && <= 0.5, microlens-th - , trivial-constraint >= 0.4 + , lens , constrained-categories >= 0.2.3 && < 0.3.1 other-extensions: FlexibleInstances , TypeFamilies @@ -77,6 +77,7 @@ Data.Manifold.Types Data.Manifold.Types.Stiefel Data.Manifold.Griddable + Data.Manifold.Atlas Data.Manifold.Riemannian Other-modules: Data.List.FastNub Data.Manifold.Types.Primitive