{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Graph.DGraph 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 graph@(DGraph _ g) (v1, v2) =
containsVertex graph v1 && containsVertex graph v2 && v2 `HM.member` v1Links
where v1Links = 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 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
-- | 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 are also 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
-- | Both inbounding and outbounding arcs
incidentArcs :: (Hashable v, Eq v) => DGraph v e -> v -> [Arc v e]
incidentArcs g v = inboundingArcs g v ++ outboundingArcs g v
-- | Tell if a 'DGraph' is symmetric
-- | All of its 'Arc's are bidirected
isSymmetric :: DGraph v e -> Bool
isSymmetric = undefined
-- | Tell if a 'DGraph' is oriented
-- | There are none bidirected 'Arc's
-- | Note: This is /not/ the opposite of 'isSymmetric'
isOriented :: DGraph v e -> Bool
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' ) $ 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' ) $ 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 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 a @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
-- * Transformations
-- | 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
-- * Lists
-- | Convert a 'DGraph' to a list of 'Arc's
-- | Same as 'arcs'
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 printing
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)