QuadEdge (empty) → 0.2
raw patch · 5 files changed
+405/−0 lines, 5 filesdep +basedep +randomdep +vectorsetup-changed
Dependencies added: base, random, vector
Files
- Data/QuadEdge.hs +292/−0
- Data/QuadEdge/Base.hs +67/−0
- LICENSE +24/−0
- QuadEdge.cabal +20/−0
- Setup.hs +2/−0
+ Data/QuadEdge.hs view
@@ -0,0 +1,292 @@+{-# LANGUAGE RankNTypes, UnicodeSyntax, FlexibleContexts #-}++{- | The quad-edge data structure is commonly used in computational geometry for representing triangulations.+ It represents simultaneously both the map, its dual and mirror image.+ + The fundamental idea behind the quad-edge structure is the recognition that a single edge, in a closed+ polygonal mesh topology, sits between exactly two faces and exactly two vertices. Thus, it can represent+ a dual of the graph simply by reversing the convention on what is a vertex and what is a face.++ The quad-edge data structure is described in the paper by Leonidas J. Guibas and Jorge Stolfi,+ \"Primitives for the manipulation of general subdivisions and the computation of Voronoi diagrams\",+ ACM Transactions on Graphics, 4(2), 1985, 75-123.++ This implementation is based on Stream Fusion and seems to yield similar performance to mutable implementations+ in the ST monad.+-}++module Data.QuadEdge (module Data.QuadEdge, module Data.QuadEdge.Base) where+import Data.QuadEdge.Base+import Prelude hiding (flip, lookup)+import Control.Monad.ST (ST)+import Data.Maybe++import qualified Data.Vector as IV+import qualified Data.Vector.Mutable as MV+import qualified Data.Vector.Generic as GV+import qualified Data.Vector.Generic.Mutable as MGV+import qualified Data.Vector.Fusion.Stream as S++import System.Random ++type QEDS a = IV.Vector (Maybe (Edge a))+type MQEDS s a = MV.MVector s (Maybe (Edge a))++------------------------------------------------------------------------------+-- * Creation++-- | Create an empty QEDS++new ∷ QEDS a+new = GV.empty+++------------------------------------------------------------------------------+-- * Topological modification ++-- | Opens up the QEDS for in-place toplogical modification++mutate ∷ QEDS a → (forall s. MQEDS s a → ST s ()) → QEDS a +mutate q f = GV.modify f q +++-- | Create a group of new edges and open up the QEDS ++mutateNEs ∷ QEDS a → [a] → ([EdgeRef] → forall s. MQEDS s a → ST s ()) → (QEDS a, [EdgeRef])+mutateNEs q xs f = (GV.modify (f es) q2, es)+ where+ es = S.toList es'+ (q2,es') = makeEdges q (S.fromList xs)+++-- | Create a new edge and open up the QEDS++mutateNE ∷ QEDS a → a → (EdgeRef → forall s. MQEDS s a → ST s ()) → (QEDS a, EdgeRef)+mutateNE q x f = (GV.modify (f e) q2, e)+ where+ (q2,e) = makeEdge q x+++-- | The QuadEdge splice operator++spliceM ∷ MQEDS s a → EdgeRef → EdgeRef → ST s ()+spliceM q a b+ | (isPrimal a && isPrimal b) || (isDual a && isDual b) + = do oa ← onextM q a+ if b == flip oa+ then return ()+ else do + ob ← onextM q b+ let x = rot oa+ y = rot ob+ ox ← onextM q x+ oy ← onextM q y+ update a y ob + update b x oa+ update x b oy+ update y a ox++ | otherwise = error "QuadEdge.splice: one primal and one dual edge"++ where++ update (i,r,Normal) _ n = do Just e ← MGV.read q i+ MGV.write q i (Just $ updET e r n)++ update (i,r,Flipped) z _ = do Just e ← MGV.read q i+ MGV.write q i (Just $ updET e (incrDir r) (flip z))++ updET e r v = e { edgeTable = updateET (edgeTable e) r v }++++-- | Delete an edge while in mutate mode++deleteEdgeM ∷ MQEDS s a → EdgeRef → ST s ()+deleteEdgeM q e@(i,_,_) = do+ spliceM q e =<< oprevM q e+ spliceM q s =<< oprevM q s+ MGV.write q i Nothing++ where s = sym e+++------------------------------------------------------------------------------+-- * Edge queries++-- | Return all valid edges in the QEDS++edges ∷ QEDS a → IV.Vector (Edge a)+edges = GV.map fromJust . GV.filter isJust +++-- | Return all valid edge references in the QEDS++edgerefs ∷ QEDS a → IV.Vector EdgeRef+edgerefs q = GV.unfoldr f 0 + where+ f i | i >= GV.length q = Nothing+ | isValid q r = Just (r,i+1)+ | otherwise = f (i+1)++ where+ r = (i,Rot0,Normal)++-- | Look up an edge. The edge must be valid.++getEdge ∷ QEDS a → EdgeRef → Edge a+getEdge q (i,_,_) = let Just e = q GV.! i+ in e++-- | Look up the attributes of an edge. The edge must be valid.++getAttr ∷ QEDS a → EdgeRef → a+getAttr q e = attributes (getEdge q e)+++-- | Return a random valid EdgeRef++randomEdgeRef ∷ RandomGen g => QEDS a → g → (EdgeRef, g)+randomEdgeRef cdt g1 = + case cdt GV.! r of+ Just _ → ((r,Rot0,Normal),g2)+ Nothing → randomEdgeRef cdt g2 ++ where+ (r,g2) = randomR (0, (GV.length cdt) - 1) g1+++-- | Check if an EdgeRef points to an active Edge++isValid ∷ QEDS a → EdgeRef → Bool+isValid q (i,_,_) = isJust $ q GV.! i+++------------------------------------------------------------------------------+-- * Edge updating++updateEdge ∷ QEDS a → EdgeRef → Edge a → QEDS a+updateEdge q (i,_,_) e = GV.modify f q + where+ f v = MGV.write v i (Just e)++updateAttr ∷ QEDS a → EdgeRef → a → QEDS a+updateAttr q (i,_,_) a = GV.modify f q+ where+ f v = do+ Just x ← MGV.read v i+ MGV.write v i (Just x{attributes=a})++------------------------------------------------------------------------------+-- * Alternate edge creation/deletion routines++-- | Delete a set of edges in one pass, using mutate and deleteEdgeM++deleteEdges ∷ QEDS a → S.Stream EdgeRef → QEDS a+deleteEdges q xs = mutate q (\v → S.mapM_ (deleteEdgeM v) xs)+++makeEdges ∷ QEDS a → S.Stream a → (QEDS a, S.Stream EdgeRef)+makeEdges z xs = (qeds, S.fromList $ reverse zs)+ where+ (qeds,zs) = S.foldl f (z,[]) xs+ where+ f (q,es) a = (q2,e:es)+ where + (q2,e) = makeEdge q a+++makeEdge ∷ QEDS a → a → (QEDS a, EdgeRef)+makeEdge q a = (q2,e)+ where+ (i,q2) = append $ \x → Edge{edgeTable=emptyET x, attributes=a}+ e = (i, Rot0, Normal)++ append f = (index, GV.snoc q (Just $ f index))+ where+ index = GV.length q+++------------------------------------------------------------------------------+-- * Adjacency Rings++-- | Returns a stream of adjacent edges using the given Adjacency Operator++ring ∷ QEDS a → (QEDS a → EdgeRef → EdgeRef) → EdgeRef → (S.Stream EdgeRef)+ring q f start@(i,_,_) = S.unfoldr g (Just start)+ where+ g Nothing = Nothing+ g (Just e) | j /= i = Just (e,Just e')+ | otherwise = Just (e, Nothing)+ where+ e'@(j,_,_) = f q e+ ++------------------------------------------------------------------------------+-- * Adjacency Operators++-- | CCW around the origin++onext ∷ QEDS a → EdgeRef → EdgeRef+onext q er@(_,r,f)+ | f == Normal = lookupET r t+ | otherwise = flip . rot $ lookupET (incrDir r) t+ where+ t = edgeTable (getEdge q er)++-- | CW around the origin++oprev ∷ QEDS a → EdgeRef → EdgeRef+oprev = rot `comp` rot ++-- | CCW around the left face+lnext ∷ QEDS a → EdgeRef → EdgeRef+lnext = rot `comp` rotInv ++-- | CW around the left face+lprev ∷ QEDS a → EdgeRef → EdgeRef+lprev = sym `comp` id ++-- | CCW around the right face+rnext ∷ QEDS a → EdgeRef → EdgeRef+rnext = rotInv `comp` rot ++-- | CW around the right face+rprev ∷ QEDS a → EdgeRef → EdgeRef+rprev = id `comp` sym ++-- | CCW around the destination+dnext ∷ QEDS a → EdgeRef → EdgeRef+dnext = sym `comp` sym ++-- | CW around the destination+dprev ∷ QEDS a → EdgeRef → EdgeRef+dprev = rotInv `comp` rotInv ++comp ∷ (EdgeRef → a) → (b → EdgeRef) → QEDS d → b → a+comp g f qeds x = g . onext qeds $ f x++------------------------------------------------------------------------------+-- * Adjacency Operators (ST)++onextM,oprevM,lnextM,lprevM,rnextM,rprevM,dnextM,dprevM ∷ MQEDS s a → EdgeRef → ST s EdgeRef++onextM q (i, r, f) = do Just e ← MGV.read q i+ let t = edgeTable e+ return $ if f == Normal + then lookupET r t+ else flip (rot (lookupET (incrDir r) t))++compM ∷ (EdgeRef → b) → (t → EdgeRef) → MQEDS s a → t → ST s b+compM g f qeds x = do e ← onextM qeds (f x)+ return (g e)++oprevM = rot `compM` rot+lnextM = rot `compM` rotInv+lprevM = sym `compM` id+rnextM = rotInv `compM` rot+rprevM = id `compM` sym+dnextM = sym `compM` sym+dprevM = rotInv `compM` rotInv ++-------
+ Data/QuadEdge/Base.hs view
@@ -0,0 +1,67 @@+-------------------------------------------------------------------------------+-- Copyright (C) 1997, 1998, 2008 Joern Dinkla, www.dinkla.net+-------------------------------------------------------------------------------++module Data.QuadEdge.Base where++import Prelude hiding (flip)++++type Index = Int++data Edge a = Edge { edgeTable :: EdgeTable, + attributes :: a } deriving (Eq, Show, Read)++type EdgeRef = (Index, Direction, Orientation)+type EdgeTable = (EdgeRef, EdgeRef, EdgeRef, EdgeRef)++data Direction = Rot0 | Rot1 | Rot2 | Rot3 deriving (Eq, Ord, Enum, Show, Read)+data Orientation = Normal | Flipped deriving (Eq, Ord, Enum, Show, Read)+++incrDir, decrDir :: Direction -> Direction+incrDir x = case x of { Rot0 -> Rot1; Rot1 -> Rot2; + Rot2 -> Rot3; Rot3 -> Rot0 }+decrDir x = case x of { Rot0 -> Rot3; Rot1 -> Rot0; + Rot2 -> Rot1; Rot3 -> Rot2 }++edgesET :: EdgeTable -> [EdgeRef]+edgesET (a,b,c,d) = [a,b,c,d]++emptyET :: Index -> EdgeTable+emptyET i = (mk Rot0, mk Rot3, mk Rot2, mk Rot1)+ where mk r = (i, r, Normal)++lookupET :: Direction -> EdgeTable -> EdgeRef+lookupET Rot0 (x,_,_,_) = x+lookupET Rot1 (_,x,_,_) = x+lookupET Rot2 (_,_,x,_) = x+lookupET Rot3 (_,_,_,x) = x++updateET :: EdgeTable -> Direction -> EdgeRef -> EdgeTable+updateET (_,b,c,d) Rot0 v = (v,b,c,d)+updateET (a,_,c,d) Rot1 v = (a,v,c,d)+updateET (a,b,_,d) Rot2 v = (a,b,v,d)+updateET (a,b,c,_) Rot3 v = (a,b,c,v)++isPrimal, isDual :: EdgeRef -> Bool+isPrimal (_, r, _) = r == Rot0 || r == Rot2+isDual (_, r, _) = r == Rot1 || r == Rot3++isFlipped :: EdgeRef -> Bool+isFlipped (_, _, f) = f == Flipped++rot, sym, rotInv, flip :: EdgeRef -> EdgeRef+rot (e, r, Normal) = (e, incrDir r, Normal)+rot (e, r, Flipped) = (e, decrDir r, Flipped)++rotInv (i, r, Normal) = (i, decrDir r, Normal)+rotInv (i, r, Flipped) = (i, incrDir r, Flipped)++sym = rot . rot++flip (e, r, Normal) = (e, r, Flipped)+flip (e, r, Flipped) = (e, r, Normal)++
+ LICENSE view
@@ -0,0 +1,24 @@+Copyright (c) 2010, Neal Alexander <NHAlxr@gmail.com>+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+ * Neither the name of the <organization> nor the+ names of its contributors may be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ QuadEdge.cabal view
@@ -0,0 +1,20 @@+Name: QuadEdge+Version: 0.2+Synopsis: QuadEdge structure for representing triangulations+License: BSD3+License-file: LICENSE+Author: Neal Alexander+Maintainer: NHAlxr@gmail.com+Category: Data+Build-Type: Simple+Cabal-Version: >=1.6+ +Library+ Build-Depends: base >= 3 && < 5, random >= 1, vector >= 0.6+ Exposed-modules: Data.QuadEdge, Data.QuadEdge.Base+ ghc-options: -Wall -Odph++source-repository head+ type: darcs+ location: http://code.haskell.org/~hexpuem/QuadEdge+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain