module Data.Graph.DGraph where
import Data.List (foldl')
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.Types
import qualified Data.Graph.UGraph as UG
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 (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
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 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'
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)
fromAdjacencyMatrix m
| length m /= length (head m) = Nothing
| otherwise = Just $ insertArcs empty (foldl' genArcs [] labeledM)
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 <$> pure empty <*> arbitrary
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
insertArcs :: (Hashable v, Eq v) => DGraph v e -> [Arc v e] -> DGraph v e
insertArcs g as = foldl' (flip insertArc) g as
removeArc :: (Hashable v, Eq v) => Arc v e -> DGraph v e -> DGraph v e
removeArc = removeEdgePair . toPair
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
removeArcAndVertices :: (Hashable v, Eq v) => Arc v e -> DGraph v e -> DGraph v e
removeArcAndVertices = removeEdgePairAndVertices . toPair
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
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 :: (Hashable v, Eq v) => DGraph v e -> v -> Int
vertexIndegree g v = length $ filter (\(_, v') -> v == v' ) $ arcs' g
vertexOutdegree :: (Hashable v, Eq v) => DGraph v e -> v -> Int
vertexOutdegree g v = length $ filter (\(v', _) -> v == v' ) $ arcs' g
indegrees :: (Hashable v, Eq v) => DGraph v e -> [Int]
indegrees g = fmap (vertexIndegree g) $ vertices g
outdegrees :: (Hashable v, Eq v) => DGraph v e -> [Int]
outdegrees g = fmap (vertexOutdegree g) $ vertices g
isBalanced :: (Hashable v, Eq v) => DGraph v e -> Bool
isBalanced g = sum (indegrees g) == sum (outdegrees g)
isRegular :: DGraph v e -> Bool
isRegular _ = undefined
isSource :: (Hashable v, Eq v) => DGraph v e -> v -> Bool
isSource g v = vertexIndegree g v == 0
isSink :: (Hashable v, Eq v) => DGraph v e -> v -> Bool
isSink g v = vertexOutdegree g v == 0
isInternal :: (Hashable v, Eq v) => DGraph v e -> v -> Bool
isInternal g v = not $ isSource g v || isSink g v
transpose :: (Hashable v, Eq v) => DGraph v e -> DGraph v e
transpose g = insertArcs empty (fmap reverseArc $ arcs g)
where reverseArc (Arc fromV toV attr) = Arc toV fromV attr
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
toList :: (Hashable v, Eq v) => DGraph v e -> [Arc v e]
toList = arcs
fromList :: (Hashable v, Eq v) => [Arc v e] -> DGraph v e
fromList = insertArcs empty