module Data.PlanarGraph( Arc(..)
, Direction(..), rev
, Dart(..), arc, direction
, twin, isPositive
, World(..)
, Dual
, VertexId(..)
, PlanarGraph
, embedding, vertexData, dartData, faceData
, edgeData
, planarGraph, planarGraph'
, numVertices, numDarts, numEdges, numFaces
, darts', darts, edges', edges, vertices', vertices, faces', faces
, tailOf, headOf, endPoints
, incidentEdges, incomingEdges, outgoingEdges, neighboursOf
, vDataOf, eDataOf, fDataOf, endPointDataOf, endPointData
, dual
, FaceId(..)
, leftFace, rightFace, boundary
) where
import Control.Lens
import Control.Monad (forM_)
import Data.Permutation
import qualified Data.Vector as V
import qualified Data.Foldable as F
import qualified Data.Vector.Mutable as MV
newtype Arc s = Arc { _unArc :: Int } deriving (Eq,Ord,Enum,Bounded)
instance Show (Arc s) where
show (Arc i) = "Arc " ++ show i
data Direction = Negative | Positive deriving (Eq,Ord,Bounded,Enum)
instance Show Direction where
show Positive = "+1"
show Negative = "-1"
instance Read Direction where
readsPrec _ "-1" = [(Negative,"")]
readsPrec _ "+1" = [(Positive,"")]
readsPrec _ _ = []
rev :: Direction -> Direction
rev Negative = Positive
rev Positive = Negative
data Dart s = Dart { _arc :: !(Arc s)
, _direction :: !Direction
} deriving (Eq,Ord)
makeLenses ''Dart
instance Show (Dart s) where
show (Dart a d) = "Dart (" ++ show a ++ ") " ++ show d
twin :: Dart s -> Dart s
twin (Dart a d) = Dart a (rev d)
isPositive :: Dart s -> Bool
isPositive d = d^.direction == Positive
instance Enum (Dart s) where
toEnum x
| even x = Dart (Arc $ x `div` 2) Positive
| otherwise = Dart (Arc $ (x `div` 2) + 1) Negative
fromEnum (Dart (Arc i) d) = case d of
Positive -> 2*i
Negative -> 2*i + 1
data World = Primal_ | Dual_ deriving (Show,Eq)
type family Dual (sp :: World) where
Dual Primal_ = Dual_
Dual Dual_ = Primal_
newtype VertexId s (w :: World) = VertexId { _unVertexId :: Int } deriving (Eq,Ord,Enum)
instance Show (VertexId s w) where
show (VertexId i) = "VertexId " ++ show i
data PlanarGraph s (w :: World) v e f = PlanarGraph { _embedding :: Permutation (Dart s)
, _vertexData :: V.Vector v
, _rawDartData :: V.Vector e
, _faceData :: V.Vector f
}
deriving (Show,Eq)
makeLenses ''PlanarGraph
dartData :: Lens (PlanarGraph s w v e f) (PlanarGraph s w v e' f)
(V.Vector (Dart s, e)) (V.Vector (Dart s, e'))
dartData = lens darts (\g xs -> g&rawDartData .~ reorderEdgeData xs)
edgeData :: Lens (PlanarGraph s w v e f) (PlanarGraph s w v e' f)
(V.Vector (Dart s, e)) (V.Vector (Dart s, e'))
edgeData = dartData
reorderEdgeData :: Foldable f => f (Dart s, e) -> V.Vector e
reorderEdgeData ds = V.create $ do
v <- MV.new (F.length ds)
forM_ (F.toList ds) $ \(d,x) ->
MV.write v (fromEnum d) x
pure v
planarGraph :: Permutation (Dart s) -> PlanarGraph s Primal_ () () ()
planarGraph perm = PlanarGraph perm vData eData fData
where
d = size perm
e = d `div` 2
v = V.length (perm^.orbits)
f = e v + 2
vData = V.replicate v ()
eData = V.replicate d ()
fData = V.replicate f ()
planarGraph' :: [[(Dart s,e)]] -> PlanarGraph s Primal_ () e ()
planarGraph' ds = (planarGraph perm)&dartData .~ (V.fromList . concat $ ds)
where
n = sum . map length $ ds
perm = toCycleRep n $ map (map fst) ds
numVertices :: PlanarGraph s w v e f -> Int
numVertices g = V.length (g^.embedding.orbits)
numDarts :: PlanarGraph s w v e f -> Int
numDarts g = size (g^.embedding)
numEdges :: PlanarGraph s w v e f -> Int
numEdges g = numDarts g `div` 2
numFaces :: PlanarGraph s w v e f -> Int
numFaces g = numEdges g numVertices g + 2
vertices' :: PlanarGraph s w v e f -> V.Vector (VertexId s w)
vertices' g = VertexId <$> V.enumFromN 0 (V.length (g^.embedding.orbits))
vertices :: PlanarGraph s w v e f -> V.Vector (VertexId s w, v)
vertices g = V.zip (vertices' g) (g^.vertexData)
darts' :: PlanarGraph s w v e f -> V.Vector (Dart s)
darts' = elems . _embedding
darts :: PlanarGraph s w v e f -> V.Vector (Dart s, e)
darts g = (\d -> (d,g^.eDataOf d)) <$> darts' g
edges' :: PlanarGraph s w v e f -> V.Vector (Dart s)
edges' = V.filter isPositive . darts'
edges :: PlanarGraph s w v e f -> V.Vector (Dart s, e)
edges = V.filter (isPositive . fst) . darts
tailOf :: Dart s -> PlanarGraph s w v e f -> VertexId s w
tailOf d g = VertexId . fst $ lookupIdx (g^.embedding) d
headOf :: Dart s -> PlanarGraph s w v e f -> VertexId s w
headOf d = tailOf (twin d)
endPoints :: Dart s -> PlanarGraph s w v e f -> (VertexId s w, VertexId s w)
endPoints d g = (tailOf d g, headOf d g)
incidentEdges :: VertexId s w -> PlanarGraph s w v e f
-> V.Vector (Dart s)
incidentEdges (VertexId v) g = g^.embedding.orbits.ix' v
incomingEdges :: VertexId s w -> PlanarGraph s w v e f -> V.Vector (Dart s)
incomingEdges v g = V.filter (not . isPositive) $ incidentEdges v g
outgoingEdges :: VertexId s w -> PlanarGraph s w v e f -> V.Vector (Dart s)
outgoingEdges v g = V.filter isPositive $ incidentEdges v g
neighboursOf :: VertexId s w -> PlanarGraph s w v e f -> V.Vector (VertexId s w)
neighboursOf v g = otherVtx <$> incidentEdges v g
where
otherVtx d = let u = tailOf d g in if u == v then headOf d g else u
vDataOf :: VertexId s w -> Lens' (PlanarGraph s w v e f) v
vDataOf (VertexId i) = vertexData.ix' i
eDataOf :: Dart s -> Lens' (PlanarGraph s w v e f) e
eDataOf d = rawDartData.ix' (fromEnum d)
fDataOf :: FaceId s w -> Lens' (PlanarGraph s w v e f) f
fDataOf (FaceId (VertexId i)) = faceData.ix' i
endPointDataOf :: Dart s -> Getter (PlanarGraph s w v e f) (v,v)
endPointDataOf d = to $ endPointData d
endPointData :: Dart s -> PlanarGraph s w v e f -> (v,v)
endPointData d g = let (u,v) = endPoints d g in (g^.vDataOf u, g^.vDataOf v)
dual :: PlanarGraph s w v e f -> PlanarGraph s (Dual w) f e v
dual g = let perm = g^.embedding
in PlanarGraph (cycleRep (elems perm) (apply perm . twin))
(g^.faceData)
(g^.rawDartData)
(g^.vertexData)
newtype FaceId s w = FaceId { _unFaceId :: VertexId s (Dual w) } deriving (Eq,Ord)
instance Show (FaceId s w) where
show (FaceId (VertexId i)) = "FaceId " ++ show i
faces' :: PlanarGraph s w v e f -> V.Vector (FaceId s w)
faces' = fmap FaceId . vertices' . dual
faces :: PlanarGraph s w v e f -> V.Vector (FaceId s w, f)
faces g = V.zip (faces' g) (g^.faceData)
leftFace :: Dart s -> PlanarGraph s w v e f -> FaceId s w
leftFace d g = FaceId . headOf d $ dual g
rightFace :: Dart s -> PlanarGraph s w v e f -> FaceId s w
rightFace d g = FaceId . tailOf d $ dual g
boundary :: FaceId s w -> PlanarGraph s w v e f -> V.Vector (Dart s)
boundary (FaceId v) g = incidentEdges v $ dual g
testPerm :: Permutation (Dart s)
testPerm = let (a:b:c:d:e:g:_) = take 6 [Arc 0..]
in toCycleRep 12 [ [ Dart a Negative
, Dart c Positive
, Dart b Positive
, Dart a Positive
]
, [ Dart e Negative
, Dart b Negative
, Dart d Negative
, Dart g Positive
]
, [ Dart e Positive
, Dart d Positive
, Dart c Negative
]
, [ Dart g Negative
]
]
data Test
testG :: PlanarGraph Test Primal_ () String ()
testG = planarGraph' [ [ (Dart aA Negative, "a-")
, (Dart aC Positive, "c+")
, (Dart aB Positive, "b+")
, (Dart aA Positive, "a+")
]
, [ (Dart aE Negative, "e-")
, (Dart aB Negative, "b-")
, (Dart aD Negative, "d-")
, (Dart aG Positive, "g+")
]
, [ (Dart aE Positive, "e+")
, (Dart aD Positive, "d+")
, (Dart aC Negative, "c-")
]
, [ (Dart aG Negative, "g-")
]
]
where
(aA:aB:aC:aD:aE:aG:_) = take 6 [Arc 0..]