summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDanielCampoverde <>2017-10-11 20:49:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-10-11 20:49:00 (GMT)
commit06119fce87d3ad99470e8c74a058f5f3e6397ce8 (patch)
treebcb8cc3e0581821eceb87a05d424aae6499a988f
parent961dc98ce5e6a83ad394a6afb7bf84b1fdb183fd (diff)
version 0.7.0.00.7.0.0
-rw-r--r--graphite.cabal3
-rw-r--r--src/Data/Graph/Connectivity.hs6
-rw-r--r--src/Data/Graph/DGraph.hs105
-rw-r--r--src/Data/Graph/Generation.hs2
-rw-r--r--src/Data/Graph/Read.hs6
-rw-r--r--src/Data/Graph/Types.hs66
-rw-r--r--src/Data/Graph/UGraph.hs69
-rw-r--r--src/Data/Graph/UGraph/DegreeSequence.hs2
-rw-r--r--src/Data/Graph/Visualize.hs10
-rw-r--r--src/Scratch.hs73
10 files changed, 155 insertions, 187 deletions
diff --git a/graphite.cabal b/graphite.cabal
index d4fbba7..814396d 100644
--- a/graphite.cabal
+++ b/graphite.cabal
@@ -1,5 +1,5 @@
name: graphite
-version: 0.5.0.2
+version: 0.7.0.0
synopsis: Graphs and networks library
description: Represent, analyze and visualize graphs
homepage: https://github.com/alx741/graphite#readme
@@ -25,7 +25,6 @@ library
, Data.Graph.DGraph.DegreeSequence
, Data.Graph.UGraph.DegreeSequence
, Data.Graph.Visualize
- other-modules: Scratch
build-depends: base >= 4.7 && < 5
, QuickCheck
, bytestring
diff --git a/src/Data/Graph/Connectivity.hs b/src/Data/Graph/Connectivity.hs
index 1a592de..79a62c1 100644
--- a/src/Data/Graph/Connectivity.hs
+++ b/src/Data/Graph/Connectivity.hs
@@ -24,7 +24,7 @@ areConnected :: forall g v e . (Graph g, Hashable v, Eq v, Ord v)
-> Bool
areConnected g fromV toV
| fromV == toV = True
- | otherwise = search (directlyReachableVertices g fromV) S.empty toV
+ | otherwise = search (fromV : reachableAdjacentVertices g fromV) S.empty toV
where
search :: [v] -> S.Set v -> v -> Bool
search [] _ _ = False
@@ -32,7 +32,7 @@ areConnected g fromV toV
| v `S.member` banned = search vs banned v'
| v == v' = True
| otherwise =
- search (directlyReachableVertices g v) banned' v'
+ search (v : reachableAdjacentVertices g v) banned' v'
|| search vs banned' v'
where banned' = v `S.insert` banned
@@ -84,7 +84,7 @@ isWeaklyConnected = isConnected . toUndirected
-- | A Directed Graph is @strongly connected@ if it contains a directed path
-- | on every pair of vertices
isStronglyConnected :: (Hashable v, Eq v, Ord v) => DGraph v e -> Bool
-isStronglyConnected g = isConnected g
+isStronglyConnected = isConnected
-- TODO
-- * connected component
diff --git a/src/Data/Graph/DGraph.hs b/src/Data/Graph/DGraph.hs
index 27a3da6..28227fb 100644
--- a/src/Data/Graph/DGraph.hs
+++ b/src/Data/Graph/DGraph.hs
@@ -18,7 +18,7 @@ import qualified Data.Graph.UGraph as UG
-- | Directed Graph of Vertices in /v/ and Arcs with attributes in /e/
data DGraph v e = DGraph
- { _size :: Int
+ { _size :: Int
, unDGraph :: HM.HashMap v (Links v e)
} deriving (Eq, Generic)
@@ -39,36 +39,61 @@ instance Graph DGraph where
order (DGraph _ g) = HM.size g
size (DGraph s _) = s
vertices (DGraph _ g) = HM.keys g
- edgePairs = arcs'
+ edgePairs g = toPair <$> arcs g
+
containsVertex (DGraph _ g) = flip HM.member g
+
areAdjacent (DGraph _ g) v1 v2 =
HM.member v2 (getLinks v1 g) || HM.member v1 (getLinks v2 g)
+
adjacentVertices g v = filter
- (\v' -> containsArc' g (v, v') || containsArc' g (v', v))
+ (\v' -> containsEdgePair g (v, v') || containsEdgePair g (v', v))
(vertices g)
- directlyReachableVertices (DGraph _ g) v = v : (HM.keys $ getLinks v g)
+
+ adjacentVertices' g v = fmap
+ (\(fromV, toV, e) -> if fromV == v then (toV, e) else (fromV, e)) $
+ filter
+ (\(fromV, toV, _) -> fromV == v || toV == v)
+ (toTriple <$> toList g)
+
+ reachableAdjacentVertices (DGraph _ g) v = HM.keys (getLinks v g)
+
+ reachableAdjacentVertices' g v = fmap (\(_, toV, e) -> (toV, e)) $
+ filter
+ (\(fromV, _, _) -> fromV == v)
+ (toTriple <$> toList g)
-- | The total number of inbounding and outbounding 'Arc's of a vertex
vertexDegree g v = vertexIndegree g v + vertexOutdegree g v
insertVertex v (DGraph s g) = DGraph s $ hashMapInsert v HM.empty g
- containsEdgePair = containsArc'
- incidentEdgePairs g v = fmap toPair $ incidentArcs g v
- insertEdgePair (v1, v2) g = insertArc (Arc v1 v2 ()) g
- removeEdgePair = removeArc'
+ containsEdgePair graph@(DGraph _ g) (v1, v2) =
+ containsVertex graph v1 && containsVertex graph v2 && v2 `HM.member` v1Links
+ where v1Links = getLinks v1 g
+
+
+ incidentEdgePairs g v = toPair <$> incidentArcs g v
+ insertEdgeTriple (v1, v2, e) = insertArc (Arc v1 v2 e)
+
+ removeEdgePair (v1, v2) graph@(DGraph s g)
+ | containsEdgePair graph (v1, v2) =
+ DGraph (s - 1) $ HM.adjust (const v1Links') v1 g
+ | otherwise = graph
+ where v1Links' = HM.delete v2 $ getLinks v1 g
+
removeVertex v g@(DGraph s _) = DGraph s
$ (\(DGraph _ g') -> HM.delete v g')
$ foldl' (flip removeArc) g $ incidentArcs g v
isSimple g = foldl' go True $ vertices g
- where go bool v = bool && (not $ HM.member v $ getLinks v $ unDGraph g)
+ where go bool v = bool && not (HM.member v $ getLinks v $ unDGraph g)
fromAdjacencyMatrix m
| length m /= length (head m) = Nothing
- | otherwise = Just $ insertArcs empty (foldl' genArcs [] labeledM)
+ | otherwise = Just $ insertArcs (foldl' genArcs [] labeledM) empty
where
labeledM :: [(Int, [(Int, Int)])]
labeledM = zip [1..] $ fmap (zip [1..]) m
@@ -81,41 +106,36 @@ instance Graph DGraph where
instance (Arbitrary v, Arbitrary e, Hashable v, Num v, Ord v)
=> Arbitrary (DGraph v e) where
- arbitrary = insertArcs <$> pure empty <*> arbitrary
+ arbitrary = insertArcs <$> arbitrary <*> pure empty
--- | @O(log n)@ Insert a directed 'Arc' into a 'DGraph'
--- | The involved vertices are inserted if don't exist. If the graph already
--- | contains the Arc, its attribute is updated
+-- | Insert a directed 'Arc' into a 'DGraph'
+-- | The involved vertices are inserted if they don't exist. If the graph
+-- | already contains the Arc, its attribute is updated
insertArc :: (Hashable v, Eq v) => Arc v e -> DGraph v e -> DGraph v e
insertArc (Arc fromV toV edgeAttr) g@(DGraph s _)
| containsEdgePair g (fromV, toV) = g
| otherwise = DGraph (s + 1) $ HM.adjust (insertLink toV edgeAttr) fromV g'
where g' = unDGraph $ insertVertices [fromV, toV] g
--- | @O(m*log n)@ Insert many directed 'Arc's into a 'DGraph'
--- | Same rules as 'insertArc' are applied
-insertArcs :: (Hashable v, Eq v) => DGraph v e -> [Arc v e] -> DGraph v e
-insertArcs g as = foldl' (flip insertArc) g as
+-- | Same as 'insertArc' but for a list of 'Arc's
+insertArcs :: (Hashable v, Eq v) => [Arc v e] -> DGraph v e -> DGraph v e
+insertArcs as g = foldl' (flip insertArc) g as
--- | @O(log n)@ Remove the directed 'Arc' from a 'DGraph' if present
+-- | Remove the directed 'Arc' from a 'DGraph' if present
-- | The involved vertices are left untouched
removeArc :: (Hashable v, Eq v) => Arc v e -> DGraph v e -> DGraph v e
removeArc = removeEdgePair . toPair
--- | Same as 'removeArc' but the arc is an ordered pair
-removeArc' :: (Hashable v, Eq v) => (v, v) -> DGraph v e -> DGraph v e
-removeArc' (v1, v2) graph@(DGraph s g)
- | containsEdgePair graph (v1, v2) =
- DGraph (s - 1) $ HM.adjust (const v1Links') v1 g
- | otherwise = graph
- where v1Links' = HM.delete v2 $ getLinks v1 g
+-- | Same as 'removeArc' but for a list of 'Arc's
+removeArcs :: (Hashable v, Eq v) => [Arc v e] -> DGraph v e -> DGraph v e
+removeArcs as g = foldl' (flip removeArc) g as
--- | @O(log n)@ Remove the directed 'Arc' from a 'DGraph' if present
+-- | Remove the directed 'Arc' from a 'DGraph' if present
-- | The involved vertices are also removed
removeArcAndVertices :: (Hashable v, Eq v) => Arc v e -> DGraph v e -> DGraph v e
removeArcAndVertices = removeEdgePairAndVertices . toPair
--- | @O(n*m)@ Retrieve the 'Arc's of a 'DGraph'
+-- | Retrieve the 'Arc's of a 'DGraph'
arcs :: forall v e . (Hashable v, Eq v) => DGraph v e -> [Arc v e]
arcs (DGraph s g) = linksToArcs $ zip vs links
where
@@ -124,20 +144,9 @@ arcs (DGraph s g) = linksToArcs $ zip vs links
links :: [Links v e]
links = fmap (`getLinks` g) vs
--- | Same as 'arcs' but the arcs are ordered pairs, and their attributes are
--- | discarded
-arcs' :: (Hashable v, Eq v) => DGraph v e -> [(v, v)]
-arcs' g = toPair <$> arcs g
-
--- | @O(log n)@ Tell if a directed 'Arc' exists in the graph
+-- | Tell if a directed 'Arc' exists in the graph
containsArc :: (Hashable v, Eq v) => DGraph v e -> Arc v e -> Bool
-containsArc g = containsArc' g . toPair
-
--- | Same as 'containsArc' but the arc is an ordered pair
-containsArc' :: (Hashable v, Eq v) => DGraph v e -> (v, v) -> Bool
-containsArc' graph@(DGraph _ g) (v1, v2) =
- containsVertex graph v1 && containsVertex graph v2 && v2 `HM.member` v1Links
- where v1Links = getLinks v1 g
+containsArc g = containsEdgePair g . toPair
-- | Retrieve the inbounding 'Arc's of a Vertex
inboundingArcs :: (Hashable v, Eq v) => DGraph v e -> v -> [Arc v e]
@@ -166,20 +175,20 @@ isOriented = undefined
-- | Indegree of a vertex
-- | The number of inbounding 'Arc's to a vertex
vertexIndegree :: (Hashable v, Eq v) => DGraph v e -> v -> Int
-vertexIndegree g v = length $ filter (\(_, v') -> v == v' ) $ arcs' g
+vertexIndegree g v = length $ filter (\(_, v') -> v == v' ) $ edgePairs g
-- | Outdegree of a vertex
-- | The number of outbounding 'Arc's from a vertex
vertexOutdegree :: (Hashable v, Eq v) => DGraph v e -> v -> Int
-vertexOutdegree g v = length $ filter (\(v', _) -> v == v' ) $ arcs' g
+vertexOutdegree g v = length $ filter (\(v', _) -> v == v' ) $ edgePairs g
-- | Indegrees of all the vertices in a 'DGraph'
indegrees :: (Hashable v, Eq v) => DGraph v e -> [Int]
-indegrees g = fmap (vertexIndegree g) $ vertices g
+indegrees g = vertexIndegree g <$> vertices g
-- | Outdegree of all the vertices in a 'DGraph'
outdegrees :: (Hashable v, Eq v) => DGraph v e -> [Int]
-outdegrees g = fmap (vertexOutdegree g) $ vertices g
+outdegrees g = vertexOutdegree g <$> vertices g
-- | Tell if a 'DGraph' is balanced
-- | A Directed Graph is @balanced@ when its @indegree = outdegree@
@@ -214,13 +223,13 @@ isInternal g v = not $ isSource g v || isSink g v
-- | The @transpose@ of a directed graph is another directed graph where all of
-- | its arcs are reversed
transpose :: (Hashable v, Eq v) => DGraph v e -> DGraph v e
-transpose g = insertArcs empty (fmap reverseArc $ arcs g)
+transpose g = insertArcs (reverseArc <$> arcs g) empty
where reverseArc (Arc fromV toV attr) = Arc toV fromV attr
-- | Convert a directed 'DGraph' to an undirected 'UGraph' by converting all of
-- | its 'Arc's into 'Edge's
toUndirected :: (Hashable v, Eq v) => DGraph v e -> UG.UGraph v e
-toUndirected g = UG.insertEdges (fmap arcToEdge $ arcs g) empty
+toUndirected g = UG.insertEdges (arcToEdge <$> arcs g) empty
where arcToEdge (Arc fromV toV attr) = Edge fromV toV attr
@@ -233,4 +242,4 @@ toList = arcs
-- | Construct a 'DGraph' from a list of 'Arc's
fromList :: (Hashable v, Eq v) => [Arc v e] -> DGraph v e
-fromList = insertArcs empty
+fromList as = insertArcs as empty
diff --git a/src/Data/Graph/Generation.hs b/src/Data/Graph/Generation.hs
index d9b2809..b10932f 100644
--- a/src/Data/Graph/Generation.hs
+++ b/src/Data/Graph/Generation.hs
@@ -22,7 +22,7 @@ erdosRenyi n p = go [1..n] (probability p) empty
flipDir <- randomRIO (True, False)
let vs' = zip rnds vs
let g' = insertVertex v g
- go vs pv $! (foldl' (putV pv v flipDir) g' vs')
+ go vs pv $! foldl' (putV pv v flipDir) g' vs'
putV :: Graph g => Float -> Int -> Bool -> g Int () -> (Float, Int) -> g Int ()
putV pv v flipDir g (p', v')
diff --git a/src/Data/Graph/Read.hs b/src/Data/Graph/Read.hs
index caa5ddd..44b3c73 100644
--- a/src/Data/Graph/Read.hs
+++ b/src/Data/Graph/Read.hs
@@ -20,11 +20,11 @@ fromCsv fp = do
let dec = decode NoHeader content
case dec of
Left err -> return $ Left err
- Right vec -> return $ Right $ (flip insertEdgePairs) empty $ toEdges $ V.toList vec
+ Right vec -> return $ Right $ flip insertEdgePairs empty $ toEdges $ V.toList vec
where
toEdges :: [[v]] -> [(v, v)]
- toEdges ns = Prelude.concat $ fmap nodeEdges ns
+ toEdges = Prelude.concatMap nodeEdges
nodeEdges :: [v] -> [(v, v)]
nodeEdges [] = []
@@ -39,4 +39,4 @@ fromCsv' fp = do
eitherG <- fromCsv fp
case eitherG of
Left err -> error err
- Right g -> return g
+ Right g -> return g
diff --git a/src/Data/Graph/Types.hs b/src/Data/Graph/Types.hs
index fc72ded..8c4f4fd 100644
--- a/src/Data/Graph/Types.hs
+++ b/src/Data/Graph/Types.hs
@@ -30,7 +30,11 @@ class Graph g where
vertices :: g v e -> [v]
-- | Retrieve the edges of a graph
+ edgeTriples :: (Hashable v, Eq v) => g v e -> [(v, v, e)]
+
+ -- | Retrieve the edges of a graph, ignoring its attributes
edgePairs :: (Hashable v, Eq v) => g v e -> [(v, v)]
+ edgePairs g = tripleToPair <$> edgeTriples g
-- | Tell if a vertex exists in the graph
containsVertex :: (Hashable v, Eq v) => g v e -> v -> Bool
@@ -40,13 +44,24 @@ class Graph g where
-- | Retrieve the adjacent vertices of a vertex
adjacentVertices :: (Hashable v, Eq v) => g v e -> v -> [v]
+ adjacentVertices g v = fst <$> adjacentVertices' g v
+
+ -- | Same as 'adjacentVertices' but pairs the vertex with the connecting
+ -- | edge's attribute
+ adjacentVertices' :: (Hashable v, Eq v) => g v e -> v -> [(v, e)]
+
+ -- | Same as 'adjacentVertices' but gives back only those vertices for which
+ -- | the connecting edge allows the vertex to be reached.
+ -- |
+ -- | For an undirected graph this is equivalent to 'adjacentVertices', but
+ -- | for the case of a directed graph, the directed arcs will constrain the
+ -- | reachability of the adjacent vertices.
+ reachableAdjacentVertices :: (Hashable v, Eq v) => g v e -> v -> [v]
+ reachableAdjacentVertices g v = fst <$> reachableAdjacentVertices' g v
- -- | Retrieve the vertices that are directly reachable from a particular
- -- | vertex.
- -- | A vertex is @directly reachable@ to other if there is an edge that
- -- | connects @from@ one vertex @to@ the other
- -- | Every vertex is directly reachable from itself
- directlyReachableVertices :: (Hashable v, Eq v) => g v e -> v -> [v]
+ -- | Same as 'reachableAdjacentVertices' but pairs the vertex with the
+ -- | connecting edge's attribute
+ reachableAdjacentVertices' :: (Hashable v, Eq v) => g v e -> v -> [(v, e)]
-- | Total number of incident edges of a vertex
vertexDegree :: (Hashable v, Eq v) => g v e -> v -> Int
@@ -65,7 +80,7 @@ class Graph g where
-- | Average degree of a graph
avgDegree :: (Hashable v, Eq v) => g v e -> Double
- avgDegree g = fromIntegral (2 * size g) / (fromIntegral $ order g)
+ avgDegree g = fromIntegral (2 * size g) / fromIntegral (order g)
-- | Density of a graph
-- | The ratio of the number of existing edges in the graph to the number of
@@ -90,14 +105,27 @@ class Graph g where
containsEdgePair :: (Hashable v, Eq v) => g v e -> (v, v) -> Bool
-- | Retrieve the incident edges of a vertex
+ incidentEdgeTriples :: (Hashable v, Eq v) => g v e -> v -> [(v, v, e)]
+
+ -- | Retrieve the incident edges of a vertex, ignoring its attributes
incidentEdgePairs :: (Hashable v, Eq v) => g v e -> v -> [(v, v)]
+ incidentEdgePairs g v = tripleToPair <$> incidentEdgeTriples g v
-- | Insert an edge into a graph
-- | The involved vertices are inserted if don't exist. If the graph already
-- | contains the edge, its attribute is updated
+ insertEdgeTriple :: (Hashable v, Eq v) => (v, v, e) -> g v e -> g v e
+
+ -- | Same as 'insertEdgeTriple' but for multiple edges
+ insertEdgeTriples :: (Hashable v, Eq v) => [(v, v, e)] -> g v e -> g v e
+ insertEdgeTriples es g = foldl' (flip insertEdgeTriple) g es
+
+ -- | Same as 'insertEdgeTriple' but insert edge pairs in graphs with
+ -- | attributeless edges
insertEdgePair :: (Hashable v, Eq v) => (v, v) -> g v () -> g v ()
+ insertEdgePair (v1, v2) = insertEdgeTriple (v1, v2, ())
- -- | Same as 'insertEdgePair' but for multiple edges
+ -- | Same as 'insertEdgePair' for multiple edges
insertEdgePairs :: (Hashable v, Eq v) => [(v, v)] -> g v () -> g v ()
insertEdgePairs es g = foldl' (flip insertEdgePair) g es
@@ -154,6 +182,10 @@ class IsEdge e where
-- | Convert an edge to a pair discargind its attribute
toPair :: e v a -> (v, v)
+ -- | Convert an edge to a triple, where the 3rd element it's the edge
+ -- | attribute
+ toTriple :: e v a -> (v, v, a)
+
-- | Tell if an edge is a loop
-- | An edge forms a @loop@ if both of its ends point to the same vertex
isLoop :: (Eq v) => e v a -> Bool
@@ -163,10 +195,12 @@ instance (NFData v, NFData e) => NFData (Arc v e)
instance IsEdge Edge where
toPair (Edge v1 v2 _) = (v1, v2)
+ toTriple (Edge v1 v2 e) = (v1, v2, e)
isLoop (Edge v1 v2 _) = v1 == v2
instance IsEdge Arc where
toPair (Arc fromV toV _) = (fromV, toV)
+ toTriple (Arc fromV toV e) = (fromV, toV, e)
isLoop (Arc v1 v2 _) = v1 == v2
-- | Weighted Edge attributes
@@ -216,6 +250,10 @@ instance (Eq v, Eq a) => Eq (Edge v a) where
instance (Eq v, Eq a) => Eq (Arc v a) where
(Arc v1 v2 a) == (Arc v1' v2' a') = (a == a') && (v1 == v1' && v2 == v2')
+-- | Convert a triple to a pair by ignoring the third element
+tripleToPair :: (a, b, c) -> (a, b)
+tripleToPair (a, b, _) = (a, b)
+
-- | Edges generator
arbitraryEdge :: (Arbitrary v, Arbitrary e, Ord v, Num v)
=> (v -> v -> e -> edge) -> Gen edge
@@ -245,21 +283,17 @@ getLinks = HM.lookupDefault HM.empty
-- | Get 'Arc's from an association list of vertices and their links
linksToArcs :: [(v, Links v a)] -> [Arc v a]
-linksToArcs ls = concat $ fmap toArc ls
+linksToArcs = concatMap toArc
where
toArc :: (v, Links v a) -> [Arc v a]
- toArc (fromV, links) = fmap (\(v, a) -> Arc fromV v a) (HM.toList links)
+ toArc (fromV, links) = fmap (uncurry (Arc fromV)) (HM.toList links)
-- | Get 'Edge's from an association list of vertices and their links
linksToEdges :: [(v, Links v a)] -> [Edge v a]
-linksToEdges ls = concat $ fmap toEdge ls
+linksToEdges = concatMap toEdge
where
toEdge :: (v, Links v a) -> [Edge v a]
- toEdge (fromV, links) = fmap (\(v, a) -> Edge fromV v a) (HM.toList links)
-
--- | Get 'Edge's from an association list of vertices and their links
-linksToEdges' :: (Eq v) => (v, Links v a) -> [Edge v a]
-linksToEdges' (fromV, links) = fmap (\(v, a) -> Edge fromV v a) (HM.toList links)
+ toEdge (fromV, links) = fmap (uncurry (Edge fromV)) (HM.toList links)
-- | O(log n) Associate the specified value with the specified key in this map.
-- | If this map previously contained a mapping for the key, leave the map
diff --git a/src/Data/Graph/UGraph.hs b/src/Data/Graph/UGraph.hs
index e7a4270..8149d20 100644
--- a/src/Data/Graph/UGraph.hs
+++ b/src/Data/Graph/UGraph.hs
@@ -20,7 +20,7 @@ import Data.Graph.Types
-- | Undirected Graph of Vertices in /v/ and Edges with attributes in /e/
data UGraph v e = UGraph
- { _size :: Int
+ { _size :: Int
, unUGraph :: HM.HashMap v (Links v e)
} deriving (Eq, Generic)
@@ -45,26 +45,39 @@ instance Graph UGraph where
order (UGraph _ g) = HM.size g
size (UGraph s _) = s
vertices (UGraph _ g) = HM.keys g
- edgePairs g = toPair <$> edges g
+ edgeTriples g = toTriple <$> edges g
containsVertex (UGraph _ g) = flip HM.member g
areAdjacent (UGraph _ g) v1 v2 = HM.member v2 $ getLinks v1 g
adjacentVertices (UGraph _ g) v = HM.keys $ getLinks v g
- directlyReachableVertices g v = v : (adjacentVertices g v)
+ adjacentVertices' (UGraph _ g) v = HM.toList $ getLinks v g
+ reachableAdjacentVertices = adjacentVertices
+ reachableAdjacentVertices' = adjacentVertices'
vertexDegree (UGraph _ g) v = length $ HM.keys $ getLinks v g
insertVertex v (UGraph s g) = UGraph s $ hashMapInsert v HM.empty g
- containsEdgePair = containsEdge'
- incidentEdgePairs g v = fmap toPair $ incidentEdges g v
- insertEdgePair (v1, v2) g = insertEdge (Edge v1 v2 ()) g
- removeEdgePair = removeEdge'
+ containsEdgePair graph@(UGraph _ g) (v1, v2) =
+ containsVertex graph v1 && containsVertex graph v2 && v2 `HM.member` v1Links
+ where v1Links = getLinks v1 g
+
+ incidentEdgeTriples g v = toTriple <$> incidentEdges g v
+ insertEdgeTriple (v1, v2, e) = insertEdge (Edge v1 v2 e)
+
+ removeEdgePair (v1, v2) graph@(UGraph s g)
+ | containsEdgePair graph (v1, v2) =
+ UGraph (s - 1) $ update v2Links v2 $ update v1Links v1 g
+ | otherwise = graph
+ where
+ v1Links = HM.delete v2 $ getLinks v1 g
+ v2Links = HM.delete v1 $ getLinks v2 g
+ update = HM.adjust . const
removeVertex v g@(UGraph s _) = UGraph s
$ (\(UGraph _ g') -> HM.delete v g')
$ foldl' (flip removeEdge) g $ incidentEdges g v
isSimple g = foldl' go True $ vertices g
- where go bool v = bool && (not $ HM.member v $ getLinks v $ unUGraph g)
+ where go bool v = bool && not (HM.member v $ getLinks v $ unUGraph g)
fromAdjacencyMatrix m
| length m /= length (head m) = Nothing
@@ -81,9 +94,9 @@ instance Graph UGraph where
--- | @O(log n)@ Insert an undirected 'Edge' into a 'UGraph'
--- | The involved vertices are inserted if don't exist. If the graph already
--- | contains the Edge, its attribute is updated
+-- | Insert an undirected 'Edge' into a 'UGraph'
+-- | The involved vertices are inserted if they don't exist. If the graph
+-- | already contains the Edge, its attribute is updated
insertEdge :: (Hashable v, Eq v) => Edge v e -> UGraph v e -> UGraph v e
insertEdge (Edge v1 v2 edgeAttr) g@(UGraph s _)
| containsEdgePair g (v1, v2) = g
@@ -92,33 +105,25 @@ insertEdge (Edge v1 v2 edgeAttr) g@(UGraph s _)
g' = unUGraph $ insertVertices [v1, v2] g
link fromV toV = HM.adjust (insertLink toV edgeAttr) fromV
--- | @O(m*log n)@ Insert many directed 'Edge's into a 'UGraph'
--- | Same rules as 'insertEdge' are applied
+-- | Same as 'insertEdge' but for a list of 'Edge's
insertEdges :: (Hashable v, Eq v) => [Edge v e] -> UGraph v e -> UGraph v e
insertEdges es g = foldl' (flip insertEdge) g es
--- | @O(log n)@ Remove the undirected 'Edge' from a 'UGraph' if present
+-- | Remove the undirected 'Edge' from a 'UGraph' if present
-- | The involved vertices are left untouched
removeEdge :: (Hashable v, Eq v) => Edge v e -> UGraph v e -> UGraph v e
removeEdge = removeEdgePair . toPair
--- | Same as 'removeEdge' but the edge is an unordered pair
-removeEdge' :: (Hashable v, Eq v) => (v, v) -> UGraph v e -> UGraph v e
-removeEdge' (v1, v2) graph@(UGraph s g)
- | containsEdgePair graph (v1, v2) =
- UGraph (s - 1) $ update v2Links v2 $ update v1Links v1 g
- | otherwise = graph
- where
- v1Links = HM.delete v2 $ getLinks v1 g
- v2Links = HM.delete v1 $ getLinks v2 g
- update = HM.adjust . const
+-- | Same as 'removeEdge' but for a list of 'Edge's
+removeEdges :: (Hashable v, Eq v) => [Edge v e] -> UGraph v e -> UGraph v e
+removeEdges es g = foldl' (flip removeEdge) g es
--- | @O(log n)@ Remove the undirected 'Edge' from a 'UGraph' if present
+-- | Remove the undirected 'Edge' from a 'UGraph' if present
-- | The involved vertices are also removed
removeEdgeAndVertices :: (Hashable v, Eq v) => Edge v e -> UGraph v e -> UGraph v e
removeEdgeAndVertices = removeEdgePairAndVertices . toPair
--- | @O(n*m)@ Retrieve the 'Edge's of a 'UGraph'
+-- | Retrieve the 'Edge's of a 'UGraph'
edges :: forall v e . (Hashable v, Eq v) => UGraph v e -> [Edge v e]
edges g = F.toList $ go g S.empty
where
@@ -127,17 +132,11 @@ edges g = F.toList $ go g S.empty
let v = head $ vertices g'
in go
(removeVertex v g')
- (es S.>< (S.fromList $ incidentEdges g' v))
+ (es S.>< S.fromList (incidentEdges g' v))
--- | @O(log n)@ Tell if an undirected 'Edge' exists in the graph
+-- | Tell if an undirected 'Edge' exists in the graph
containsEdge :: (Hashable v, Eq v) => UGraph v e -> Edge v e -> Bool
-containsEdge g = containsEdge' g . toPair
-
--- | Same as 'containsEdge' but the edge is an unordered pair
-containsEdge' :: (Hashable v, Eq v) => UGraph v e -> (v, v) -> Bool
-containsEdge' graph@(UGraph _ g) (v1, v2) =
- containsVertex graph v1 && containsVertex graph v2 && v2 `HM.member` v1Links
- where v1Links = getLinks v1 g
+containsEdge g = containsEdgePair g . toPair
-- | Retrieve the incident 'Edge's of a Vertex
incidentEdges :: (Hashable v, Eq v) => UGraph v e -> v -> [Edge v e]
diff --git a/src/Data/Graph/UGraph/DegreeSequence.hs b/src/Data/Graph/UGraph/DegreeSequence.hs
index 38e6a9a..fd72494 100644
--- a/src/Data/Graph/UGraph/DegreeSequence.hs
+++ b/src/Data/Graph/UGraph/DegreeSequence.hs
@@ -34,7 +34,7 @@ isGraphicalSequence (DegreeSequence []) = True
isGraphicalSequence (DegreeSequence (x:xs))
| x > length xs = False
| otherwise = isGraphicalSequence $ degreeSequence seq'
- where seq' = (map (subtract 1) $ take x xs) ++ drop x xs
+ where seq' = subtract 1 <$> take x xs ++ drop x xs
-- | Tell if a 'DegreeSequence' is a Directed Graphic
-- | A @Directed Graphic@ is a Degree Sequence for wich a 'DGraph' exists
diff --git a/src/Data/Graph/Visualize.hs b/src/Data/Graph/Visualize.hs
index f2af0c3..e110db1 100644
--- a/src/Data/Graph/Visualize.hs
+++ b/src/Data/Graph/Visualize.hs
@@ -20,7 +20,7 @@ plotUGraph g = runGraphvizCanvas Sfdp (toUndirectedDot g) Xlib
-- | Plot an undirected 'UGraph' to a PNG image file
plotUGraphPng :: (Show e) => UGraph Int e -> FilePath -> IO FilePath
-plotUGraphPng g fp = addExtension (runGraphvizCommand Sfdp $ toUndirectedDot g) Png fp
+plotUGraphPng g = addExtension (runGraphvizCommand Sfdp $ toUndirectedDot g) Png
-- | Plot a directed 'DGraph'
plotDGraph :: (Show e) => DGraph Int e -> IO ()
@@ -28,16 +28,16 @@ plotDGraph g = runGraphvizCanvas Sfdp (toDirectedDot g) Xlib
-- | Plot a directed 'DGraph' to a PNG image file
plotDGraphPng :: (Show e) => DGraph Int e -> FilePath -> IO FilePath
-plotDGraphPng g fp = addExtension (runGraphvizCommand Sfdp $ toDirectedDot g) Png fp
+plotDGraphPng g = addExtension (runGraphvizCommand Sfdp $ toDirectedDot g) Png
labeledNodes :: (Graph g, Show v) => g v e -> [(v, String)]
-labeledNodes g = fmap (\v -> (v, show v)) $ vertices g
+labeledNodes g = (\v -> (v, show v)) <$> vertices g
labeledEdges :: (Hashable v, Eq v, Show e) => UGraph v e -> [(v, v, String)]
-labeledEdges g = fmap (\(Edge v1 v2 attr) -> (v1, v2, show attr)) $ edges g
+labeledEdges g = (\(Edge v1 v2 attr) -> (v1, v2, show attr)) <$> edges g
labeledArcs :: (Hashable v, Eq v, Show e) => DGraph v e -> [(v, v, String)]
-labeledArcs g = fmap (\(Arc v1 v2 attr) -> (v1, v2, show attr)) $ arcs g
+labeledArcs g = (\(Arc v1 v2 attr) -> (v1, v2, show attr)) <$> arcs g
toUndirectedDot :: (Show e) => UGraph Int e -> DotGraph Int
toUndirectedDot g = graphElemsToDot params (labeledNodes g) (labeledEdges g)
diff --git a/src/Scratch.hs b/src/Scratch.hs
deleted file mode 100644
index d286434..0000000
--- a/src/Scratch.hs
+++ /dev/null
@@ -1,73 +0,0 @@
-module Scratch where
-
-import Data.List (foldl')
-
-import qualified Data.Dequeue as Q
-import qualified Data.Set as S
-
-import Data.Graph.Types
-import Data.Graph.UGraph
-
-testG :: UGraph Int ()
-testG = fromList
- [ 1 <-> 2
- , 1 <-> 3
- , 1 <-> 5
- , 2 <-> 1
- , 2 <-> 4
- , 3 <-> 4
- , 3 <-> 6
- , 4 <-> 2
- , 4 <-> 3
- , 4 <-> 5
- , 5 <-> 1
- , 5 <-> 4
- , 5 <-> 6
- , 6 <-> 5
- , 6 <-> 3
- ]
-
-path :: UGraph Int () -> Int -> Int -> [Int]
-path g fromV toV
- | fromV == toV = [toV]
- | otherwise = search [fromV] S.empty []
- where
- search :: [Int] -> S.Set Int -> [Int] -> [Int]
- search (v:vs) banned popped
- | v == toV = popped ++ [v]
- | otherwise =
- let reachables = nonVisitedReachables banned v
- in search
- (vs ++ reachables)
- (setInsertMany banned $ v : reachables)
- (popped ++ [v])
-
- nonVisitedReachables banned v = filter
- (\v' -> v' /= v && (not $ S.member v' banned))
- (directlyReachableVertices g v)
-
-path' :: UGraph Int () -> Int -> Int -> [Int]
-path' g fromV toV
- | fromV == toV = [toV]
- | otherwise = reverse $ search (Q.fromList [fromV]) S.empty []
- where
- search :: Q.BankersDequeue Int -> S.Set Int -> [Int] -> [Int]
- search queue banned popped = case Q.popFront queue of
- Nothing -> popped
- Just (v, queue') -> if v == toV then v : popped else
- let reachables = nonVisitedReachables banned v
- in search
- (queue' `pushBackMany` reachables)
- (setInsertMany banned $ v : reachables)
- (v : popped)
-
- nonVisitedReachables banned v = filter
- (\v' -> v' /= v && (not $ S.member v' banned))
- (directlyReachableVertices g v)
-
-
-setInsertMany :: Ord a => S.Set a -> [a] -> S.Set a
-setInsertMany = foldl' (flip S.insert)
-
-pushBackMany :: Q.BankersDequeue a -> [a] -> Q.BankersDequeue a
-pushBackMany = foldl' Q.pushBack