diff --git a/Math/Manifold/Core/PseudoAffine.hs b/Math/Manifold/Core/PseudoAffine.hs --- a/Math/Manifold/Core/PseudoAffine.hs +++ b/Math/Manifold/Core/PseudoAffine.hs @@ -17,6 +17,8 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE CPP #-} @@ -28,11 +30,10 @@ import Data.AffineSpace import Data.Basis -import Data.Tagged import Data.Fixed (mod') import Data.Void -import Math.Manifold.Core.Types +import Math.Manifold.Core.Types.Internal import Math.Manifold.VectorSpace.ZeroDimensional import Control.Applicative @@ -43,10 +44,7 @@ import Data.CallStack (HasCallStack) - -data BoundarylessWitness m where - BoundarylessWitness :: (Semimanifold m, Interior m ~ m) - => BoundarylessWitness m +type ℝeal r = (RealFloat r, PseudoAffine r, Semimanifold r, Needle r ~ r) -- | This is the reified form of the property that the interior of a semimanifold -- is a manifold. These constraints would ideally be expressed directly as @@ -54,77 +52,43 @@ -- extension, which is not reliable yet. -- -- Also, if all those equality constraints are in scope, GHC tends to infer needlessly --- complicated types like @'Interior' ('Interior' ('Needle' ('Interior' x)))@, which is +-- complicated types like @'Needle' ('Needle' ('Needle' x))@, which is -- the same as just @'Needle' x@. data SemimanifoldWitness x where SemimanifoldWitness :: - ( Semimanifold (Needle x), Needle (Interior x) ~ Needle x - , Needle (Needle x) ~ Needle x - , Interior (Needle x) ~ Needle x ) - => BoundarylessWitness (Interior x) -> SemimanifoldWitness x + ( Semimanifold (Needle x) + , Needle (Needle x) ~ Needle x ) + => SemimanifoldWitness x data PseudoAffineWitness x where - PseudoAffineWitness :: - ( PseudoAffine (Interior x), PseudoAffine (Needle x) ) + PseudoAffineWitness :: PseudoAffine (Needle x) => SemimanifoldWitness x -> PseudoAffineWitness 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 + -- | The space of “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). + -- This space should be isomorphic to the tangent space (and in fact + -- serves an in many ways similar role), however whereas the tangent space + -- of a manifold is really infinitesimally small, needles actually allow + -- macroscopic displacements. type Needle x :: * type Needle x = GenericNeedle 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 -> Maybe (Interior x) - default toInterior :: ( Generic x, Semimanifold (VRep x) - , Interior x ~ GenericInterior x ) - => x -> Maybe (Interior x) - toInterior p = fmap GenericInterior $ toInterior (Gnrx.from p :: VRep 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) - default translateP :: ( Generic x, Semimanifold (VRep x) - , Interior x ~ GenericInterior x, Needle x ~ GenericNeedle x ) - => Tagged x (Interior x -> Needle x -> Interior x) - translateP = Tagged $ case translateP :: Tagged (VRep x) - (Interior (VRep x) -> Needle (VRep x) -> Interior (VRep x)) of - Tagged tp -> \(GenericInterior p) (GenericNeedle v) -> GenericInterior $ tp p v + -- | Generalisation of the translation operation '.+^' to possibly non-flat + -- manifolds, instead of affine spaces. + (.+~^) :: x -> Needle x -> x + default (.+~^) :: ( Generic x, Semimanifold (VRep x) + , Needle x ~ GenericNeedle x ) + => x -> Needle x -> x + p.+~^GenericNeedle v = Gnrx.to (Gnrx.from p.+~^v :: Gnrx.Rep x Void) -- | Shorthand for @\\p v -> p .+~^ 'negateV' v@, which should obey the /asymptotic/ law -- @@ -133,30 +97,23 @@ -- @ -- -- 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, + -- the difference @(p.-~^v.+~^v) .-~. p@ should eventually scale down even faster: + -- as /O/ (/η/²). For large vectors, it may however behave differently, -- except in flat spaces (where all this should be equivalent to the 'AffineSpace' -- instance). - (.-~^) :: Interior x -> Needle x -> x + (.-~^) :: 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 - , Needle (Needle x) ~ Needle x - , Interior (Needle x) ~ Needle x ) + ( Semimanifold (Needle x), Needle (Needle x) ~ Needle x ) => SemimanifoldWitness x - semimanifoldWitness = SemimanifoldWitness BoundarylessWitness + 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@.) +-- | This is the class underlying what we understand as manifolds. -- --- The interface is (boundaries aside) almost identical to the better-known +-- The interface is almost identical to the better-known -- 'AffineSpace' class, but we don't require associativity of '.+~^' with '^+^' -- – except in an /asymptotic sense/ for small vectors. -- @@ -168,42 +125,77 @@ -- 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). +-- +-- The 'Semimanifold' and 'PseudoAffine' classes can be @anyclass@-derived +-- or empty-instantiated based on 'Generic' for product types (including newtypes) of +-- existing 'PseudoAffine' instances. For example, the definition +-- +-- @ +-- data Cylinder = CylinderPolar { zCyl :: !D¹, φCyl :: !S¹ } +-- deriving (Generic, Semimanifold, PseudoAffine) +-- @ +-- +-- is equivalent to +-- +-- @ +-- data Cylinder = CylinderPolar { zCyl :: !D¹, φCyl :: !S¹ } +-- +-- data CylinderNeedle = CylinderPolarNeedle { δzCyl :: !(Needle D¹), δφCyl :: !(Needle S¹) } +-- +-- instance Semimanifold Cylinder where +-- type Needle Cylinder = CylinderNeedle +-- CylinderPolar z φ .+~^ CylinderPolarNeedle δz δφ +-- = CylinderPolar (z.+~^δz) (φ.+~^δφ) +-- +-- instance PseudoAffine Cylinder where +-- CylinderPolar z₁ φ₁ .-~. CylinderPolar z₀ φ₀ +-- = CylinderPolarNeedle <$> z₁.-~.z₀ <*> φ₁.-~.φ₀ +-- CylinderPolar z₁ φ₁ .-~! CylinderPolar z₀ φ₀ +-- = CylinderPolarNeedle (z₁.-~!z₀) (φ₁.-~.φ₀) +-- @ class Semimanifold 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 - -- + -- Should only yield 'Nothing' if the points are on disjoint segments + -- of a non–path-connected space. + -- + -- For a connected manifold, you may define this method as + -- -- @ - -- p .+~^ (q.-~.p) ≡ q + -- p.-~.q = pure (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 -> x -> Maybe (Needle x) - p.-~.q = return $ p.-~!q + default (.-~.) :: ( Generic x, PseudoAffine (VRep x) + , Needle x ~ GenericNeedle x ) + => x -> x -> Maybe (Needle x) + p.-~.q = GenericNeedle <$> Gnrx.from p .-~. (Gnrx.from q :: Gnrx.Rep x Void) -- | Unsafe version of '.-~.'. If the two points lie in disjoint regions, -- the behaviour is undefined. + -- + -- Whenever @p@ and @q@ lie in a connected region, the identity + -- + -- @ + -- p .+~^ (q.-~.p) ≡ q + -- @ + -- + -- should hold (up to possible floating point rounding etc.). + -- Meanwhile, you will in general have + -- + -- @ + -- (p.+~^v).-~^v ≠ p + -- @ + -- + -- (though in many instances this is at least for sufficiently small @v@ approximately equal). (.-~!) :: HasCallStack => x -> x -> Needle x - p.-~!q = case p.-~.q of - Just v -> v - Nothing -> error "Attempt to calculate vector between points on disjoint manifold-regions." + default (.-~!) :: ( Generic x, PseudoAffine (VRep x) + , Needle x ~ GenericNeedle x ) + => x -> x -> Needle x + p.-~!q = GenericNeedle $ Gnrx.from p .-~! (Gnrx.from q :: Gnrx.Rep x Void) {-# INLINE (.-~!) #-} pseudoAffineWitness :: PseudoAffineWitness x default pseudoAffineWitness :: - ( PseudoAffine (Interior x), PseudoAffine (Needle x) ) + PseudoAffine (Needle x) => PseudoAffineWitness x pseudoAffineWitness = PseudoAffineWitness semimanifoldWitness @@ -233,17 +225,17 @@ -- only makes sense on a Riemannian manifold, as 'Data.Manifold.Riemannian.Geodesic'. palerp :: ∀ x. (PseudoAffine x, VectorSpace (Needle x)) => x -> x -> Maybe (Scalar (Needle x) -> x) -palerp p₀ p₁ = case (toInterior p₀, p₁.-~.p₀) of - (Just b, Just v) -> return $ \t -> b .+~^ t *^ v - _ -> Nothing +palerp p₀ p₁ = case p₁.-~.p₀ of + Just v -> return $ \t -> p₀ .+~^ t *^ v + _ -> Nothing -- | 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. (PseudoAffine x, VectorSpace (Needle x), Scalar (Needle x) ~ ℝ) => x -> x -> Maybe (D¹ -> x) -palerpB p₀ p₁ = case (toInterior p₀, p₁.-~.p₀) of - (Just b, Just v) -> return $ \(D¹ t) -> b .+~^ ((t+1)/2) *^ v +palerpB p₀ p₁ = case p₁.-~.p₀ of + Just v -> return $ \(D¹ t) -> p₀ .+~^ ((t+1)/2) *^ v _ -> Nothing -- | Like 'alerp', but actually restricted to the interval between the points. @@ -254,151 +246,86 @@ -hugeℝVal :: ℝ -hugeℝVal = 1e+100 - #define deriveAffine(c,t) \ instance (c) => Semimanifold (t) where { \ type Needle (t) = Diff (t); \ - fromInterior = id; \ - toInterior = pure; \ - translateP = Tagged (.+^); \ - (.+~^) = (.+^) }; \ -instance (c) => PseudoAffine (t) where { \ - a.-~.b = pure (a.-.b); } + (.+~^) = (.+^) }; \ +instance (c) => PseudoAffine (t) where { \ + a.-~.b = pure (a.-.b); \ + (.-~!) = (.-.) } deriveAffine((),Double) deriveAffine((),Float) deriveAffine((),Rational) - 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 = Origin Origin .-~. Origin = pure Origin 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) = (,) <$> 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 BoundarylessWitness, SemimanifoldWitness BoundarylessWitness) - -> SemimanifoldWitness BoundarylessWitness + (SemimanifoldWitness, SemimanifoldWitness) -> SemimanifoldWitness instance (PseudoAffine a, PseudoAffine b) => PseudoAffine (a,b) where (a,b).-~.(c,d) = liftA2 (,) (a.-~.c) (b.-~.d) + (a,b).-~!(c,d) = (a.-~!c, b.-~!d) pseudoAffineWitness = case ( pseudoAffineWitness :: PseudoAffineWitness a , pseudoAffineWitness :: PseudoAffineWitness b ) of - ( PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness) - , PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness) ) - ->PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness) + ( PseudoAffineWitness (SemimanifoldWitness) + , PseudoAffineWitness (SemimanifoldWitness) ) + ->PseudoAffineWitness (SemimanifoldWitness) 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 BoundarylessWitness - ,SemimanifoldWitness BoundarylessWitness - ,SemimanifoldWitness BoundarylessWitness ) - -> SemimanifoldWitness BoundarylessWitness + ( SemimanifoldWitness, SemimanifoldWitness, SemimanifoldWitness ) + -> SemimanifoldWitness instance (PseudoAffine a, PseudoAffine b, PseudoAffine c) => PseudoAffine (a,b,c) where + (a,b,c).-~!(d,e,f) = (a.-~!d, b.-~!e, c.-~!f) (a,b,c).-~.(d,e,f) = liftA3 (,,) (a.-~.d) (b.-~.e) (c.-~.f) pseudoAffineWitness = case ( pseudoAffineWitness :: PseudoAffineWitness a , pseudoAffineWitness :: PseudoAffineWitness b , pseudoAffineWitness :: PseudoAffineWitness c ) of - ( PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness) - , PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness) - , PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness) ) - ->PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness) + ( PseudoAffineWitness SemimanifoldWitness + , PseudoAffineWitness SemimanifoldWitness + , PseudoAffineWitness SemimanifoldWitness ) + ->PseudoAffineWitness SemimanifoldWitness -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 - _ .-~. _ = Nothing -instance Semimanifold S¹ where - type Needle S¹ = ℝ - fromInterior = id - toInterior = pure - translateP = Tagged (.+~^) - S¹Polar φ₀ .+~^ δφ = S¹Polar $ φ' - where φ' = toS¹range $ φ₀ + δφ -instance PseudoAffine S¹ where - S¹Polar φ₁ .-~. S¹Polar φ₀ - | δφ > pi = pure (δφ - tau) - | δφ < (-pi) = pure (δφ + tau) - | 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 .-~. D¹ y - | abs x < 1, abs y < 1 = return $ atanh x - atanh y - | otherwise = empty - - -instance Semimanifold ℝP⁰ where - type Needle ℝP⁰ = ZeroDim ℝ - fromInterior = id - toInterior = pure - translateP = Tagged (.+~^) +instance Semimanifold (ℝP⁰_ r) where + type Needle (ℝP⁰_ r) = ZeroDim r p .+~^ Origin = p p .-~^ Origin = p -instance PseudoAffine ℝP⁰ where +instance PseudoAffine (ℝP⁰_ r) where + ℝPZero .-~! ℝPZero = Origin ℝPZero .-~. ℝPZero = pure Origin -instance Semimanifold ℝP¹ where - type Needle ℝP¹ = ℝ - fromInterior = id - toInterior = pure - translateP = Tagged (.+~^) +instance ℝeal r => Semimanifold (ℝP¹_ r) where + type Needle (ℝP¹_ r) = r HemisphereℝP¹Polar r₀ .+~^ δr = HemisphereℝP¹Polar . toℝP¹range $ r₀ + δr -instance PseudoAffine ℝP¹ where - HemisphereℝP¹Polar φ₁ .-~. HemisphereℝP¹Polar φ₀ - | δφ > pi/2 = pure (δφ - pi) - | δφ < (-pi/2) = pure (δφ + pi) - | otherwise = pure δφ +instance ℝeal r => PseudoAffine (ℝP¹_ r) where + p.-~.q = pure (p.-~!q) + HemisphereℝP¹Polar φ₁ .-~! HemisphereℝP¹Polar φ₀ + | δφ > pi/2 = δφ - pi + | δφ < (-pi/2) = δφ + pi + | otherwise = δφ where δφ = φ₁ - φ₀ @@ -406,16 +333,16 @@ -tau :: ℝ +tau :: RealFloat r => r tau = 2 * pi -toS¹range :: ℝ -> ℝ +toS¹range :: RealFloat r => r -> r toS¹range φ = (φ+pi)`mod'`tau - pi -toℝP¹range :: ℝ -> ℝ +toℝP¹range :: RealFloat r => r -> r toℝP¹range φ = (φ+pi/2)`mod'`pi - pi/2 -toUnitrange :: ℝ -> ℝ +toUnitrange :: RealFloat r => r -> r toUnitrange φ = (φ+1)`mod'`2 - 1 @@ -445,9 +372,6 @@ => Semimanifold (NeedleProductSpace f g p) where type Needle (NeedleProductSpace f g p) = NeedleProductSpace f g p (.+~^) = (^+^) - fromInterior = id - toInterior = pure - translateP = Tagged (^+^) instance (PseudoAffine (f p), PseudoAffine (g p)) => PseudoAffine (NeedleProductSpace f g p) where p.-~.q = Just $ p.-.q @@ -466,42 +390,6 @@ decompose' (NeedleProductSpace _ vg) (Right bg) = decompose' vg bg -data InteriorProductSpace f g p = InteriorProductSpace - !(Interior (f p)) !(Interior (g p)) deriving (Generic) -instance ∀ f g p . (Semimanifold (f p), Semimanifold (g p)) - => Semimanifold (InteriorProductSpace f g p) where - type Needle (InteriorProductSpace f g p) = NeedleProductSpace f g p - type Interior (InteriorProductSpace f g p) = InteriorProductSpace f g p - (.+~^) = case - ( translateP :: Tagged (f p) (Interior (f p) -> Needle (f p) -> Interior (f p)) - , translateP :: Tagged (g p) (Interior (g p) -> Needle (g p) -> Interior (g p)) ) of - (Tagged tf, Tagged tg) - -> \(InteriorProductSpace pf pg) (NeedleProductSpace vf vg) - -> InteriorProductSpace (tf pf vf) (tg pg vg) - fromInterior = id - toInterior = pure - translateP = Tagged $ case - ( translateP :: Tagged (f p) (Interior (f p) -> Needle (f p) -> Interior (f p)) - , translateP :: Tagged (g p) (Interior (g p) -> Needle (g p) -> Interior (g p)) ) of - (Tagged tf, Tagged tg) - -> \(InteriorProductSpace pf pg) (NeedleProductSpace vf vg) - -> InteriorProductSpace (tf pf vf) (tg pg vg) -instance ∀ f g p . (PseudoAffine (f p), PseudoAffine (g p)) - => PseudoAffine (InteriorProductSpace f g p) where - (.-~.) = case - ( pseudoAffineWitness :: PseudoAffineWitness (f p) - , pseudoAffineWitness :: PseudoAffineWitness (g p) ) of - ( PseudoAffineWitness (SemimanifoldWitness _) - ,PseudoAffineWitness (SemimanifoldWitness _) ) - -> \(InteriorProductSpace pf pg) (InteriorProductSpace qf qg) - -> NeedleProductSpace <$> pf.-~.qf <*> pg.-~.qg - (.-~!) = case - ( pseudoAffineWitness :: PseudoAffineWitness (f p) - , pseudoAffineWitness :: PseudoAffineWitness (g p) ) of - ( PseudoAffineWitness (SemimanifoldWitness _) - ,PseudoAffineWitness (SemimanifoldWitness _) ) - -> \(InteriorProductSpace pf pg) (InteriorProductSpace qf qg) - -> NeedleProductSpace (pf.-~!qf) (pg.-~!qg) newtype GenericNeedle x = GenericNeedle {getGenericNeedle :: Needle (VRep x)} @@ -522,100 +410,82 @@ (.+^) = (^+^) instance AdditiveGroup (Needle (VRep x)) => Semimanifold (GenericNeedle x) where type Needle (GenericNeedle x) = GenericNeedle x - type Interior (GenericNeedle x) = GenericNeedle x - fromInterior = id - toInterior = pure - translateP = Tagged (^+^) + (.+~^) = (.+^) instance AdditiveGroup (Needle (VRep x)) => PseudoAffine (GenericNeedle x) where GenericNeedle v .-~. GenericNeedle w = Just $ GenericNeedle (v ^-^ w) GenericNeedle v .-~! GenericNeedle w = GenericNeedle (v ^-^ w) -newtype GenericInterior x = GenericInterior {getGenericInterior :: Interior (VRep x)} - deriving (Generic) -instance Semimanifold (VRep x) => Semimanifold (GenericInterior x) where - type Needle (GenericInterior x) = GenericNeedle x - type Interior (GenericInterior x) = GenericInterior x - fromInterior = id - toInterior = pure - translateP = Tagged $ case translateP :: Tagged (VRep x) - (Interior (VRep x) -> Needle (VRep x) -> Interior (VRep x)) of - Tagged tp -> \(GenericInterior p) (GenericNeedle v) -> GenericInterior $ tp p v -instance ∀ x . PseudoAffine (VRep x) => PseudoAffine (GenericInterior x) where - (.-~.) = case pseudoAffineWitness :: PseudoAffineWitness (VRep x) of - PseudoAffineWitness (SemimanifoldWitness _) - -> \(GenericInterior v) (GenericInterior w) - -> GenericNeedle <$> (v .-~. w) - (.-~!) = case pseudoAffineWitness :: PseudoAffineWitness (VRep x) of - PseudoAffineWitness (SemimanifoldWitness _) - -> \(GenericInterior v) (GenericInterior w) - -> GenericNeedle (v .-~! w) - - instance ∀ a s . Semimanifold a => Semimanifold (Gnrx.Rec0 a s) where type Needle (Gnrx.Rec0 a s) = Needle a - type Interior (Gnrx.Rec0 a s) = Interior a semimanifoldWitness = case semimanifoldWitness :: SemimanifoldWitness a of - SemimanifoldWitness BoundarylessWitness - -> SemimanifoldWitness BoundarylessWitness - fromInterior = Gnrx.K1 . fromInterior - toInterior = toInterior . Gnrx.unK1 - translateP = case semimanifoldWitness :: SemimanifoldWitness a of - SemimanifoldWitness BoundarylessWitness -> Tagged (.+~^) + SemimanifoldWitness + -> SemimanifoldWitness + Gnrx.K1 p .+~^ v = Gnrx.K1 $ p .+~^ v instance ∀ f p i c . Semimanifold (f p) => Semimanifold (Gnrx.M1 i c f p) where type Needle (Gnrx.M1 i c f p) = Needle (f p) - type Interior (Gnrx.M1 i c f p) = Interior (f p) semimanifoldWitness = case semimanifoldWitness :: SemimanifoldWitness (f p) of - SemimanifoldWitness BoundarylessWitness - -> SemimanifoldWitness BoundarylessWitness - fromInterior = Gnrx.M1 . fromInterior - toInterior = toInterior . Gnrx.unM1 - translateP = case semimanifoldWitness :: SemimanifoldWitness (f p) of - SemimanifoldWitness BoundarylessWitness -> Tagged (.+~^) + SemimanifoldWitness -> SemimanifoldWitness + Gnrx.M1 p.+~^v = Gnrx.M1 $ p.+~^v instance ∀ f g p . (Semimanifold (f p), Semimanifold (g p)) => Semimanifold ((f :*: g) p) where type Needle ((f:*:g) p) = NeedleProductSpace f g p - type Interior ((f:*:g) p) = InteriorProductSpace f g p semimanifoldWitness = case ( semimanifoldWitness :: SemimanifoldWitness (f p) , semimanifoldWitness :: SemimanifoldWitness (g p) ) of - ( SemimanifoldWitness BoundarylessWitness - ,SemimanifoldWitness BoundarylessWitness ) - -> SemimanifoldWitness BoundarylessWitness - fromInterior (InteriorProductSpace pf pg) = fromInterior pf :*: fromInterior pg - toInterior (pf :*: pg) = InteriorProductSpace <$> toInterior pf <*> toInterior pg - translateP = Tagged $ case - ( translateP :: Tagged (f p) (Interior (f p) -> Needle (f p) -> Interior (f p)) - , translateP :: Tagged (g p) (Interior (g p) -> Needle (g p) -> Interior (g p)) ) of - (Tagged tf, Tagged tg) - -> \(InteriorProductSpace pf pg) (NeedleProductSpace vf vg) - -> InteriorProductSpace (tf pf vf) (tg pg vg) + ( SemimanifoldWitness, SemimanifoldWitness ) + -> SemimanifoldWitness + (p:*:q).+~^(NeedleProductSpace v w) = (p.+~^v) :*: (q.+~^w) instance ∀ a s . PseudoAffine a => PseudoAffine (Gnrx.Rec0 a s) where pseudoAffineWitness = case pseudoAffineWitness :: PseudoAffineWitness a of - PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness) - -> PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness) + PseudoAffineWitness SemimanifoldWitness + -> PseudoAffineWitness SemimanifoldWitness Gnrx.K1 p .-~. Gnrx.K1 q = p .-~. q Gnrx.K1 p .-~! Gnrx.K1 q = p .-~! q instance ∀ f p i c . PseudoAffine (f p) => PseudoAffine (Gnrx.M1 i c f p) where pseudoAffineWitness = case pseudoAffineWitness :: PseudoAffineWitness (f p) of - PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness) - -> PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness) + PseudoAffineWitness SemimanifoldWitness + -> PseudoAffineWitness SemimanifoldWitness Gnrx.M1 p .-~. Gnrx.M1 q = p .-~. q Gnrx.M1 p .-~! Gnrx.M1 q = p .-~! q instance ∀ f g p . (PseudoAffine (f p), PseudoAffine (g p)) => PseudoAffine ((f :*: g) p) where pseudoAffineWitness = case ( pseudoAffineWitness :: PseudoAffineWitness (f p) , pseudoAffineWitness :: PseudoAffineWitness (g p) ) of - ( PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness) - ,PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness) ) - -> PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness) + ( PseudoAffineWitness SemimanifoldWitness + ,PseudoAffineWitness SemimanifoldWitness ) + -> PseudoAffineWitness SemimanifoldWitness (pf:*:pg) .-~. (qf:*:qg) = NeedleProductSpace <$> (pf.-~.qf) <*> (pg.-~.qg) (pf:*:pg) .-~! (qf:*:qg) = NeedleProductSpace (pf.-~!qf) (pg.-~!qg) type VRep x = Gnrx.Rep x Void + + + +-- | A (closed) cone over a space @x@ is the product of @x@ with the closed interval 'D¹' +-- of “heights”, +-- except on its “tip”: here, @x@ is smashed to a single point. +-- +-- This construct becomes (homeomorphic-to-) an actual geometric cone (and to 'D²') in the +-- special case @x = 'S¹'@. +data CD¹ x = CD¹ { hParamCD¹ :: !(Scalar (Needle x)) -- ^ Range @[0, 1]@ + , pParamCD¹ :: !x -- ^ Irrelevant at @h = 0@. + } deriving (Generic) +deriving instance (Show x, Show (Scalar (Needle x))) => Show (CD¹ x) + + +-- | An open cone is homeomorphic to a closed cone without the “lid”, +-- i.e. without the “last copy” of @x@, at the far end of the height +-- interval. Since that means the height does not include its supremum, it is actually +-- more natural to express it as the entire real ray, hence the name. +data Cℝay x = Cℝay { hParamCℝay :: !(Scalar (Needle x)) -- ^ Range @[0, ∞[@ + , pParamCℝay :: !x -- ^ Irrelevant at @h = 0@. + } deriving (Generic) +deriving instance (Show x, Show (Scalar (Needle x))) => Show (Cℝay x) + diff --git a/Math/Manifold/Core/Types.hs b/Math/Manifold/Core/Types.hs --- a/Math/Manifold/Core/Types.hs +++ b/Math/Manifold/Core/Types.hs @@ -18,14 +18,15 @@ module Math.Manifold.Core.Types - ( ℝ⁰, ℝ - , S⁰(..), otherHalfSphere, S¹(..), pattern S¹, S²(..), pattern S² - , D¹(..), fromIntv0to1, D²(..), pattern D² - , ℝP⁰(..), ℝP¹(..), pattern ℝP¹, ℝP²(..), pattern ℝP² + ( EmptyMfd(..), ℝ⁰, ℝ + , S⁰, S⁰_(..), otherHalfSphere, S¹, S¹_(..), pattern S¹, S², S²_(..), pattern S² + , D¹, D¹_(..), fromIntv0to1, D², D²_(..), pattern D² + , ℝP⁰, ℝP⁰_(..), ℝP¹, ℝP¹_(..), pattern ℝP¹, ℝP², ℝP²_(..), pattern ℝP² , Cℝay(..), CD¹(..) ) where import Math.Manifold.Core.Types.Internal +import Math.Manifold.Core.PseudoAffine import Data.VectorSpace import Math.Manifold.VectorSpace.ZeroDimensional diff --git a/Math/Manifold/Core/Types/Internal.hs b/Math/Manifold/Core/Types/Internal.hs --- a/Math/Manifold/Core/Types/Internal.hs +++ b/Math/Manifold/Core/Types/Internal.hs @@ -11,6 +11,7 @@ -- data types. All these are in the 'PseudoAffine' class. -- {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyCase #-} module Math.Manifold.Core.Types.Internal where @@ -19,33 +20,55 @@ import Data.Fixed (mod') +import Proof.Propositional (Empty(..)) + import GHC.Generics +-- | The empty space can be considered a manifold with any sort of tangent space. +data EmptyMfd v + +instance Empty (EmptyMfd v) where + eliminate p = case p of {} +instance Eq (EmptyMfd v) where + p==q = eliminate p && eliminate q +instance Ord (EmptyMfd v) where + p Eq (S¹_ r) where S¹Polar φ == S¹Polar φ' = φ `mod'` (2*pi) == φ' `mod'` (2*pi) + -- It's not clear that it's actually a good idea to fold back the range here, + -- since values outside @[-π, π[@ should not be allowed in the first place. -newtype ℝP¹ = HemisphereℝP¹Polar { φParamℝP¹ :: Double -- ^ Range @[-π\/2,π\/2[@. - } deriving (Show, Generic) +type ℝP¹ = ℝP¹_ Double +newtype ℝP¹_ r = HemisphereℝP¹Polar { φParamℝP¹ :: r -- ^ Range @[-π\/2,π\/2[@. + } deriving (Show, Generic) -- | The ordinary unit sphere. -data S² = S²Polar { ϑParamS² :: !Double -- ^ Range @[0, π[@. - , φParamS² :: !Double -- ^ Range @[-π, π[@. - } deriving (Show, Generic) +type S² = S²_ Double +data S²_ r = S²Polar { ϑParamS² :: !r -- ^ Range @[0, π[@. + , φParamS² :: !r -- ^ Range @[-π, π[@. + } deriving (Show, Generic) -instance Eq S² where +instance (Eq r, RealFloat r) => Eq (S²_ r) where S²Polar θ φ == S²Polar θ' φ' | θ > 0, θ < pi = θ == θ' && φ `mod'` (2*pi) == φ' `mod'` (2*pi) | otherwise = θ == θ' @@ -55,41 +78,26 @@ -- of a unit sphere; 'ℝP²' is the space of all straight lines passing through -- the origin of 'ℝ³', and each of these lines is represented by the point at which it -- passes through the hemisphere. -data ℝP² = HemisphereℝP²Polar { ϑParamℝP² :: !Double -- ^ Range @[0, π/2]@. - , φParamℝP² :: !Double -- ^ Range @[-π, π[@. - } deriving (Show, Generic) +type ℝP² = ℝP²_ Double +data ℝP²_ r = HemisphereℝP²Polar { ϑParamℝP² :: !r -- ^ Range @[0, π/2]@. + , φParamℝP² :: !r -- ^ Range @[-π, π[@. + } deriving (Show, Generic) -- | The standard, closed unit disk. Homeomorphic to the cone over 'S¹', but not in the -- the obvious, “flat” way. (In is /not/ homeomorphic, despite -- the almost identical ADT definition, to the projective space 'ℝP²'!) -data D² = D²Polar { rParamD² :: !Double -- ^ Range @[0, 1]@. - , φParamD² :: !Double -- ^ Range @[-π, π[@. - } deriving (Show, Generic) - --- | A (closed) cone over a space @x@ is the product of @x@ with the closed interval 'D¹' --- of “heights”, --- except on its “tip”: here, @x@ is smashed to a single point. --- --- This construct becomes (homeomorphic-to-) an actual geometric cone (and to 'D²') in the --- special case @x = 'S¹'@. -data CD¹ x = CD¹ { hParamCD¹ :: !Double -- ^ Range @[0, 1]@ - , pParamCD¹ :: !x -- ^ Irrelevant at @h = 0@. - } deriving (Show, Generic) +type D² = D²_ Double +data D²_ r = D²Polar { rParamD² :: !r -- ^ Range @[0, 1]@. + , φParamD² :: !r -- ^ Range @[-π, π[@. + } deriving (Show, Generic) --- | An open cone is homeomorphic to a closed cone without the “lid”, --- i.e. without the “last copy” of @x@, at the far end of the height --- interval. Since that means the height does not include its supremum, it is actually --- 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, Generic) - -- | 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]@. - } deriving (Show, Generic) +type D¹ = D¹_ Double +newtype D¹_ r = D¹ { xParamD¹ :: r -- ^ Range @[-1, 1]@. + } deriving (Show, Generic) type ℝ = Double type ℝ⁰ = ZeroDim ℝ diff --git a/Math/Manifold/VectorSpace/Scalar.hs b/Math/Manifold/VectorSpace/Scalar.hs new file mode 100644 --- /dev/null +++ b/Math/Manifold/VectorSpace/Scalar.hs @@ -0,0 +1,22 @@ +-- | +-- Module : Math.Manifold.VectorSpace.Scalar +-- Copyright : (c) Justus Sagemüller 2022 +-- License : GPL v3 +-- +-- Maintainer : (@) jsag $ hvl.no +-- Stability : experimental +-- Portability : portable +-- + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} + + +module Math.Manifold.VectorSpace.Scalar where + +import Data.VectorSpace + + +class (VectorSpace s, Num s, Scalar s ~ s) => ScalarSpace s +instance (VectorSpace s, Num s, Scalar s ~ s) => ScalarSpace s diff --git a/manifolds-core.cabal b/manifolds-core.cabal --- a/manifolds-core.cabal +++ b/manifolds-core.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: manifolds-core -version: 0.5.1.0 +version: 0.6.0.0 synopsis: The basic classes for the manifolds hierarchy. description: The basic classes for the hierarchy. @@ -21,11 +21,13 @@ exposed-modules: Math.Manifold.Core.Types , Math.Manifold.Core.PseudoAffine , Math.Manifold.VectorSpace.ZeroDimensional + , Math.Manifold.VectorSpace.Scalar other-modules: Math.Manifold.Core.Types.Internal other-extensions: FlexibleInstances, UndecidableInstances, ExplicitNamespaces, TypeFamilies, FunctionalDependencies, FlexibleContexts, GADTs, RankNTypes, TupleSections, ConstraintKinds, PatternGuards, TypeOperators, ScopedTypeVariables, RecordWildCards, DataKinds, StandaloneDeriving, DefaultSignatures, UnicodeSyntax, MultiWayIf build-depends: base >=4.5 && <5 , vector-space >=0.11 , tagged , call-stack + , equational-reasoning >=0.6 && <0.8 -- hs-source-dirs: default-language: Haskell2010