{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} module Data.Graph.DGraph ( -- * DGraph data type DGraph -- * Functions on DGraph , insertArc , insertArcs , removeArc , removeArcs , removeArcAndVertices , arcs , containsArc , inboundingArcs , outboundingArcs , incidentArcs , vertexIndegree , vertexOutdegree , indegrees , outdegrees -- ** Query graph properties and characteristics , isSymmetric , isOriented , isBalanced , isRegular , isSource , isSink , isInternal -- ** Transformations , transpose , toUndirected -- * List conversions , toArcsList , fromArcsList -- * Pretty printing , prettyPrint ) where import Data.List (foldl', intersect) import Data.Semigroup import GHC.Generics (Generic) import Control.DeepSeq import Data.Hashable import qualified Data.HashMap.Lazy as HM import Test.QuickCheck import Text.Read import Data.Graph.Internal import Data.Graph.Types 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 , unDGraph :: HM.HashMap v (Links v e) } deriving (Eq, Generic) instance (Hashable v, Eq v, Show v, Show e) => Show (DGraph v e) where showsPrec d m = showParen (d > 10) $ showString "fromList " . shows (toList m) instance (Hashable v, Eq v, Read v, Read e) => Read (DGraph v e) where readPrec = parens $ prec 10 $ do Ident "fromList" <- lexP xs <- readPrec return (fromList xs) instance (Hashable v, Eq v) => Monoid (DGraph v e) where mempty = empty mappend = union instance (Hashable v, Eq v) => Semigroup (DGraph v e) where (<>) = mappend instance (Hashable v, Eq v) => Functor (DGraph v) where fmap f (DGraph s g) = DGraph s $ fmap (fmap f) g instance (Hashable v, Eq v) => Foldable (DGraph v) where foldMap f g = foldMap f $ fmap attribute $ arcs g foldr f acc g = foldr f acc $ fmap attribute $ arcs g instance (NFData v, NFData e) => NFData (DGraph v e) instance Graph DGraph where empty = DGraph 0 HM.empty order (DGraph _ g) = HM.size g size (DGraph s _) = s vertices (DGraph _ g) = HM.keys g edgeTriples g = toTriple <$> arcs g edgeTriple (DGraph _ g) v1 v2 = let mAttr = HM.lookup v2 $ getLinks v1 g in case mAttr of Just attr -> Just (v1, v2, attr) Nothing -> Nothing 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' -> containsEdgePair g (v, v') || containsEdgePair g (v', v)) (vertices g) adjacentVertices' g v = filter (\(fromV, toV, _) -> fromV == v || toV == v) (toTriple <$> toArcsList g) reachableAdjacentVertices (DGraph _ g) v = HM.keys (getLinks v g) reachableAdjacentVertices' g v = filter (\(fromV, _, _) -> fromV == v) (toTriple <$> toArcsList 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 (DGraph _ g) (v1, v2) = v2 `HM.member` (getLinks v1 g) incidentEdgeTriples g v = toTriple <$> 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) union g1 g2 = insertArcs (toArcsList g1) $ insertVertices (vertices g1) g2 intersection g1 g2 = insertVertices (isolatedVertices g1 `intersect` isolatedVertices g2) $ fromArcsList (toArcsList g1 `intersect` toArcsList g2) toList (DGraph _ g) = zip vs $ fmap (\v -> HM.toList $ getLinks v g) vs where vs = HM.keys g fromAdjacencyMatrix m | length m /= length (head m) = Nothing | otherwise = Just $ insertArcs (foldl' genArcs [] labeledM) empty where labeledM :: [(Int, [(Int, Int)])] labeledM = zip [1..] $ fmap (zip [1..]) m genArcs :: [Arc Int ()] -> (Int, [(Int, Int)]) -> [Arc Int ()] genArcs as (i, vs) = as ++ fmap (\v -> Arc i v ()) connected where connected = fst <$> filter (\(_, v) -> v /= 0) vs toAdjacencyMatrix = undefined instance (Arbitrary v, Arbitrary e, Hashable v, Num v, Ord v) => Arbitrary (DGraph v e) where arbitrary = insertArcs <$> arbitrary <*> pure empty -- | 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 gets 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 -- | 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 -- | 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 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 -- | Remove the directed 'Arc' from a 'DGraph' if present. The involved vertices -- also get removed removeArcAndVertices :: (Hashable v, Eq v) => Arc v e -> DGraph v e -> DGraph v e removeArcAndVertices = removeEdgePairAndVertices . toPair -- | 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 vs :: [v] vs = vertices $ DGraph s g links :: [Links v e] links = fmap (`getLinks` g) vs -- | Tell if a directed 'Arc' exists in the graph containsArc :: (Hashable v, Eq v) => DGraph v e -> Arc v e -> Bool 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] inboundingArcs g v = filter (\(Arc _ toV _) -> v == toV) $ arcs g -- | Retrieve the outbounding 'Arc's of a Vertex outboundingArcs :: (Hashable v, Eq v) => DGraph v e -> v -> [Arc v e] outboundingArcs g v = filter (\(Arc fromV _ _) -> v == fromV) $ arcs g -- | Retrieve the incident 'Arc's of a Vertex -- -- The @incident@ arcs of a vertex are all the inbounding and outbounding arcs -- of the vertex incidentArcs :: (Hashable v, Eq v) => DGraph v e -> v -> [Arc v e] incidentArcs g v = inboundingArcs g v ++ outboundingArcs g v -- | Indegree of a vertex -- -- The @indegree@ of a vertex is 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' ) $ edgePairs g -- | Outdegree of a vertex -- -- The @outdegree@ of a vertex is 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' ) $ edgePairs g -- | Indegrees of all the vertices in a 'DGraph' indegrees :: (Hashable v, Eq v) => DGraph v e -> [Int] 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 = vertexOutdegree g <$> vertices g -- | Tell if a 'DGraph' is symmetric -- -- A directed graph is @symmetric@ if all of its 'Arc's are bi-directed isSymmetric :: DGraph v e -> Bool isSymmetric = undefined -- | Tell if a 'DGraph' is oriented -- -- A directed graph is @oriented@ if there are none bi-directed 'Arc's -- -- Note: This is /not/ the opposite of 'isSymmetric' isOriented :: DGraph v e -> Bool isOriented = undefined -- | Tell if a 'DGraph' is balanced -- -- A directed graph is @balanced@ when its @indegree = outdegree@ isBalanced :: (Hashable v, Eq v) => DGraph v e -> Bool isBalanced g = sum (indegrees g) == sum (outdegrees g) -- | Tell if a 'DGraph' is regular -- -- A directed graph is @regular@ when all of its vertices have the same number -- of adjacent vertices /AND/ when the @indegree@ and @outdegree@ of each vertex -- are equal to each other. isRegular :: DGraph v e -> Bool isRegular _ = undefined -- | Tell if a vertex is a source -- -- A vertex is a @source@ when its @indegree = 0@ isSource :: (Hashable v, Eq v) => DGraph v e -> v -> Bool isSource g v = vertexIndegree g v == 0 -- | Tell if a vertex is a sink -- -- A vertex is a @sink@ when its @outdegree = 0@ isSink :: (Hashable v, Eq v) => DGraph v e -> v -> Bool isSink g v = vertexOutdegree g v == 0 -- | Tell if a vertex is internal -- -- A vertex is @internal@ when its neither a @source@ nor a @sink@ isInternal :: (Hashable v, Eq v) => DGraph v e -> v -> Bool isInternal g v = not $ isSource g v || isSink g v -- | Get the transpose of a 'DGraph' -- -- 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 (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 (arcToEdge <$> arcs g) empty where arcToEdge (Arc fromV toV attr) = Edge fromV toV attr -- | Convert a 'DGraph' to a list of 'Arc's discarding isolated vertices -- -- Note that because 'toArcsList' discards isolated vertices: -- -- > fromArcsList . toArcsList /= id toArcsList :: (Hashable v, Eq v) => DGraph v e -> [Arc v e] toArcsList = arcs -- | Construct a 'DGraph' from a list of 'Arc's fromArcsList :: (Hashable v, Eq v) => [Arc v e] -> DGraph v e fromArcsList as = insertArcs as empty -- | Pretty print a 'DGraph' prettyPrint :: (Hashable v, Eq v, Show v, Show e) => DGraph v e -> String prettyPrint g = "Isolated Vertices: " <> show (filter (\v -> vertexDegree g v == 0) $ vertices g) <> " " <> "Arcs: " <> show (arcs g)