From 2c2ea34474cb833c8301534f1f441096a5cc4ffd Mon Sep 17 00:00:00 2001 From: Frank Staals Date: Sat, 16 Nov 2024 23:34:27 +0100 Subject: [PATCH] creating a graph from connected segments --- .../Plane/LowerEnvelope/Connected/Graph.hs | 14 +- .../LowerEnvelope/Connected/MonoidalMap.hs | 21 ++- hgeometry/src/HGeometry/PlaneGraph.hs | 1 + hgeometry/src/HGeometry/PlaneGraph/Type.hs | 123 +++++++----------- 4 files changed, 66 insertions(+), 93 deletions(-) diff --git a/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Graph.hs b/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Graph.hs index 8f135299b..85e69e3a2 100644 --- a/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Graph.hs +++ b/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) diff --git a/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/MonoidalMap.hs b/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/MonoidalMap.hs index 0e0118c23..a6fca3202 100644 --- a/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/MonoidalMap.hs +++ b/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 diff --git a/hgeometry/src/HGeometry/PlaneGraph.hs b/hgeometry/src/HGeometry/PlaneGraph.hs index 75e7595a6..81b5fc0a0 100644 --- a/hgeometry/src/HGeometry/PlaneGraph.hs +++ b/hgeometry/src/HGeometry/PlaneGraph.hs @@ -14,6 +14,7 @@ module HGeometry.PlaneGraph , module Hiraffe.PlanarGraph.Class , PlaneGraph(..) , fromAdjacencyRep + , fromConnectedSegments ) where import HGeometry.PlaneGraph.Class diff --git a/hgeometry/src/HGeometry/PlaneGraph/Type.hs b/hgeometry/src/HGeometry/PlaneGraph/Type.hs index 138203803..891ce8c3e 100644 --- a/hgeometry/src/HGeometry/PlaneGraph/Type.hs +++ b/hgeometry/src/HGeometry/PlaneGraph/Type.hs @@ -14,22 +14,31 @@ 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(..) @@ -37,6 +46,8 @@ import Hiraffe.PlanarGraph ( PlanarGraph, World(..) ) import qualified Hiraffe.PlanarGraph as PG import Hiraffe.PlanarGraph.Class +import qualified Hiraffe.PlanarGraph.Dart as Dart + -------------------------------------------------------------------------------- -- * The PlaneGraph type @@ -184,10 +195,10 @@ 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 @@ -195,63 +206,37 @@ fromConnectedSegments :: ( Foldable1 f, Ord r, Num r , 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)