diff options
| -rw-r--r-- | src/Grasp/Edge.hs | 43 | ||||
| -rw-r--r-- | src/Grasp/Graph.hs | 153 | ||||
| -rw-r--r-- | src/Grasp/Node.hs | 47 |
3 files changed, 153 insertions, 90 deletions
diff --git a/src/Grasp/Edge.hs b/src/Grasp/Edge.hs deleted file mode 100644 index f0e1cc3..0000000 --- a/src/Grasp/Edge.hs +++ /dev/null @@ -1,43 +0,0 @@ -module Grasp.Edge ( - GEdge, - GEdgeType, - - singleton, - fromStringList, - src, - dest, - lab - ) where - - - -import Data.Graph.Inductive.Graph( LEdge ) -import Data.Map( Map ) -import qualified Data.Map as Map - - - -type GEdge = LEdge String -type GEdgeType = String - - - -singleton :: Int -> Int -> String -> GEdge -singleton f t s = (f,t,s) - -fromStringList :: Map String Int -> [(String,String,String)] -> [GEdge] -fromStringList m es = - let change x = case (Map.lookup x m) of - Just a -> a - Nothing -> error "Grasp.Edge.fromStringList: no value for key " ++ x - in map (\(x,y,z) -> (change x, change y, z)) es - -src :: GEdge -> Int -src (x,_,_) = x - -dest :: GEdge -> Int -dest (_,x,_) = x - -lab :: GEdge -> String -lab (_,_,x) = x - diff --git a/src/Grasp/Graph.hs b/src/Grasp/Graph.hs new file mode 100644 index 0000000..0caaee7 --- /dev/null +++ b/src/Grasp/Graph.hs @@ -0,0 +1,153 @@ +module Grasp.Graph ( + Node, + LNode, + UNode, + + Edge, + LEdge, + UEdge, + + Adj, + + Context, + MContext, + UContext, + + Decomp, + GDecomp, + UDecomp, + + Path, + LPath, + UPath, + + Gr, + + empty, + isEmpty, + match, + mkGraph, + labNodes, + noNodes, + labEdges, + nodes + ) where + + + + +import Data.List +import qualified Data.Maybe as Maybe + + + + +type Node = String + +type LNode a = (Node, a) + +type UNode = LNode () + +type Edge = (Node, Node) + +type LEdge a = (Node, Node, a) + +type UEdge = LEdge () + +type Adj b = [(b, Node)] + +type Context a b = (Adj b, Node, a, Adj b) + +type MContext a b = Maybe (Context a b) + +type UContext = ([Node], Node, [Node]) + +type Decomp a b = (MContext a b, Gr a b) + +type GDecomp a b = (Context a b, Gr a b) + +type UDecomp = (Maybe UContext, Gr () ()) + +type Path = [Node] + +newtype LPath a = LP [LNode a] + +type UPath = [UNode] + + + + +data Gr a b = Gr { labNodes :: [LNode a] + , labEdges :: [LEdge b] } + deriving (Show) + + + + +instance (Eq a, Eq b) => Eq (Gr a b) where + a == b = (labNodes a == labNodes b) && (labEdges a == labEdges b) + + + + +empty :: Gr a b +empty = Gr [] [] + + + +isEmpty :: Gr a b -> Bool +isEmpty gr = (length (labNodes gr) == 0) && (length (labEdges gr) == 0) + + + +match :: Node -> Gr a b -> Decomp a b +match n gr = + if (n `notElem` nodes gr) + then (Nothing, gr) + else (Just (to, n, label, from), gr) + where + to = map edgeToAdjTo (filter (edgeTo n) (labEdges gr)) + label = snd . head $ (filter (\(x,y) -> x == n) (labNodes gr)) + from = map edgeToAdjFrom (filter (edgeFrom n) (labEdges gr)) + + + +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) + + in if (all (`elem` nodes) edgeNodes) + then Gr lnodes ledges + else error "Edge Exception" + + + +noNodes :: Gr a b -> Int +noNodes = length . labNodes + + + +nodes :: Gr a b -> [Node] +nodes gr = (map fst) . labNodes $ gr + + + +edgeToAdjFrom :: LEdge a -> Adj a +edgeToAdjFrom (x,y,z) = (z,y) + + + +edgeToAdjTo :: LEdge a -> Adj a +edgeToAdjTo (x,y,z) = (z,x) + + + +edgeFrom :: Node -> LEdge a -> Bool +edgeFrom n (x,y,z) = (y == n) + + + +edgeTo :: Node -> LEdge a -> Bool +edgeTo n (x,y,z) = (x == n) + diff --git a/src/Grasp/Node.hs b/src/Grasp/Node.hs deleted file mode 100644 index ce84163..0000000 --- a/src/Grasp/Node.hs +++ /dev/null @@ -1,47 +0,0 @@ -module Grasp.Node ( - GNode, - GNodeType, - - singleton, - uSingleton, - fromStringList, - lab, - inst, - idNo - ) where - - - -import Data.Graph.Inductive.Graph( LNode ) -import Data.Map( Map ) -import qualified Data.Map as Map - - - -type GNode = LNode (Maybe String, String) -type GNodeType = (Maybe String, String) - - - -singleton :: Int -> String -> String -> GNode -singleton i m s = (i,(Just m,s)) - -uSingleton :: Int -> String -> GNode -uSingleton i s = (i,(Nothing,s)) - -fromStringList :: Map String Int -> [(String,String)] -> [GNode] -fromStringList m ns = - let change x = case (Map.lookup x m) of - Just a -> a - Nothing -> error "Grasp.Node.fromStringList: no value for key " ++ x - in map (\(x,y) -> (change x, (Just x, y))) ns - -lab :: GNode -> Maybe String -lab (_,(x,_)) = x - -inst :: GNode -> String -inst (_,(_,x)) = x - -idNo :: GNode -> Int -idNo (x,(_,_)) = x - |