From 30aa8d3b326c97045a3dbac58b3189f8b86410e6 Mon Sep 17 00:00:00 2001 From: Frank Staals Date: Tue, 23 Jul 2024 19:59:50 +0200 Subject: [PATCH] cleaning up things --- hgeometry/hgeometry.cabal | 3 +- .../Plane/LowerEnvelope/BatchedPointLoc.hs | 6 +- .../Plane/LowerEnvelope/Connected/Regions.hs | 61 ++++++++++++++++- .../Plane/LowerEnvelope/Triangulate.hs | 65 ------------------- 4 files changed, 65 insertions(+), 70 deletions(-) delete mode 100644 hgeometry/src/HGeometry/Plane/LowerEnvelope/Triangulate.hs diff --git a/hgeometry/hgeometry.cabal b/hgeometry/hgeometry.cabal index 344220907..2b6a20e57 100644 --- a/hgeometry/hgeometry.cabal +++ b/hgeometry/hgeometry.cabal @@ -29,8 +29,7 @@ data-files: test-with-ipe/**/*.ipe tested-with: - GHC == 9.6.5 - , GHC == 9.8.2 + GHC == 9.8.2 , GHC == 9.10.1 source-repository head diff --git a/hgeometry/src/HGeometry/Plane/LowerEnvelope/BatchedPointLoc.hs b/hgeometry/src/HGeometry/Plane/LowerEnvelope/BatchedPointLoc.hs index 04dcb321c..5580d2abe 100644 --- a/hgeometry/src/HGeometry/Plane/LowerEnvelope/BatchedPointLoc.hs +++ b/hgeometry/src/HGeometry/Plane/LowerEnvelope/BatchedPointLoc.hs @@ -1,5 +1,5 @@ module HGeometry.LowerEnvelope.BatchedPointLoc - ( batchedPointLocation + ( -- batchedPointLocation ) where import Control.Lens @@ -7,10 +7,11 @@ import qualified Data.Vector as Boxed import HGeometry.Interval import HGeometry.Line import HGeometry.Line.LineEQ -import HGeometry.LowerEnvelope.Type +-- import HGeometry.LowerEnvelope.Type import HGeometry.Point -------------------------------------------------------------------------------- +{- -- | Given a set of n query points and a set of r planes, computes -- an output array A of the planes, and for each query point q an interval [i,j] so that @@ -38,3 +39,4 @@ batchedPointLocation2 :: f (Point 2 r) -> g (LineEQ r) -> ( Boxed.Vector (LineEQ ) batchedPointLocation2 = undefined -- use some sweepline here. so maybe don't report them as a vector +-} diff --git a/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Regions.hs b/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Regions.hs index 6668c4eef..fed31f69d 100644 --- a/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Regions.hs +++ b/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Regions.hs @@ -28,6 +28,8 @@ module HGeometry.Plane.LowerEnvelope.Connected.Regions , intersectionPoint , intersectionLine + + , toPlaneGraph ) where import Control.Lens @@ -38,6 +40,7 @@ import qualified Data.List.NonEmpty as NonEmpty import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe, listToMaybe) +import Data.Semigroup (First(..)) -- import Data.Sequence (Seq) -- import qualified Data.Sequence as Seq import Data.Set (Set) @@ -460,7 +463,7 @@ unionsWithKey :: (Foldable f, Ord k) => (k -> a-> a ->a) -> f (Map k a) -> Map unionsWithKey f = F.foldl' (Map.unionWithKey f) Map.empty -- | Merge the maps. When they share a key, combine their values using a semigroup. -mapWithKeyMerge :: (Ord k, Ord k', Semigroup v') +mapWithKeyMerge :: (Ord k', Semigroup v') => (k -> v -> Map k' v') -> Map k v -> Map k' v' mapWithKeyMerge f = getMap . Map.foldMapWithKey (\k v -> MonoidalMap $ f k v) @@ -474,3 +477,59 @@ instance (Ord k, Semigroup v) => Semigroup (MonoidalMap k v) where instance (Ord k, Semigroup v) => Monoid (MonoidalMap k v) where mempty = MonoidalMap mempty + + +-------------------------------------------------------------------------------- + +-- -- | Triangulate the regions. Note that unbounded regions are somewhat weird now +-- triangulate :: Region r plane -> [Region r plane] +-- triangulate region = case region of +-- Bounded vertices -> case vertices of +-- (v0:v1:vs) -> zipWith (\u v -> Bounded [v0,u,v]) (v1:vs) vs +-- _ -> error "triangulate: absurd, <2 vertices" +-- Unbounded v vertices w -> case vertices of +-- [_] -> [region] +-- [_,_] -> [region] +-- (v0:v1:vs) -> let w = List.last vs +-- in Unbounded v [v0,w] vs : zipWith (\u v -> Bounded [v0,u,v]) (v1:vs) vs + + +-- | A Plane graph storing vertices of type v that are identified by keys of type k, and +-- some ordered sequence of edges (which are ordered using e). +type PlaneGraph 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 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) + => MinimizationDiagram r plane -> PlaneGraph (Point 2 r) (First r) (E r) +toPlaneGraph = mapWithKeyMerge toTriangulatedGr + +toTriangulatedGr :: (Plane_ plane r, Num r, Ord r) + => plane -> Region r (Point 2 r) + -> PlaneGraph (Point 2 r) (First r) (E r) +toTriangulatedGr h = Map.mapWithKey (\v adjs -> (adjs, First $ evalAt v h)) . \case + Bounded vertices -> case vertices of + (v0:v1:vs) -> triangulate v0 v1 vs + _ -> error "triangulate: absurd, <2 vertices" + Unbounded _ vertices _ -> case vertices of + _ :| [] -> Map.empty + u :| [v] -> Map.fromList [ (u, (uncurry Map.singleton $ edge u v)) + , (v, (uncurry Map.singleton $ edge v u)) + ] + v0 :|(v1:vs) -> triangulate v0 v1 vs + where + triangulate v0 v1 vs = Map.unionsWith (<>) $ zipWith (triangle v0) (v1:vs) vs + + triangle u v w = Map.fromList [ (u, Map.fromList [ edge u v, edge u w]) + , (v, Map.fromList [ edge v u, edge v w]) + , (w, Map.fromList [ edge w u, edge w v]) + ] + edge u v = ((E $ v .-. u), v) diff --git a/hgeometry/src/HGeometry/Plane/LowerEnvelope/Triangulate.hs b/hgeometry/src/HGeometry/Plane/LowerEnvelope/Triangulate.hs deleted file mode 100644 index 239aff8d3..000000000 --- a/hgeometry/src/HGeometry/Plane/LowerEnvelope/Triangulate.hs +++ /dev/null @@ -1,65 +0,0 @@ -module HGeometry.LowerEnvelope.Triangulate - ( triangulate - , triangulateFace - ) where - -import Control.Lens -import Data.Function (on) -import Data.Ord (comparing) -import qualified Data.Vector as Boxed -import HGeometry.Foldable.Sort -import HGeometry.LowerEnvelope.Type - --------------------------------------------------------------------------------- - --- | Triangulates all faces. --- --- \(O(n \log n)\) - -triangulate :: ( Foldable g, Applicative g - , Ord r, Num r - , Monoid (g (HalfEdge r)) - , Cons (g (HalfEdge r)) (g (HalfEdge r)) (HalfEdge r) (HalfEdge r) - ) => LowerEnvelope f g r -> LowerEnvelope f Boxed.Vector r -triangulate = over halfEdges triangulateFaces' - --- | Given some --- --- \(O(n \log n)\) -triangulateFaces' :: ( Foldable f, Applicative f - , Ord r, Num r - , Monoid (f (HalfEdge r)) - , Cons (f (HalfEdge r)) (f (HalfEdge r)) (HalfEdge r) (HalfEdge r) - ) => f (HalfEdge r) -> Boxed.Vector (HalfEdge r) -triangulateFaces' = sortBy aroundOrigins . foldMap triangulateFace . edgesByFace - - --- | triangulate a convex face -triangulateFace :: ( Foldable f - , Applicative f - , Monoid (f (HalfEdge r)) - , Cons (f (HalfEdge r)) (f (HalfEdge r)) (HalfEdge r) (HalfEdge r) - ) - => f (HalfEdge r) -- ^ the edges in CCW order along the face - -> f (HalfEdge r) -triangulateFace face = foldMap mkEdge rest'' <> face - where - Just (e0,rest) = uncons face -- - Just (_ ,rest') = uncons rest -- the face has at least 2 vertices, so this should be safe - rest'' = rest' -- FIXME - -- Just (_, rest'') = unsnoc rest' -- TODO: if rest does not exist we area lready a triangle - u = e0^.origin - h = e0^.leftPlane - mkEdge e = pure (HalfEdge u (e^.origin) h) <> pure (HalfEdge (e^.origin) u h) - --- we may want to make sure that the f we use here is a VectorBuilder, --- so that it is cheap to produce the output f. - --- | collect all edges by the plane defining them. -edgesByFace :: ( Foldable f, Ord r) - => f (HalfEdge r) -> [Boxed.Vector (HalfEdge r)] -edgesByFace = groupOn (^.leftPlane) . sortBy (comparing (^.leftPlane)) - --- | Group a bunch of consecutive elements b -groupOn :: Ord b => (a -> b) -> Boxed.Vector a -> [Boxed.Vector a] -groupOn f = Boxed.groupBy ((==) `on` f)