From 69c19403fa3e8cb6d975a0ed9110b5ab6f0151d8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Justus=20Sagem=C3=BCller?= Date: Mon, 12 Mar 2018 14:40:43 +0100 Subject: [PATCH] More meaningful representation of projective spaces. Using the half-sphere readily allows us to piggy-back upon the well-tested sphere methods for tangent transport etc. --- .../Math/Manifold/Core/PseudoAffine.hs | 16 +++++------ manifolds-core/Math/Manifold/Core/Types.hs | 11 +++++--- .../Math/Manifold/Core/Types/Internal.hs | 21 ++++++++------ manifolds/Data/Manifold/PseudoAffine.hs | 28 ++++++++----------- manifolds/Data/Manifold/Types/Primitive.hs | 19 +++++++------ manifolds/test/tasty/test.hs | 20 ++++++------- 6 files changed, 58 insertions(+), 57 deletions(-) diff --git a/manifolds-core/Math/Manifold/Core/PseudoAffine.hs b/manifolds-core/Math/Manifold/Core/PseudoAffine.hs index 79f09ca..cd1694b 100644 --- a/manifolds-core/Math/Manifold/Core/PseudoAffine.hs +++ b/manifolds-core/Math/Manifold/Core/PseudoAffine.hs @@ -393,15 +393,12 @@ instance Semimanifold ℝP¹ where fromInterior = id toInterior = pure translateP = Tagged (.+~^) - UnitDiskℝP¹ r₀ .+~^ δr - | r' < -1 = UnitDiskℝP¹ $ r' + 2 - | otherwise = UnitDiskℝP¹ $ r' - where r' = toUnitrange $ r₀ + δr + HemisphereℝP¹Polar r₀ .+~^ δr = HemisphereℝP¹Polar . toℝP¹range $ r₀ + δr instance PseudoAffine ℝP¹ where - UnitDiskℝP¹ φ₁ .-~. UnitDiskℝP¹ φ₀ - | δφ > pi = pure (δφ - 2*pi) - | δφ < (-pi) = pure (δφ + 2*pi) - | otherwise = pure δφ + HemisphereℝP¹Polar φ₁ .-~. HemisphereℝP¹Polar φ₀ + | δφ > pi/2 = pure (δφ - pi) + | δφ < (-pi/2) = pure (δφ + pi) + | otherwise = pure δφ where δφ = φ₁ - φ₀ @@ -415,6 +412,9 @@ tau = 2 * pi toS¹range :: ℝ -> ℝ toS¹range φ = (φ+pi)`mod'`tau - pi +toℝP¹range :: ℝ -> ℝ +toℝP¹range φ = (φ+pi/2)`mod'`pi - pi/2 + toUnitrange :: ℝ -> ℝ toUnitrange φ = (φ+1)`mod'`2 - 1 diff --git a/manifolds-core/Math/Manifold/Core/Types.hs b/manifolds-core/Math/Manifold/Core/Types.hs index c48177e..ea3622f 100644 --- a/manifolds-core/Math/Manifold/Core/Types.hs +++ b/manifolds-core/Math/Manifold/Core/Types.hs @@ -14,6 +14,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} module Math.Manifold.Core.Types @@ -45,17 +46,19 @@ otherHalfSphere NegativeHalfSphere = PositiveHalfSphere pattern S¹ :: Double -> S¹ pattern S¹ φ = S¹Polar φ -{-# DEPRECATED ℝP¹ "Use Math.Manifold.Core.Types.UnitDiskℝP¹" #-} +{-# DEPRECATED ℝP¹ "Use Math.Manifold.Core.Types.HemisphereℝP¹Polar (notice: different range)" #-} pattern ℝP¹ :: Double -> ℝP¹ -pattern ℝP¹ r = UnitDiskℝP¹ r +pattern ℝP¹ r <- (HemisphereℝP¹Polar ((2/pi*)->r)) + where ℝP¹ r = HemisphereℝP¹Polar $ r * pi/2 {-# DEPRECATED S² "Use Math.Manifold.Core.Types.S²Polar" #-} pattern S² :: Double -> Double -> S² pattern S² ϑ φ = S²Polar ϑ φ -{-# DEPRECATED ℝP² "Use Math.Manifold.Core.Types.UnitDiskℝP²Polar" #-} +{-# DEPRECATED ℝP² "Use Math.Manifold.Core.Types.HemisphereℝP²Polar (notice: different range)" #-} pattern ℝP² :: Double -> Double -> ℝP² -pattern ℝP² r φ = UnitDiskℝP²Polar r φ +pattern ℝP² r φ <- (HemisphereℝP²Polar ((2/pi*)->r) φ) + where ℝP² r φ = HemisphereℝP²Polar (r * pi/2) φ {-# DEPRECATED D² "Use Math.Manifold.Core.Types.D²Polar" #-} pattern D² :: Double -> Double -> D² diff --git a/manifolds-core/Math/Manifold/Core/Types/Internal.hs b/manifolds-core/Math/Manifold/Core/Types/Internal.hs index d521cf1..22901f0 100644 --- a/manifolds-core/Math/Manifold/Core/Types/Internal.hs +++ b/manifolds-core/Math/Manifold/Core/Types/Internal.hs @@ -30,8 +30,8 @@ newtype S¹ = S¹Polar { φParamS¹ :: Double -- ^ Must be in range @[-π, π[@. } deriving (Show) -newtype ℝP¹ = UnitDiskℝP¹ { rParamℝP¹ :: Double -- ^ Range @[-1,1]@. - } deriving (Show) +newtype ℝP¹ = HemisphereℝP¹Polar { φParamℝP¹ :: Double -- ^ Range @[-π/2,π/2[@. + } deriving (Show) -- | The ordinary unit sphere. data S² = S²Polar { ϑParamS² :: !Double -- ^ Range @[0, π[@. @@ -39,16 +39,19 @@ data S² = S²Polar { ϑParamS² :: !Double -- ^ Range @[0, π[@. } deriving (Show) --- | The two-dimensional real projective space, implemented as a unit disk with --- opposing points on the rim glued together. -data ℝP² = UnitDiskℝP²Polar { rParamℝP² :: !Double -- ^ Range @[0, 1]@. - , φParamℝP² :: !Double -- ^ Range @[-π, π[@. - } deriving (Show) +-- | The two-dimensional real projective space, implemented as a disk with +-- opposing points on the rim glued together. Image this disk as the northern hemisphere +-- 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) -- | 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²'!) +-- 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) diff --git a/manifolds/Data/Manifold/PseudoAffine.hs b/manifolds/Data/Manifold/PseudoAffine.hs index ccefb88..1383dd0 100644 --- a/manifolds/Data/Manifold/PseudoAffine.hs +++ b/manifolds/Data/Manifold/PseudoAffine.hs @@ -430,24 +430,18 @@ instance Semimanifold ℝP² where fromInterior = id toInterior = pure translateP = Tagged (.+~^) - UnitDiskℝP²Polar r₀ φ₀ .+~^ V2 δr δφ - | r₀ > 1/2 = case r₀ + δr of - r₁ | r₁ > 1 -> UnitDiskℝP²Polar (2-r₁) (toS¹range $ φ₀+δφ+pi) - | otherwise -> UnitDiskℝP²Polar r₁ (toS¹range $ φ₀+δφ) - UnitDiskℝP²Polar r₀ φ₀ .+~^ δxy - = let v = r₀*^embed(S¹Polar φ₀) ^+^ δxy - S¹Polar φ₁ = coEmbed v - r₁ = magnitude v `mod'` 1 - in UnitDiskℝP²Polar r₁ φ₁ + HemisphereℝP²Polar θ₀ φ₀ .+~^ v + = case S²Polar θ₀ φ₀ .+~^ v of + S²Polar θ₁ φ₁ + | θ₁ > pi/2 -> HemisphereℝP²Polar (pi-θ₁) (-φ₁) + | otherwise -> HemisphereℝP²Polar θ₁ φ₁ instance PseudoAffine ℝP² where - UnitDiskℝP²Polar r₁ φ₁ .-~. UnitDiskℝP²Polar r₀ φ₀ - | r₀ > 1/2 = pure `id` case φ₁-φ₀ of - δφ | δφ > 3*pi/2 -> V2 ( r₁ - r₀) (δφ - 2*pi) - | δφ < -3*pi/2 -> V2 ( r₁ - r₀) (δφ + 2*pi) - | δφ > pi/2 -> V2 (2-r₁ - r₀) (δφ - pi ) - | δφ < -pi/2 -> V2 (2-r₁ - r₀) (δφ + pi ) - | otherwise -> V2 ( r₁ - r₀) (δφ ) - | otherwise = pure ( r₁*^embed(S¹Polar φ₁) ^-^ r₀*^embed(S¹Polar φ₀) ) + HemisphereℝP²Polar θ₁ φ₁ .-~! HemisphereℝP²Polar θ₀ φ₀ + = case S²Polar θ₁ φ₁ .-~! S²Polar θ₀ φ₀ of + v -> let r² = magnitudeSq v + in if r²>pi^2/4 + then S²Polar (pi-θ₁) (-φ₁) .-~! S²Polar θ₀ φ₀ + else v -- instance (PseudoAffine m, VectorSpace (Needle m), Scalar (Needle m) ~ ℝ) diff --git a/manifolds/Data/Manifold/Types/Primitive.hs b/manifolds/Data/Manifold/Types/Primitive.hs index 9942769..83da33b 100644 --- a/manifolds/Data/Manifold/Types/Primitive.hs +++ b/manifolds/Data/Manifold/Types/Primitive.hs @@ -141,9 +141,10 @@ instance NaturallyEmbedded S² ℝ³ where {-# INLINE coEmbed #-} instance NaturallyEmbedded ℝP² ℝ³ where - embed (UnitDiskℝP²Polar r φ) = V3 (r * cos φ) (r * sin φ) (sqrt $ 1-r^2) - coEmbed (V3 x y z) = UnitDiskℝP²Polar (sqrt $ 1-(z/r)^2) (atan2 (y/r) (x/r)) - where r = sqrt $ x^2 + y^2 + z^2 + embed (HemisphereℝP²Polar θ φ) = V3 (cθ * cos φ) (cθ * sin φ) (sin θ) + where cθ = cos θ + coEmbed (V3 x y z) = HemisphereℝP²Polar (atan2 rxy z) (atan2 y x) + where rxy = sqrt $ x^2 + y^2 instance NaturallyEmbedded D¹ ℝ where embed = xParamD¹ @@ -226,15 +227,15 @@ instance QC.Arbitrary ℝP⁰ where arbitrary = pure ℝPZero instance QC.Arbitrary ℝP¹ where - arbitrary = ( \h -> UnitDiskℝP¹ (1 - (h`mod'`2)) ) <$> QC.arbitrary - shrink (UnitDiskℝP¹ r) = UnitDiskℝP¹ . (/12) <$> QC.shrink (r*12) + arbitrary = ( \θ -> HemisphereℝP¹Polar (pi/2 - (θ`mod'`pi)) ) <$> QC.arbitrary + shrink (HemisphereℝP¹Polar θ) = HemisphereℝP¹Polar . (pi/6*) <$> QC.shrink (θ*6/pi) instance QC.Arbitrary ℝP² where - arbitrary = ( \r φ -> UnitDiskℝP²Polar (r`mod'`1) (pi - (φ`mod'`(2*pi))) ) + arbitrary = ( \θ φ -> HemisphereℝP²Polar (θ`mod'`pi/2) (pi - (φ`mod'`(2*pi))) ) <$> QC.arbitrary<*>QC.arbitrary - shrink (UnitDiskℝP²Polar r φ) = [ UnitDiskℝP²Polar (r'/12) (φ'*pi/12) - | r' <- QC.shrink (r*12) - , φ' <- QC.shrink (φ*12/pi) ] + shrink (HemisphereℝP²Polar θ φ) = [ HemisphereℝP²Polar (θ'*pi/6) (φ'*pi/12) + | θ' <- QC.shrink (θ*6/pi) + , φ' <- QC.shrink (φ*12/pi) ] instance (SP.Show (Interior m), SP.Show f) => SP.Show (FibreBundle m f) where diff --git a/manifolds/test/tasty/test.hs b/manifolds/test/tasty/test.hs index 9c2469d..df7da1c 100644 --- a/manifolds/test/tasty/test.hs +++ b/manifolds/test/tasty/test.hs @@ -759,17 +759,17 @@ instance AEq ℝ³ where instance AEq ℝP⁰ where fuzzyEq _ ℝPZero ℝPZero = True instance AEq ℝP¹ where - fuzzyEq η (UnitDiskℝP¹ h) (UnitDiskℝP¹ h') - | h > 1/2, h'< -1/2 = fuzzyEq η (S¹Polar $ h - 2) (S¹Polar h') - | h'> 1/2, h < -1/2 = fuzzyEq η (S¹Polar h) (S¹Polar $ h'- 2) - | otherwise = abs (h - h') < η + fuzzyEq η (HemisphereℝP¹Polar θ) (HemisphereℝP¹Polar ϑ) + = fuzzyEq η (S¹Polar $ θ*2) (S¹Polar $ ϑ*2) instance AEq ℝP² where - fuzzyEq η (UnitDiskℝP²Polar r φ) (UnitDiskℝP²Polar r' ϕ) - | φ > pi/2, ϕ < -pi/2 = fuzzyEq η (UnitDiskℝP²Polar r $ φ - 2*pi) (UnitDiskℝP²Polar r' ϕ) - | ϕ > pi/2, φ < -pi/2 = fuzzyEq η (UnitDiskℝP²Polar r φ) (UnitDiskℝP²Polar r' $ ϕ - 2*pi) - | r < 1 = abs (r - r') < η && abs (φ - ϕ) * r < η - | φ > pi/4, ϕ < -pi/4 = fuzzyEq η (UnitDiskℝP²Polar 1 $ φ - pi) (UnitDiskℝP²Polar 1 ϕ) - | ϕ > pi/4, φ < -pi/4 = fuzzyEq η (UnitDiskℝP²Polar 1 φ) (UnitDiskℝP²Polar 1 $ ϕ - pi) + fuzzyEq η (HemisphereℝP²Polar θ φ) (HemisphereℝP²Polar ϑ ϕ) + | φ > pi/2, ϕ < -pi/2 = fuzzyEq η (HemisphereℝP²Polar θ $ φ - 2*pi) (HemisphereℝP²Polar ϑ ϕ) + | ϕ > pi/2, φ < -pi/2 = fuzzyEq η (HemisphereℝP²Polar θ φ) (HemisphereℝP²Polar ϑ $ ϕ - 2*pi) + | θ < pi/2 = abs (θ - ϑ) < η && abs (φ - ϕ) * θ < η + | φ > pi/4, ϕ < -pi/4 = fuzzyEq η (HemisphereℝP²Polar (pi/2) $ φ - pi) + (HemisphereℝP²Polar (pi/2) ϕ) + | ϕ > pi/4, φ < -pi/4 = fuzzyEq η (HemisphereℝP²Polar (pi/2) φ) + (HemisphereℝP²Polar (pi/2) $ ϕ - pi) | otherwise = abs (φ - ϕ) < η instance (AEq (Interior m), AEq f) => AEq (FibreBundle m f) where