module Game.Antisplice.Utils.Graph where
import Game.Antisplice.Utils.BST
import Game.Antisplice.Utils.AVL
import Game.Antisplice.Utils.None
newtype NodeId = NodeId Int deriving (Eq,Show,Ord)
data Graph a b c = Graph { nodes :: AVL (Node a), edges :: [Edge b c], nextId :: NodeId }
data Node a = Node { nodeMarked :: Bool, nodeContent :: a, nodeId :: NodeId }
data Edge b c = Edge { fromNode :: NodeId, toNode :: NodeId, weight :: Int, label :: b, content :: c }
instance Indexable (Node a) NodeId (Node a) where
type IndexOf (Node a) = NodeId
type ValueOf (Node a) = Node a
indexOf = nodeId
valueOf = id
instance (Show a) => Show (Node a) where
show (Node _ c i) = concat [show i, ": ", show c]
instance (Show b) => Show (Edge b c) where
show (Edge f t w l _) = concat [show f, " --", show l, "-> ", show t, " [", show w, "]"]
incId :: NodeId -> NodeId
incId (NodeId i) = NodeId (i+1)
emptyGraph :: Graph a b c
emptyGraph = Graph EmptyAVL [] (NodeId 0)
instance None (Graph a b c) where
none = emptyGraph
addNode :: a -> Graph a b c -> Graph a b c
addNode x = snd . addNode' x
addNode' :: a -> Graph a b c -> (NodeId,Graph a b c)
addNode' x (Graph ns es nid) = (nid, Graph (avlInsert (Node False x nid) ns) es (incId nid))
addNodes :: [a] -> Graph a b c -> Graph a b c
addNodes xs = snd . addNodes' xs
addNodes' :: [a] -> Graph a b c -> ([NodeId],Graph a b c)
addNodes' [] g = ([],g)
addNodes' (p:ps) g = let (ls, g'') = addNodes' ps g'
(l, g') = addNode' p g
in (l:ls, g'')
allNodes :: Graph a b c -> [Node a]
allNodes = avlInorder . nodes
rootNode :: Graph a b c -> NodeId
rootNode = nodeId . avlRoot . nodes
addEdge :: NodeId -> NodeId -> Int -> b -> c -> Graph a b c -> Graph a b c
addEdge f t w l c = addEdge' (Edge f t w l c)
addEdge' :: Edge b c -> Graph a b c -> Graph a b c
addEdge' e g = g{edges=e:edges g}
addMutualEdge :: NodeId -> NodeId -> Int -> b -> c -> Graph a b c -> Graph a b c
addMutualEdge f t w l c = addEdge f t w l c . addEdge t f w l c
addEdges :: [(NodeId,NodeId,Int,b,c)] -> Graph a b c -> Graph a b c
addEdges es g = foldr (addEdge' . (\(f,t,w,l,c) -> Edge f t w l c)) g es
addEdges' :: [Edge b c] -> Graph a b c -> Graph a b c
addEdges' = flip $ foldr addEdge'
addMutualEdges :: [(NodeId,NodeId,Int,b,c)] -> Graph a b c -> Graph a b c
addMutualEdges es = addEdges es . addEdges (map (\(f,t,w,l,c) -> (t,f,w,l,c)) es)
getNode :: NodeId -> Graph a b c -> a
getNode n = nodeContent . getNode' n
getNode' :: NodeId -> Graph a b c -> Node a
getNode' n = (\(Just x) -> x) . avlLookup n . nodes
setNode :: NodeId -> a -> Graph a b c -> Graph a b c
setNode n a g@(Graph ns _ _) = g{nodes=fmap setNode' ns}
where setNode' (Node m c i) = if i == n then Node m a i else Node m c i
markNode :: NodeId -> Graph a b c -> Graph a b c
markNode n g@(Graph ns _ _) = g{nodes=fmap markNode' ns}
where markNode' (Node m c i) = if i == n then Node True c i else Node m c i
followEdge :: Eq b => NodeId -> b -> Graph a b c -> Maybe NodeId
followEdge n l g = case filter ((==l).label) $ filter ((==n).fromNode) $ edges g of
[] -> Nothing
(x:_) -> Just (toNode x)
queryEdge :: Eq b => NodeId -> b -> Graph a b c -> Maybe c
queryEdge n l g = case filter ((==l).label) $ filter ((==n).fromNode) $ edges g of
[] -> Nothing
(x:_) -> Just (content x)
listEdges :: NodeId -> Graph a b c -> [(b,c,NodeId)]
listEdges n g = fmap (\(Edge _ t _ l c) -> (l,c,t)) $ filter ((==n).fromNode) $ edges g