Rendering Geojson polygons :)

hgeometry-combinatorial/src/HGeometry/Cyclic.hs

@@ -24,7 +24,7 @@ import           Control.DeepSeq (NFData)
 import           Control.Lens
 import           Control.Monad (forM_)
 import qualified Data.Foldable as F
-import           Data.Functor.Apply (Apply, (<.*>), (<*.>), MaybeApply(..))
+import           Data.Functor.Apply (Apply, (<.*>), MaybeApply(..))
 import qualified Data.List.NonEmpty as NonEmpty
 import           Data.Maybe (isJust)
 import           Data.Semigroup.Foldable
@@ -75,6 +75,9 @@ instance (Index (v a) ~ Int, Foldable v, Ixed (v a)) => Ixed (Cyclic v a) where
   ix i = \f (Cyclic v) -> let n  = F.length v
                           in Cyclic <$> ix (i `mod` n) f v
 
+instance Reversing (v a) => Reversing (Cyclic v a) where
+  reversing (Cyclic v) = Cyclic (reversing v)
+
 -- | Turn the cyclic vector into a circular Vector
 toCircularVector            :: Cyclic NV.NonEmptyVector a -> CircularVector a
 toCircularVector (Cyclic v) = CircularVector v 0

hgeometry-combinatorial/src/HGeometry/Sequence/NonEmpty.hs

