creating a graph from connected segments

hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Graph.hs

@@ -17,16 +17,16 @@ module HGeometry.Plane.LowerEnvelope.Connected.Graph
 import           Data.List.NonEmpty (NonEmpty(..))
 import           Data.Map (Map)
 import qualified Data.Map as Map
+import qualified Data.Map.NonEmpty as NEMap
 import           Data.Semigroup (First(..))
 import           HGeometry.HyperPlane.Class
 import           HGeometry.HyperPlane.NonVertical
 import           HGeometry.Plane.LowerEnvelope.Connected.MonoidalMap
 import           HGeometry.Plane.LowerEnvelope.Connected.Type
+import           HGeometry.PlaneGraph.Type (E(..))
 import           HGeometry.Point
 import           HGeometry.Vector
 import           Hiraffe.AdjacencyListRep.Map
-import qualified Data.Map.NonEmpty as NEMap
-
 --------------------------------------------------------------------------------
 
 -- | A Plane graph storing vertices of type v that are identified by keys of type k, and
@@ -40,16 +40,6 @@ type PlaneGraph' k v e = GGraph (Map e) k v e
 type PlaneGraphMap k v e = Map k (Map e k, v)
 
 
-
-newtype E r = E (Vector 2 r)
-  deriving newtype (Show)
-
-instance (Ord r, Num r) => Eq (E r) where
-  a == b = a `compare` b == EQ
-instance (Ord r, Num r) => Ord (E r) where
-  (E v) `compare` (E u) = ccwCmpAroundWith (Vector2 0 1) (origin :: Point 2 r) (Point v) (Point u)
-
-
 -- | Produce a triangulated plane graph on the bounded vertices.  every vertex is
 -- represented by its point, it stores a list of its outgoing edges, and some data.
 toPlaneGraph' :: (Plane_ plane r, Num r, Ord r)

hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/MonoidalMap.hs

@@ -1,12 +1,17 @@
 module HGeometry.Plane.LowerEnvelope.Connected.MonoidalMap
-  ( MonoidalMap, getMap
+  ( MonoidalMap(..)
   , unionsWithKey
   , mapWithKeyMerge
+
+  , MonoidalNEMap(..)
   ) where
 
 import qualified Data.Foldable as F
+import           Data.Foldable1
 import           Data.Map (Map)
 import qualified Data.Map as Map
+import           Data.Map.NonEmpty (NEMap)
+import qualified Data.Map.NonEmpty as NEMap
 
 --------------------------------------------------------------------------------
 -- * Operations on Maps
@@ -23,10 +28,22 @@ mapWithKeyMerge f = getMap . Map.foldMapWithKey (\k v -> MonoidalMap $ f k v)
 -- | A Map in which we combine conflicting elements by using their semigroup operation
 -- rather than picking the left value (as is done in the default Data.Map)
 newtype MonoidalMap k v = MonoidalMap { getMap :: Map k v }
-  deriving (Show)
+  deriving stock (Show)
+  deriving newtype (Functor,Foldable)
 
 instance (Ord k, Semigroup v) => Semigroup (MonoidalMap k v) where
   (MonoidalMap ma) <> (MonoidalMap mb) = MonoidalMap $ Map.unionWith (<>) ma mb
 
 instance (Ord k, Semigroup v) => Monoid (MonoidalMap k v) where
   mempty = MonoidalMap mempty
+
+--------------------------------------------------------------------------------
+
+-- | A NonEmpty Map in which we combine conflicting elements by using their semigroup
+-- operation rather than picking the left value (as is done in the default Data.Map)
+newtype MonoidalNEMap k v = MonoidalNEMap { getNEMap :: NEMap k v }
+  deriving stock (Show)
+  deriving newtype (Functor,Foldable,Foldable1)
+
+instance (Ord k, Semigroup v) => Semigroup (MonoidalNEMap k v) where
+  (MonoidalNEMap ma) <> (MonoidalNEMap mb) = MonoidalNEMap $ NEMap.unionWith (<>) ma mb

hgeometry/src/HGeometry/PlaneGraph.hs

@@ -14,6 +14,7 @@ module HGeometry.PlaneGraph
   , module Hiraffe.PlanarGraph.Class
   , PlaneGraph(..)
   , fromAdjacencyRep
+  , fromConnectedSegments
   ) where
 
 import HGeometry.PlaneGraph.Class

