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 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' -> containsEdgePair g (v, v') || containsEdgePair g (v', v))
(vertices 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)
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
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)
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
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) => [Arc v e] -> DGraph v e -> DGraph v e
insertArcs as g = foldl' (flip insertArc) g as
removeArc :: (Hashable v, Eq v) => Arc v e -> DGraph v e -> DGraph v e
removeArc = removeEdgePair . toPair
removeArcs :: (Hashable v, Eq v) => [Arc v e] -> DGraph v e -> DGraph v e
removeArcs as g = foldl' (flip removeArc) g as
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
containsArc :: (Hashable v, Eq v) => DGraph v e -> Arc v e -> Bool
containsArc g = containsEdgePair g . toPair
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' ) $ edgePairs g
vertexOutdegree :: (Hashable v, Eq v) => DGraph v e -> v -> Int
vertexOutdegree g v = length $ filter (\(v', _) -> v == v' ) $ edgePairs g
indegrees :: (Hashable v, Eq v) => DGraph v e -> [Int]
indegrees g = vertexIndegree g <$> vertices g
outdegrees :: (Hashable v, Eq v) => DGraph v e -> [Int]
outdegrees g = 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 (reverseArc <$> arcs g) empty
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 (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 as = insertArcs as empty