diff options
| -rw-r--r-- | src/Grasp/Graph.hs | 288 |
1 files changed, 250 insertions, 38 deletions
diff --git a/src/Grasp/Graph.hs b/src/Grasp/Graph.hs index bc08bbe..2f22d2b 100644 --- a/src/Grasp/Graph.hs +++ b/src/Grasp/Graph.hs @@ -1,25 +1,10 @@ module Grasp.Graph ( - Node, - LNode, - UNode, - - Edge, - LEdge, - UEdge, - + Node, LNode, UNode, + Edge, LEdge, UEdge, Adj, - - Context, - MContext, - UContext, - - Decomp, - GDecomp, - UDecomp, - - Path, - LPath, - UPath, + Context, MContext, UContext, + Decomp, GDecomp, UDecomp, + Path, LPath, UPath, Gr, @@ -28,20 +13,48 @@ module Grasp.Graph ( match, mkGraph, labNodes, + matchAny, noNodes, + nodeRange, labEdges, - nodes + + (&), + + nodes, + edges, + newNodes, + gelem, + + insNode, insEdge, + delNode, delEdge, delLEdge, + insNodes, insEdges, + delNodes, delEdges, + buildGr, + mkUGraph, + + context, + lab, + neighbours, + suc, pre, lsuc, lpre, + out, inn, + outdeg, indeg, deg, + equal ) where -import Data.List +import qualified Data.List as List import qualified Data.Maybe as Maybe +-- this whole thing is essentially a reimplementation of Data.Graph.Inductive.Graph +-- with String nodes instead of Int nodes, because it makes the rest of the code easier + + + type Node = String type LNode a = (Node, a) @@ -77,8 +90,8 @@ type UPath = [UNode] -data Gr a b = Gr { labNodes :: [LNode a] - , labEdges :: [LEdge b] } +data Gr a b = Gr { getLabNodes :: [LNode a] + , getLabEdges :: [LEdge b] } deriving (Show) @@ -90,13 +103,17 @@ instance (Eq a, Eq b) => Eq (Gr a b) where + +-- class methods + + empty :: Gr a b empty = Gr [] [] isEmpty :: Gr a b -> Bool -isEmpty gr = (length (labNodes gr) == 0) && (length (labEdges gr) == 0) +isEmpty gr = (length (labNodes gr) == 0) @@ -106,48 +123,243 @@ match n gr = then (Nothing, gr) else (Just (to, n, label, from), gr) where - to = edgesToAdjTo (filter (edgeTo n) (labEdges gr)) + to = map (\(x,y,z) -> (z,y)) (inn gr n) label = snd . head $ (filter (\(x,y) -> x == n) (labNodes gr)) - from = edgesToAdjFrom (filter (edgeFrom n) (labEdges gr)) + from = map (\(x,y,z) -> (z,x)) (out gr n) mkGraph :: [LNode a] -> [LEdge b] -> Gr a b mkGraph lnodes ledges = let nodes = map fst lnodes - edgeNodes = (map (\(x,y,z) -> x) ledges) `union` (map (\(x,y,z) -> y) ledges) - + edgeNodes = (map (\(x,y,z) -> x) ledges) `List.union` (map (\(x,y,z) -> y) ledges) in if (all (`elem` nodes) edgeNodes) then Gr lnodes ledges else error "Edge Exception" +labNodes :: Gr a b -> [LNode a] +labNodes = getLabNodes + + + +matchAny :: Gr a b -> GDecomp a b +matchAny gr = + let (mcon, gr') = match (head . nodes $ gr) gr + in if (isEmpty gr) + then error "Match Exception" + else (Maybe.fromJust mcon, gr') + + + noNodes :: Gr a b -> Int noNodes = length . labNodes +nodeRange :: Gr a b -> (Node,Node) +nodeRange gr = + let nodes = map fst (labNodes gr) + in if (length nodes == 0) then ("","") else (head nodes, last nodes) + + + +labEdges :: Gr a b -> [LEdge b] +labEdges = getLabEdges + + + +(&) :: Context a b -> Gr a b -> Gr a b +(to, n, lab, from) & gr = + let edgesTo = map (\(z,y) -> (n,y,z)) to + edgesFrom = map (\(z,x) -> (x,n,z)) from + in (insEdges edgesTo) . (insEdges edgesFrom) . (insNode (n,lab)) $ gr + + + + + +-- graph projection + + nodes :: Gr a b -> [Node] -nodes gr = (map fst) . labNodes $ gr +nodes gr = map fst (labNodes gr) + + + +edges :: Gr a b -> [Edge] +edges gr = map (\(x,y,z) -> (x,y)) (labEdges gr) + + + +newNodes :: Int -> Gr a b -> [Node] +newNodes x gr = take x (filter (`notElem` (nodes gr)) (map show [1..])) + + + +gelem :: Node -> Gr a b -> Bool +gelem n gr = n `elem` (nodes gr) + + + + + +-- graph construction and deconstruction + + +insNode :: LNode a -> Gr a b -> Gr a b +insNode n gr = + let preExisting = filter (\x -> fst x == fst n) (labNodes gr) + in if (length preExisting /= 0) + then error "Node Exception" + else Gr (n:(labNodes gr)) (labEdges gr) + + + +insEdge :: LEdge b -> Gr a b -> Gr a b +insEdge (a,b,c) gr = + let from = filter (\x -> fst x == a) (labNodes gr) + to = filter (\x -> fst x == b) (labNodes gr) + in if (length from == 0 || length to == 0) + then error "Edge Exception" + else Gr (labNodes gr) ((a,b,c):(labEdges gr)) + + + +delNode :: Node -> Gr a b -> Gr a b +delNode n gr = + let nodes' = filter (\x -> fst x /= n) (labNodes gr) + edges' = filter (\(x,y,z) -> x /= n && y /= n) (labEdges gr) + in Gr nodes' edges' + + + +delEdge :: Edge -> Gr a b -> Gr a b +delEdge e gr = + let edges' = filter (\(x,y,z) -> (x,y) /= e) (labEdges gr) + in Gr (labNodes gr) edges' + + + +delLEdge :: (Eq b) => LEdge b -> Gr a b -> Gr a b +delLEdge e gr = Gr (labNodes gr) (filter (/= e) (labEdges gr)) + + + +insNodes :: [LNode a] -> Gr a b -> Gr a b +insNodes ns gr = List.foldl' (flip insNode) gr ns + + + +insEdges :: [LEdge b] -> Gr a b -> Gr a b +insEdges es gr = List.foldl' (flip insEdge) gr es + + + +delNodes :: [Node] -> Gr a b -> Gr a b +delNodes ns gr = + let nodes' = filter (\x -> fst x `notElem` ns) (labNodes gr) + edges' = filter (\(x,y,z) -> x `notElem` ns && y `notElem` ns) (labEdges gr) + in Gr nodes' edges' + + + +delEdges :: [Edge] -> Gr a b -> Gr a b +delEdges es gr = + let edges' = filter (\(x,y,z) -> (x,y) `notElem` es) (labEdges gr) + in Gr (labNodes gr) edges' + + + +buildGr :: [Context a b] -> Gr a b +buildGr cs = List.foldl' (flip (&)) empty cs + + + +mkUGraph :: [Node] -> [Edge] -> Gr () () +mkUGraph ns es = Gr (map (\x -> (x,())) ns) (map (\(x,y) -> (x,y,())) es) + + + + + +-- graph inspection + + +context :: Gr a b -> Node -> Context a b +context gr n = + let from = map (\(x,y,z) -> (z,y)) (out gr n) + to = map (\(x,y,z) -> (z,x)) (inn gr n) + in if (n `notElem` (nodes gr)) + then error "Match Exception" + else (to, n, Maybe.fromJust (lab gr n), from) + + + +lab :: Gr a b -> Node -> Maybe a +lab gr n = + let nlist = filter (\(x,y) -> x == n) (labNodes gr) + in if (length nlist == 0) then Nothing else Just (snd . head $ nlist) + + + +neighbours :: Gr a b -> Node -> [Node] +neighbours gr n = (suc gr n) ++ (pre gr n) + + + +suc :: Gr a b -> Node -> [Node] +suc gr n = + if (n `notElem` (nodes gr)) + then error "Match Exception" + else map (\(x,y,z) -> y) (out gr n) + + + +pre :: Gr a b -> Node -> [Node] +pre gr n = + if (n `notElem` (nodes gr)) + then error "Match Exception" + else map (\(x,y,z) -> x) (inn gr n) + + + +lsuc :: Gr a b -> Node -> [(Node, b)] +lsuc gr n = map (\(x,y,z) -> (y,z)) (out gr n) + + + +lpre :: Gr a b -> Node -> [(Node, b)] +lpre gr n = map (\(x,y,z) -> (x,z)) (inn gr n) + + + +out :: Gr a b -> Node -> [LEdge b] +out gr n = filter (\(x,y,z) -> x == n) (labEdges gr) + + + +inn :: Gr a b -> Node -> [LEdge b] +inn gr n = filter (\(x,y,z) -> y == n) (labEdges gr) -edgesToAdjFrom :: [LEdge a] -> Adj a -edgesToAdjFrom = map (\(x,y,z) -> (z,x)) +outdeg :: Gr a b -> Node -> Int +outdeg gr n = length (out gr n) -edgesToAdjTo :: [LEdge a] -> Adj a -edgesToAdjTo = map (\(x,y,z) -> (z,y)) +indeg :: Gr a b -> Node -> Int +indeg gr n = length (inn gr n) -edgeFrom :: Node -> LEdge a -> Bool -edgeFrom n (x,y,z) = (x == n) +deg :: Gr a b -> Node -> Int +deg gr n = (outdeg gr n) + (indeg gr n) -edgeTo :: Node -> LEdge a -> Bool -edgeTo n (x,y,z) = (y == n) +equal :: (Eq a, Eq b) => Gr a b -> Gr a b -> Bool +equal a b = (a == b) |