hgeometry/src/HGeometry/PlaneGraph/Type.hs

@@ -14,29 +14,40 @@
 module HGeometry.PlaneGraph.Type
   ( PlaneGraph(..)
   , fromAdjacencyRep
+  , fromConnectedSegments
   -- , VertexData(VertexData), location
+
+  , E(..)
   ) where
 
 import           Control.Lens hiding (holes, holesOf, (.=))
 import           Data.Coerce
 import           Data.Foldable1
+import           Data.Foldable1.WithIndex
+import qualified Data.List.NonEmpty as NonEmpty
 import qualified Data.Map as Map
+import qualified Data.Map.NonEmpty as NEMap
 import qualified Data.Vector.NonEmpty as Vector
 import           Data.YAML
 import           GHC.Generics (Generic)
 import           HGeometry.Box
 import           HGeometry.Foldable.Sort (sortBy )
+import           HGeometry.LineSegment
+import           HGeometry.Plane.LowerEnvelope.Connected.MonoidalMap
 import           HGeometry.PlaneGraph.Class
 import           HGeometry.Point
 import           HGeometry.Properties
 import           HGeometry.Transformation
+import           HGeometry.Vector
 import           Hiraffe.AdjacencyListRep.Map
 import           Hiraffe.Graph.Class
 import           Hiraffe.PlanarGraph ( PlanarGraph, World(..)
                                      , DartId, VertexId, FaceId
                                      )
 import qualified Hiraffe.PlanarGraph as PG
 import           Hiraffe.PlanarGraph.Class
+import qualified Hiraffe.PlanarGraph.Dart as Dart
+
 
 --------------------------------------------------------------------------------
 -- * The PlaneGraph type
