DGraph.hs

{-# 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)