module Data.Graph.DGraph where
import Data.List (foldl')
import Data.Hashable
import qualified Data.HashMap.Lazy as HM
import Test.QuickCheck
import Data.Graph.Types
import qualified Data.Graph.UGraph as UG
newtype DGraph v e = DGraph { unDGraph :: HM.HashMap v (Links v e) }
deriving (Eq, Show)
instance Graph DGraph where
empty = DGraph HM.empty
order (DGraph g) = HM.size g
vertices (DGraph g) = HM.keys g
edgePairs = arcs'
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))
(vertices g)
directlyReachableVertices (DGraph g) v = v : (HM.keys $ getLinks v g)
vertexDegree g v = vertexIndegree g v + vertexOutdegree g v
insertVertex (DGraph g) v = DGraph $ hashMapInsert v HM.empty g
insertVertices = foldl' insertVertex
containsEdgePair = containsArc'
incidentEdgePairs g v = fmap toPair $ incidentArcs g v
insertEdgePair g (v1, v2) = insertArc (Arc v1 v2 ()) g
removeEdgePair = removeArc'
removeEdgePairAndVertices = removeArcAndVertices'
isSimple = undefined
isRegular = undefined
fromAdjacencyMatrix = undefined
toAdjacencyMatrix = undefined
type DegreeSequence = [(Int, Int)]
instance (Arbitrary v, Arbitrary e, Hashable v, Num v, Ord v)
=> Arbitrary (DGraph v e) where
arbitrary = insertArcs <$> arbitrary <*> pure empty
removeVertex :: (Hashable v, Eq v) => v -> DGraph v e -> DGraph v e
removeVertex v g = DGraph
$ (\(DGraph g') -> HM.delete v g')
$ foldl' removeArc g $ incidentArcs g v
insertArc :: (Hashable v, Eq v) => Arc v e -> DGraph v e -> DGraph v e
insertArc (Arc fromV toV edgeAttr) g = DGraph
$ HM.adjust (insertLink toV edgeAttr) fromV g'
where g' = unDGraph $ insertVertices g [fromV, toV]
insertArcs :: (Hashable v, Eq v) => [Arc v e] -> DGraph v e -> DGraph v e
insertArcs as g = foldl' (flip insertArc) g as
removeArc :: (Hashable v, Eq v) => DGraph v e -> Arc v e -> DGraph v e
removeArc g = removeEdgePair g . toPair
removeArc' :: (Hashable v, Eq v) => DGraph v e -> (v, v) -> DGraph v e
removeArc' (DGraph g) (v1, v2) = case HM.lookup v1 g of
Nothing -> DGraph g
Just v1Links -> DGraph $ HM.adjust (const v1Links') v1 g
where v1Links' = HM.delete v2 v1Links
removeArcAndVertices :: (Hashable v, Eq v) => DGraph v e -> Arc v e -> DGraph v e
removeArcAndVertices g = removeEdgePairAndVertices g . toPair
removeArcAndVertices' :: (Hashable v, Eq v) => DGraph v e -> (v, v) -> DGraph v e
removeArcAndVertices' g (v1, v2) =
removeVertex v2 $ removeVertex v1 $ removeEdgePair g (v1, v2)
arcs :: forall v e . (Hashable v, Eq v) => DGraph v e -> [Arc v e]
arcs (DGraph g) = linksToArcs $ zip vs links
where
vs :: [v]
vs = vertices $ DGraph g
links :: [Links v e]
links = fmap (`getLinks` g) vs
arcs' :: (Hashable v, Eq v) => DGraph v e -> [(v, v)]
arcs' g = toPair <$> arcs g
containsArc :: (Hashable v, Eq v) => DGraph v e -> Arc v e -> Bool
containsArc g = containsArc' g . toPair
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
inboundingArcs :: (Hashable v, Eq v) => DGraph v e -> v -> [Arc v e]
inboundingArcs g v = filter (\(Arc _ toV _) -> v == toV) $ arcs g
outboundingArcs :: (Hashable v, Eq v) => DGraph v e -> v -> [Arc v e]
outboundingArcs g v = filter (\(Arc fromV _ _) -> v == fromV) $ arcs g
incidentArcs :: (Hashable v, Eq v) => DGraph v e -> v -> [Arc v e]
incidentArcs g v = inboundingArcs g v ++ outboundingArcs g v
isSymmetric :: DGraph v e -> Bool
isSymmetric = undefined
isOriented :: DGraph v e -> Bool
isOriented = undefined
vertexIndegree :: DGraph v e -> v -> Int
vertexIndegree = undefined
vertexOutdegree :: DGraph v e -> v -> Int
vertexOutdegree = undefined
indegrees :: DGraph v e -> [Int]
indegrees = undefined
outdegrees :: DGraph v e -> [Int]
outdegrees = undefined
isBalanced :: DGraph v e -> Bool
isBalanced g = sum (indegrees g) == sum (outdegrees g)
isRegular :: DGraph v e -> Bool
isRegular _ = undefined
isSource :: DGraph v e -> v -> Bool
isSource g v = vertexIndegree g v == 0
isSink :: DGraph v e -> v -> Bool
isSink g v = vertexOutdegree g v == 0
isInternal :: DGraph v e -> v -> Bool
isInternal g v = not $ isSource g v || isSink g v
toUndirected :: (Hashable v, Eq v) => DGraph v e -> UG.UGraph v e
toUndirected g = UG.insertEdges (fmap arcToEdge $ arcs g) empty
where arcToEdge (Arc fromV toV attr) = Edge fromV toV attr
isDirectedGraphic :: DegreeSequence -> Bool
isDirectedGraphic = undefined