module Graph.Graph (
Graph(..)
, NodeId (..)
, EdgeId (..)
, Node(..)
, Edge(..)
, NodeInContext
, EdgeInContext
, NodeContext
, incidentEdges
, incomingEdges
, outgoingEdges
, Graph.Graph.null
, isNodeOf
, isEdgeOf
, lookupNode
, lookupNodeInContext
, lookupEdge
, lookupEdgeInContext
, isAdjacentTo
, isIncidentTo
, nodesOf
, sourceOf
, sourceOfUnsafe
, targetOf
, targetOfUnsafe
, getIncidentEdges
, empty
, build
, fromNodesAndEdges
, insertNode
, insertNodeWithPayload
, insertEdge
, insertEdgeWithPayload
, removeNode
, removeNodeForced
, removeNodeAndIncidentEdges
, removeEdge
, updateNodePayload
, updateEdgePayload
, nodes
, edges
, nodeIds
, edgeIds
, nodesInContext
, edgesInContext
, newNodes
, newEdges
) where
import Abstract.Cardinality
import Abstract.Valid
import Data.List
import Data.List.Utils
import Data.Maybe (fromJust, fromMaybe)
newtype NodeId =
NodeId Int
deriving (Eq, Ord)
newtype EdgeId
= EdgeId Int
deriving (Eq, Ord)
instance Show NodeId where
show (NodeId i) = show i
instance Show EdgeId where
show (EdgeId i) = show i
instance Num NodeId where
(NodeId x) + (NodeId y) = NodeId (x+y)
(NodeId x) * (NodeId y) = NodeId (x*y)
(NodeId x) - (NodeId y) = NodeId (x-y)
negate (NodeId x) = NodeId (negate x)
signum (NodeId x) = NodeId (signum x)
fromInteger x = NodeId $ fromIntegral x
abs (NodeId x) = NodeId (abs x)
instance Enum NodeId where
toEnum = NodeId
fromEnum (NodeId x) = x
instance Num EdgeId where
(EdgeId x) + (EdgeId y) = EdgeId (x+y)
(EdgeId x) * (EdgeId y) = EdgeId (x*y)
(EdgeId x) - (EdgeId y) = EdgeId (x-y)
negate (EdgeId x) = EdgeId (negate x)
signum (EdgeId x) = EdgeId (signum x)
fromInteger x = EdgeId $ fromIntegral x
abs (EdgeId x) = EdgeId (abs x)
instance Enum EdgeId where
toEnum = EdgeId
fromEnum (EdgeId x) = x
data Node n =
Node
{ nodeId :: NodeId
, nodeInfo :: n
} deriving (Show)
data Edge e =
Edge
{ edgeId :: EdgeId
, sourceId :: NodeId
, targetId :: NodeId
, edgeInfo :: e
} deriving (Show)
data Graph n e =
Graph
{ nodeMap :: [(NodeId, Node n)]
, edgeMap :: [(EdgeId, Edge e)]
}
eq :: (Eq t) => [t] -> [t] -> Bool
eq a b = contained a b && contained b a
contained :: Eq t => [t] -> [t] -> Bool
contained a b = False `notElem` map (`elem` b) a
instance Eq (Graph n e) where
(Graph nodeMap1 edgeMap1) == (Graph nodeMap2 edgeMap2) =
let
simplifyNode (nodeId, _) = nodeId
simplifyEdge (edgeId, edge) = (edgeId, sourceId edge, targetId edge)
in
eq (map simplifyNode nodeMap1) (map simplifyNode nodeMap2) &&
eq (map simplifyEdge edgeMap1) (map simplifyEdge edgeMap2)
instance Show (Graph n e) where
show (Graph nodes edges) =
"Nodes:\n"
++ concatMap showNode nodes
++ "Edges:\n"
++ concatMap showEdge edges
where
showNode (n, _) =
"\t" ++ show n ++ "\n"
showEdge (e, Edge _ src tgt _) =
"\t" ++ show e ++ " (" ++ show src ++ "->" ++ show tgt ++ ")\n"
instance Cardinality (Graph n e) where
cardinality = cardinality'
data NodeContext n e =
NodeCtx NodeId (Graph n e)
type NodeInContext n e =
(Node n, NodeContext n e)
type EdgeInContext n e =
(NodeInContext n e, Edge e, NodeInContext n e)
nodeInContext :: Graph n e -> Node n -> NodeInContext n e
nodeInContext graph node =
(node, NodeCtx (nodeId node) graph)
edgeInContext :: Graph n e -> Edge e -> EdgeInContext n e
edgeInContext graph edge =
let
nodes =
nodeMap graph
in
( nodeInContext graph (fromJust $ lookup (sourceId edge) nodes)
, edge
, nodeInContext graph (fromJust $ lookup (targetId edge) nodes)
)
incidentEdges :: NodeContext n e -> [EdgeInContext n e]
incidentEdges (NodeCtx nodeId graph) =
map (edgeInContext graph)
. filter (\edge -> sourceId edge == nodeId || targetId edge == nodeId)
. map snd
$ edgeMap graph
incomingEdges :: NodeContext n e -> [EdgeInContext n e]
incomingEdges (NodeCtx nodeId graph) =
map (edgeInContext graph)
. filter (\edge -> targetId edge == nodeId)
. map snd
$ edgeMap graph
outgoingEdges :: NodeContext n e -> [EdgeInContext n e]
outgoingEdges (NodeCtx nodeId graph) =
map (edgeInContext graph)
. filter (\edge -> sourceId edge == nodeId)
. map snd
$ edgeMap graph
newNodes :: Graph n e -> [NodeId]
newNodes g = [succ maxNode..]
where maxNode = foldr max 0 (nodeIds g)
newEdges :: Graph n e -> [EdgeId]
newEdges g = [succ maxEdge..]
where maxEdge = foldr max 0 (edgeIds g)
empty :: Graph n e
empty = Graph [] []
build :: [Int] -> [(Int,Int,Int)] -> Graph (Maybe n) (Maybe e)
build n = foldr ((\(a,b,c) -> insertEdge a b c) . (\(a,b,c) -> (EdgeId a, NodeId b, NodeId c))) g
where
g = foldr (insertNode . NodeId) empty n
fromNodesAndEdges :: [Node n] -> [Edge e] -> Graph n e
fromNodesAndEdges nodes edges =
Graph
[ (nodeId n, n) | n <- nodes ]
[ (edgeId e, e)
| e <- edges
, any (\n -> nodeId n == sourceId e) nodes
, any (\n -> nodeId n == targetId e) nodes
]
insertNode :: NodeId -> Graph (Maybe n) e -> Graph (Maybe n) e
insertNode n (Graph ns es) =
Graph (addToAL ns n (Node n Nothing)) es
insertNodeWithPayload :: NodeId -> n -> Graph n e -> Graph n e
insertNodeWithPayload n p (Graph ns es) =
Graph (addToAL ns n (Node n p)) es
insertEdge :: EdgeId -> NodeId -> NodeId -> Graph n (Maybe e) -> Graph n (Maybe e)
insertEdge e src tgt g@(Graph ns es)
| src `elem` keysAL ns && tgt `elem` keysAL ns =
Graph ns (addToAL es e (Edge e src tgt Nothing))
| otherwise = g
insertEdgeWithPayload :: EdgeId -> NodeId -> NodeId -> e -> Graph n e -> Graph n e
insertEdgeWithPayload e src tgt p g@(Graph ns es)
| src `elem` keysAL ns && tgt `elem` keysAL ns =
Graph ns (addToAL es e (Edge e src tgt p))
| otherwise = g
removeNode :: NodeId -> Graph n e -> Graph n e
removeNode n g@(Graph ns es)
| Prelude.null $ getIncidentEdges g n = Graph (delFromAL ns n) es
| otherwise = g
removeNodeForced :: NodeId -> Graph n e -> Graph n e
removeNodeForced n (Graph ns es) = Graph (delFromAL ns n) es
removeNodeAndIncidentEdges :: NodeId -> Graph n e -> Graph n e
removeNodeAndIncidentEdges nodeId (Graph nodes edges) =
Graph
(delFromAL nodes nodeId)
(filter (\(_, e) -> sourceId e /= nodeId && targetId e /= nodeId) edges)
removeEdge :: EdgeId -> Graph n e -> Graph n e
removeEdge e (Graph ns es) = Graph ns (delFromAL es e)
updateNodePayload :: NodeId -> Graph n e -> (n -> n) -> Graph n e
updateNodePayload nodeId graph@(Graph nodes _) f =
case lookup nodeId nodes of
Nothing ->
graph
Just node ->
let
updatedNode =
node { nodeInfo = f (nodeInfo node) }
in
graph { nodeMap = addToAL nodes nodeId updatedNode }
updateEdgePayload :: EdgeId -> Graph n e -> (e -> e) -> Graph n e
updateEdgePayload edgeId graph@(Graph _ edges) f =
case lookup edgeId edges of
Nothing ->
graph
Just edge ->
let
updatedEdge =
edge { edgeInfo = f (edgeInfo edge) }
in
graph { edgeMap = addToAL edges edgeId updatedEdge }
nodeIds :: Graph n e -> [NodeId]
nodeIds (Graph nodes _) = keysAL nodes
edgeIds :: Graph n e -> [EdgeId]
edgeIds (Graph _ edges) = keysAL edges
nodes :: Graph n e -> [Node n]
nodes (Graph nodes _) = map snd nodes
edges :: Graph n e -> [Edge e]
edges (Graph _ edges) = map snd edges
nodesInContext :: Graph n e -> [NodeInContext n e]
nodesInContext graph@(Graph nodes _) =
map (nodeInContext graph . snd) nodes
edgesInContext :: Graph n e -> [EdgeInContext n e]
edgesInContext graph@(Graph _ edges) =
map (edgeInContext graph . snd) edges
{-# DEPRECATED nodesOf, sourceOf, sourceOfUnsafe, targetOf, targetOfUnsafe, getIncidentEdges "This function performs unnecessary dictionary lookups. Try using lookupNode, lookupNodeInContext, nodes or nodesInContext instead." #-}
lookupNode :: NodeId -> Graph n e -> Maybe (Node n)
lookupNode id (Graph nodes _) =
lookup id nodes
lookupEdge :: EdgeId -> Graph n e -> Maybe (Edge e)
lookupEdge id (Graph _ edges) =
lookup id edges
lookupNodeInContext :: NodeId -> Graph n e -> Maybe (NodeInContext n e)
lookupNodeInContext id graph =
nodeInContext graph <$> lookupNode id graph
lookupEdgeInContext :: EdgeId -> Graph n e -> Maybe (EdgeInContext n e)
lookupEdgeInContext id graph =
edgeInContext graph <$> lookupEdge id graph
nodesOf :: Graph n e -> EdgeId -> Maybe (NodeId, NodeId)
nodesOf (Graph _ es) e =
let ed = lookup e es
in case ed of
Just (Edge _ src tgt _) -> Just (src, tgt)
_ -> Nothing
sourceOf :: Graph n e -> EdgeId -> Maybe NodeId
sourceOf graph e =
fst <$> nodesOf graph e
targetOf :: Graph n e -> EdgeId -> Maybe NodeId
targetOf graph e =
snd <$> nodesOf graph e
sourceOfUnsafe :: Graph n e -> EdgeId -> NodeId
sourceOfUnsafe g e = fromMaybe (error "Error, graph with source edges function non total") $ sourceOf g e
targetOfUnsafe :: Graph n e -> EdgeId -> NodeId
targetOfUnsafe g e = fromMaybe (error "Error, graph with target edges function non total") $ targetOf g e
null :: Graph n e -> Bool
null (Graph [] []) = True
null _ = False
cardinality' :: Graph n e -> Int
cardinality' g = length (nodes g) + length (edges g)
isNodeOf :: Graph n e -> NodeId -> Bool
isNodeOf g n = n `elem` nodeIds g
isEdgeOf :: Graph n e -> EdgeId -> Bool
isEdgeOf g e = e `elem` edgeIds g
isAdjacentTo :: Graph n e -> NodeId -> NodeId -> Bool
isAdjacentTo g n1 n2 =
any (\e -> nodesOf g e == Just (n1,n2)) (edgeIds g)
isIncidentTo :: Graph n e -> NodeId -> EdgeId -> Bool
isIncidentTo g n e =
case res of
Just (s, t) -> n == s || n == t
_ -> False
where
res = nodesOf g e
getIncidentEdges :: Graph n e -> NodeId -> [EdgeId]
getIncidentEdges g n = nub $ getIncomingEdges g n ++ getOutgoingEdges g n
getOutgoingEdges :: Graph n e -> NodeId -> [EdgeId]
getOutgoingEdges g n = filter (\e -> sourceOf g e == Just n) (edgeIds g)
getIncomingEdges :: Graph n e -> NodeId -> [EdgeId]
getIncomingEdges g n = filter (\e -> targetOf g e == Just n) (edgeIds g)
instance Valid (Graph n e) where
validate graph =
mconcat $ map validateEdge (edgeMap graph)
where
validateEdge (edge, Edge _ src tgt _) =
mconcat
[ ensure (isNodeOf graph src) ("Source node #" ++ show src ++ " of edge #" ++ show edge ++ " is not a member of the graph")
, ensure (isNodeOf graph tgt) ("Target node #" ++ show src ++ " of edge #" ++ show edge ++ " is not a member of the graph")
]