@@ -184,74 +195,48 @@ instance ( Point_ v 2 r
 
 --------------------------------------------------------------------------------
 
-{-
 -- | Constructs a connected plane graph
 --
 -- pre: The segments form a single connected component
+--      No two segments partially overlap.
 --
 -- running time: \(O(n\log n)\)
 fromConnectedSegments      :: ( Foldable1 f, Ord r, Num r
                               , LineSegment_ lineSegment point
                               , Point_ point 2 r
                               )
                            => f lineSegment
-                           -> PlaneGraph s (NonEmpty.NonEmpty point) lineSegment () r
-fromConnectedSegments segs = PlaneGraph $ planarGraph dts & PG.vertexData .~ vxData
+                           -> PlaneGraph s (NonEmpty.NonEmpty point) lineSegment ()
+fromConnectedSegments segs = PlaneGraph $
+                             (PG.planarGraph theDarts)&PG.vertexData .~ vtxData
   where
-    -- compute the points, with for every point a list of its darts around it
-
-
-
-
-    pts :: NEMap point [(point, (dart, lineSegment))]
-    pts = ifoldMap1 (\i seg -> NEMap.sigleton (seg^.start)
-
-                    ) (toNonEmpty segs)
-
-      -- foldMap1 (\
-
-      --              )
-
-      --   $ NonEmpty.zipWith mkArc (0 :| [1..])
-
-
-
-
-
-
+    -- to get the darts we simply convert the NEMap (_, NEMap _ (dart, seg)) into
+    -- a NonEmpty (NonEmpty (dart, seg))
+    theDarts = toNonEmpty . snd  <$> verts
+    vtxData  = Vector.fromNonEmpty $ fst <$> verts
 
+    -- Collects all edges per vertex
+    verts    = toNonEmpty . ifoldMap1 f $ toNonEmpty segs
 
-    pts         = Map.fromListWith (<>) . concatMap f . zipWith g [0..] . F.toList $ segs
+    -- Creates two vertices with one edge each ; combines them into a single Map
+    f i seg = let u = seg^.start
+                  v = seg^.end
+                  d = Dart.Dart (Dart.Arc i) Dart.Positive
+              in    singleton (u^.asPoint) (vtx (d          ,seg) u v)
+                 <> singleton (v^.asPoint) (vtx (Dart.twin d,seg) v u)
 
+    singleton k v = MonoidalNEMap $ NEMap.singleton k v
 
+-- | Helper type to represent the vertex data of a vertex. The NEMap
+-- represents the edges ordered cyclically around the vertex
+type VtxData v r e = (v, NEMap.NEMap (E r) e)
 
-    f (s :+ e)  = [ ( s^.start.core
-                    , SP (sing $ s^.start.extra) [(s^.end.core)   :+ h Positive e])
-                  , ( s^.end.core
-                    , SP (sing $ s^.end.extra)   [(s^.start.core) :+ h Negative e])
-                  ]
-
-    mkArc i seg = seg :+
-
-    (s :+ e) = s :+ (Arc i :+ e)
-
-
-
-    h d (a :+ e) = (Dart a d, e)
-
-    sing = NonEmpty.singleton
-
-    vts    ::
-    vts    = map (\(p,sp) -> (p,map (^.extra) . sortAround' (ext p) <$> sp))
-           . Map.assocs $ pts
-
-    -- vertex Data
-    vxData = V.fromList . map (\(p,sp) -> VertexData p (sp^._1)) $ vts
-    -- The darts
-    dts    = fmap (^._2._2) vts
-
--}
+-- | Creates the vertex data
+vtx       :: (Point_ point 2 r, Ord r, Num r)
+          => e -> point -> point -> VtxData (NonEmpty.NonEmpty point) r e
+vtx e p q = (NonEmpty.singleton p, NEMap.singleton (E $ q .-. p) e)
 
+--------------------------------------------------------------------------------
 
 -- | Given a connected plane graph in adjacency list format; convert it into an actual
 -- PlaneGraph.
@@ -262,33 +247,13 @@ fromAdjacencyRep       :: (Point_ vertex 2 r, Ord i, Foldable1 f)
 fromAdjacencyRep proxy = PlaneGraph . PG.fromAdjacencyRep proxy
 
 
--- toPlaneGraph proxy (Graph m) = gr&vertexData .~  (\(VertexData x _ _) -> x <$> fromFoldable1 m)
---   where
---     gr = PlaneGraph $ planarGraph theDarts
-
---     vtxData =
-
---     --  a non-empty list of vertices, with for each vertex the darts in order around the vertex
---     theDarts  = evalState (sequence' theDarts) (0 :+ Map.empty)
-
---     theDarts' = toNonEmpty $ imap toIncidentDarts m
---     -- turn the outgoing edges of u into darts
---     toIncidentDarts u (VertexData _ neighMap neighOrder) =
---       (\v -> (toDart u v, neighMap Map.! u)) <$> toNonEmpty neighOrder
---     -- create the dart corresponding to vertices u and v
-
---     toDart u v | u <= v    =  flip Dart Positive <$> arc u v
---                | otherwise =  flip Dart Negative <$> arc v u
-
---     arc u v = gets (arcOf (u,v)) >>= \case
---                 Just a  -> pure a
---                 Nothing -> do a <- nextArc
---                               modify $ insertArc (u,v) a
---                               pure a
+--------------------------------------------------------------------------------
 
---     arcOf x       = Map.lookup x . view extra
---     insertArc k v = over extra $ Map.insert k v
+-- | Helper type to sort vectors cyclically around the origine
+newtype E r = E (Vector 2 r)
+  deriving newtype (Show)
 
---     nextArc = do i <- gets (view core)
---                  modify $ over core (+1)
---                  pure $ Arc i
+instance (Ord r, Num r) => Eq (E r) where
+  a == b = a `compare` b == EQ
+instance (Ord r, Num r) => Ord (E r) where
+  (E v) `compare` (E u) = ccwCmpAroundWith (Vector2 0 1) (origin :: Point 2 r) (Point v) (Point u)