@@ -96,6 +96,9 @@ instance IsList (ViewL1 a) where
   fromList = maybe (error "ViewL1 fromList; empty List") fromNonEmpty . NonEmpty.nonEmpty
   {-# INLINE fromList #-}
 
+instance Reversing (ViewL1 a) where
+  reversing (x :<< s) = viewl1 $ Sequence.reverse s :>> x
+
 --------------------------------------------------------------------------------
 
 -- | NonEmpty ViewR
@@ -161,6 +164,10 @@ instance IsList (ViewR1 a) where
   fromList = maybe (error "ViewR1 fromList; empty List") fromNonEmpty . NonEmpty.nonEmpty
   {-# INLINE fromList #-}
 
+instance Reversing (ViewR1 a) where
+  reversing (s :>> x) = viewr1 $ x :<< Sequence.reverse s
+
+
 -- | snoc an element to the right
 (|>>) :: ViewR1 a -> a -> ViewR1 a
 (ys :>> y) |>> x = (ys :|> y) :>> x

hgeometry-examples/geojson/Main.hs

@@ -9,6 +9,7 @@ import           HGeometry.GeoJSON
 import           HGeometry.Point
 import           HGeometry.Polygon.Class
 import           HGeometry.Polygon.Simple
+import           HGeometry.Polygon.WithHoles
 -- import           HGeometry.Vector ()
 import           Ipe
 import           Paths_hgeometry_examples
@@ -21,23 +22,15 @@ type R = Double
 parseGeoJSONFile :: OsPath -> IO (Either String (GeoFeatureCollection Value))
 parseGeoJSONFile = fmap eitherDecode . File.readFile
 
-
--- toPolygon :: IpeOut GeoPolygon Ipe.Path R
--- toPolygon = ipePolygon . fromMaybe (error "failed") . toPolygon'
-
--- toPolygon' :: GeoPolygon -> Maybe (SimplePolygon (Point 2 R))
--- toPolygon' = fromPoints . view (vertices.asPoint)
-
-
 main :: IO ()
 main = do
   res <- parseGeoJSONFile [osp|data/ne_110m_admin_1_states_provinces_shp.geojson|]
   case res of
     Left err          -> print err
     Right fCollection -> do
-      mapM_ print $ fCollection^..geofeatures.traverse.geometry._Polygon
-      -- let outFp = [osp|foo.ipe|]
-      --     out   = [ iO $ toPolygon pg
-      --             | pg <- fCollection^..geofeatures.traverse.geometry._Polygon
-      --             ]
-      -- writeIpeFile outFp . singlePageFromContent $ out
+      let pgs = fCollection^..geofeatures.traverse.geometry._Polygon._GeoPolygonPolygonalDomain
+      let outFp = [osp|foo.ipe|]
+          out   = [ iO $ ipePolygon pg
+                  | pg <- pgs
+                  ]
+      writeIpeFile outFp . singlePageFromContent $ out

hgeometry/geojson/src/HGeometry/GeoJSON.hs

@@ -3,6 +3,9 @@ module HGeometry.GeoJSON
   ( GeoPositionWithoutCRS'
   , RestGeoPosition(..)
   , _GeoPositionWithoutCRS
+
+
+  , _GeoPolygonPolygonalDomain
   ) where
 
 import           Control.Lens
@@ -157,11 +160,36 @@ _UncheckedRingSimplePolygon' = _RingViewL1
 _UncheckedRingSimplePolygon :: Iso' (LinearRing GeoPositionWithoutCRS)
                                     (SimplePolygonF (Cyclic ViewL1) GeoPositionWithoutCRS')
 _UncheckedRingSimplePolygon  = _UncheckedRingSimplePolygon' . convert
+
+-- | Convert the points
+convert :: Iso'  (SimplePolygonF (Cyclic ViewL1) GeoPositionWithoutCRS)
+                 (SimplePolygonF (Cyclic ViewL1) GeoPositionWithoutCRS')
+convert = iso (over vertices (view _GeoPositionWithoutCRS'))
+              (over vertices (view $ from _GeoPositionWithoutCRS'))
+
+
+-- | Treat a LinearRing as a simple polygon
+_InnerRingSimplePolygon :: Iso' (LinearRing GeoPositionWithoutCRS)
+                                (SimplePolygonF (Cyclic ViewL1) GeoPositionWithoutCRS')
+_InnerRingSimplePolygon  = _RingViewL1 . reversed . from _UncheckedSimplePolygon . convert
+
+-- | Helper type
+type GeoPolygonalDomain = PolygonalDomainF Seq (Cyclic ViewL1) GeoPositionWithoutCRS'
+
+-- | Interpret the GeoPolygon as a Polygonal domain
+_GeoPolygonPolygonalDomain :: Iso' GeoPolygon GeoPolygonalDomain
+_GeoPolygonPolygonalDomain = iso toPD fromPD
   where
-    convert :: Iso'  (SimplePolygonF (Cyclic ViewL1) GeoPositionWithoutCRS)
-                     (SimplePolygonF (Cyclic ViewL1) GeoPositionWithoutCRS')
-    convert = iso (over vertices (view _GeoPositionWithoutCRS'))
-                  (over vertices (view $ from _GeoPositionWithoutCRS'))
+    toPD (GeoPolygon rings) = case rings of
+      Seq.Empty          -> error "invalid"
+      (outer :<| inners) ->  PolygonalDomain (outer^._UncheckedRingSimplePolygon)
+                                             (inners&traversed %~ view _InnerRingSimplePolygon)
+
+    fromPD (PolygonalDomain outer inners) =
+      let outer'  = outer^.from _UncheckedRingSimplePolygon
+          inners' = inners&traversed %~ review _UncheckedRingSimplePolygon
+      in GeoPolygon $ outer' <| inners'
+
 
 -- --------------------------------------------------------------------------------
 

hgeometry/ipe/src/Ipe/IpeOut.hs

@@ -16,7 +16,7 @@
 --------------------------------------------------------------------------------
 module Ipe.IpeOut where
 
-import           Control.Lens hiding (Simple)
+import           Control.Lens hiding (Simple, holes)
 import           Data.Foldable (toList)
 import           Data.Kind
 import           Data.List.NonEmpty (NonEmpty(..))
@@ -29,15 +29,18 @@ import           HGeometry.BezierSpline
 import           HGeometry.Box
 import           HGeometry.Ellipse (Ellipse, circleToEllipse)
 import           HGeometry.Ext
+import           HGeometry.Foldable.Util
 import           HGeometry.HalfLine
 import           HGeometry.Intersection
 import           HGeometry.Line
 import           HGeometry.LineSegment
 import           HGeometry.Number.Radical
 import           HGeometry.Point
 import           HGeometry.PolyLine
+import           HGeometry.Polygon
 import           HGeometry.Polygon.Convex
 import           HGeometry.Polygon.Simple
+import           HGeometry.Polygon.WithHoles
 import           HGeometry.Properties
 import           Ipe.Attributes
 import           Ipe.Color (IpeColor(..))
@@ -163,9 +166,12 @@ instance HasDefaultIpeOut (SimplePolygon (Point 2 r)) where
   type DefaultIpeOut (SimplePolygon (Point 2 r)) = Path
   defIO = ipePolygon
 
--- instance HasDefaultIpeOut (SomePolygon p r) where
---   type DefaultIpeOut (SomePolygon p r) = Path
---   defIO = either defIO defIO
+instance (HoleContainer h f (Point 2 r)
+         , HasFromFoldable1 f
+         )
+       => HasDefaultIpeOut (PolygonalDomainF h f (Point 2 r)) where
+  type DefaultIpeOut (PolygonalDomainF h f (Point 2 r)) = Path
+  defIO = ipePolygon
 
 instance HasDefaultIpeOut (ConvexPolygon (Point 2 r)) where
   type DefaultIpeOut (ConvexPolygon (Point 2 r)) = Path
@@ -286,18 +292,30 @@ pathSegment = PolyLineSegment . fmap (^.asPoint) . lineSegmentToPolyLine
   where
     lineSegmentToPolyLine s = polyLineFromPoints . NonEmpty.fromList $ [s^.start, s^.end]
 
+-- | Render as a polygon
+ipePolygon    :: Polygon_ polygon point r => IpeOut polygon Path r
+ipePolygon pg = Path (outer <| inners) :+ mempty
+  where
+    outer  = toPolygonPathSegment pg
+    inners = toPolygonPathSegment <$> toSequenceOf holes pg
+    toSequenceOf l = foldMapOf l Seq.singleton
+
+-- | Helper type to build a path segment
+toPolygonPathSegment :: ( HasOuterBoundary polygon, Point_ point 2 r, Vertex polygon ~ point)
+                     => polygon -> PathSegment r
+toPolygonPathSegment = PolygonPath . uncheckedFromCCWPoints
+                     . toNonEmptyOf (outerBoundary.asPoint)
+  -- this feels a bit silly, I feel we should directly be able to construct
+  -- the polygon just using the outerBoundaryFold, but whatever.
 
 -- | Draw a polygon
-ipePolygon    :: IpeOut (SimplePolygon (Point 2 r)) Path r
-ipePolygon pg = pg^.re _asSimplePolygon :+ mempty
--- (first (const ()) -> pg) = case pg of
---                SimplePolygon{} -> pg^.re _asSimplePolygon :+ mempty
---                -- MultiPolygon{}  -> pg^.re _asMultiPolygon  :+ mempty
+ipeSimplePolygon    :: IpeOut (SimplePolygon (Point 2 r)) Path r
+ipeSimplePolygon pg = pg^.re _asSimplePolygon :+ mempty
 
 
 -- | Draw a Rectangle
 ipeRectangle   :: Num r => IpeOut (Rectangle (Point 2 r)) Path r
-ipeRectangle r = ipePolygon $ uncheckedFromCCWPoints [tl,tr,br,bl]
+ipeRectangle r = ipeSimplePolygon $ uncheckedFromCCWPoints [tl,tr,br,bl]
   where
     Corners tl tr br bl = corners r
 

hgeometry/ipe/src/Ipe/Path.hs

@@ -101,6 +101,8 @@ instance Fractional r => IsTransformable (PathSegment r) where
 -- | A path is a non-empty sequence of PathSegments.
 newtype Path r = Path { _pathSegments :: Seq.Seq (PathSegment r) }
                  deriving (Show,Eq,Functor,Foldable,Traversable)
+                 deriving newtype (Semigroup)
+
 makeLenses ''Path
 
 type instance NumType   (Path r) = r

hgeometry/src/HGeometry/Polygon/Class.hs

@@ -28,6 +28,7 @@ module HGeometry.Polygon.Class
 import Control.Lens hiding (holes)
 import Data.Function (on)
 import Data.Kind (Type)
+import Data.Void
 import HGeometry.Ext
 import HGeometry.Lens.Util
 -- import qualified Data.Functor.Apply as Apply
@@ -228,12 +229,12 @@ type Hole polygon = SimplePolygonF (HoleF polygon) (Vertex polygon)
 -- | Accessing the holes in a polygon (if there are any.)
 --
 -- the default implementation assumes there are no holes
-class HasHoles polygon where
+class VertexContainer (HoleF polygon) (Vertex polygon) => HasHoles polygon where
   {-# MINIMAL #-}
 
   -- | Type we use to index holes.
   type HoleIx polygon :: Type
-  type HoleIx polygon = ()
+  type HoleIx polygon = Void
 
   -- | The functor used in the holes
   type HoleF polygon :: Type -> Type

hgeometry/src/HGeometry/Polygon/WithHoles.hs

@@ -14,8 +14,10 @@
 module HGeometry.Polygon.WithHoles
   ( PolygonalDomainF(PolygonalDomain)
   , PolygonalDomain
+  , asSimplePolygon
   , outerBoundaryPolygon
   , theHoles
+  , HoleContainer
   ) where
 
 import           Control.DeepSeq (NFData)
@@ -142,6 +144,7 @@ type HoleContainer h f point =
   , Index   (h (SimplePolygonF f point)) ~ Int
   , IxValue (h (SimplePolygonF f point)) ~ SimplePolygonF f point
   , Ixed    (h (SimplePolygonF f point))
+  , VertexContainer f point
   )
 
 instance ( HoleContainer h f point
@@ -161,9 +164,7 @@ data VtxIx = Outer {-#UNPACK#-}!Int
 inner :: (Int,Int) -> VtxIx
 inner = uncurry Inner
 
-instance ( HoleContainer h f point
-         , VertexContainer f point
-         ) => HasVertices' (PolygonalDomainF h f point) where
+instance HoleContainer h f point => HasVertices' (PolygonalDomainF h f point) where
   type Vertex   (PolygonalDomainF h f point) = point
   type VertexIx (PolygonalDomainF h f point) = VtxIx
 
@@ -173,7 +174,7 @@ instance ( HoleContainer h f point
 
   numVertices pg = numVertices (pg^.outerBoundaryPolygon) + sumOf (holes.to numVertices) pg
 
-instance ( HoleContainer h f point, VertexContainer f point
+instance ( HoleContainer h f point
          ) => HasOuterBoundary (PolygonalDomainF h f point) where
   outerBoundary        = reindexed Outer $ outerBoundaryPolygon .> outerBoundary
   ccwOuterBoundaryFrom = \case
@@ -203,7 +204,6 @@ mapEdge (u,v) = (Outer u, Outer v)
 
 instance ( Point_ point 2 r
          , HasFromFoldable1 f
-         , VertexContainer f point
          , HoleContainer h f point
          ) => Polygon_ (PolygonalDomainF h f point) point r where
   extremes u = extremes u . view outerBoundaryPolygon
@@ -240,3 +240,14 @@ instance Semigroup Monoid where
   mempty = Intersect Outside
 
 -}
+
+--------------------------------------------------------------------------------
+
+
+-- | interpret a simple polygon as a Polygonal domain.
+asSimplePolygon :: (HasFromFoldable h, HoleContainer h f point)
+                 => Prism' (PolygonalDomainF h f point) (SimplePolygonF f point)
+asSimplePolygon = prism' (flip PolygonalDomain (fromList []))
+                         (\pd -> if nullOf holes pd then Just (pd^.outerBoundaryPolygon)
+                                 else Nothing
+                         )

hgeometry/test-with-ipe/test/HalfPlane/CommonIntersectionSpec.hs

@@ -144,7 +144,7 @@ myIpeTest input = [ iO $ draw $ commonIntersection input
 asConstraint    :: forall r. (Fractional r, Ord r)
                 => IpeOut (HalfPlane r) Group r
 asConstraint h = ipeGroup [ iO $ defIO seg
-                          , iO $ ipePolygon poly ! attr SFill gray
+                          , iO $ ipeSimplePolygon poly ! attr SFill gray
                           ]
   where
     l = h^.boundingHyperPlane

hgeometry/test-with-ipe/test/PlaneGraph/RenderSpec.hs

@@ -149,7 +149,7 @@ offset s = translateBy theOffset s
 drawFace         :: ( PlaneGraph_ planeGraph vertex, Point_ vertex 2 r
                     , Show (Face planeGraph), Ord r, Fractional r)
                  => planeGraph -> FaceIx planeGraph -> SimplePolygon (vertex :+ VertexIx planeGraph) -> [IpeObject r]
-drawFace gr f pg = [ iO $ ipePolygon pg' ! attr SLayer "face"
+drawFace gr f pg = [ iO $ ipeSimplePolygon pg' ! attr SLayer "face"
                    , iO $ ipeLabel (tshow (gr^?!faceAt f) :+ c) ! attr SLayer "faceLabel"
                    ]
   where