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.

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
 

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²

manifolds-core/Math/Manifold/Core/Types/Internal.hs

@@ -30,25 +30,28 @@ 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, π[@.
                   , φParamS² :: !Double -- ^ Range @[-π, π[@.
                   } 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)

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) ~ ℝ)

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

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