libhugs-fgl-bundled 98.200609.21-5.3 / usr / lib / hugs / packages / fgl / Data / Graph / Inductive / Graph.hs

-- (c) 1999-2005 by Martin Erwig [see file COPYRIGHT]
-- | Static and Dynamic Inductive Graphs  
module Data.Graph.Inductive.Graph (
    -- * General Type Defintions
    -- ** Node and Edge Types
    Node,LNode,UNode,
    Edge,LEdge,UEdge,
    -- ** Types Supporting Inductive Graph View
    Adj,Context,MContext,Decomp,GDecomp,UDecomp,
    Path,LPath(..),UPath,
    -- * Graph Type Classes
    -- | We define two graph classes:
    --
    --   Graph: static, decomposable graphs.
    --		Static means that a graph itself cannot be changed
    --             
    --   DynGraph: dynamic, extensible graphs.
    --             Dynamic graphs inherit all operations from static graphs
    --             but also offer operations to extend and change graphs.
    --
    -- Each class contains in addition to its essential operations those
    -- derived operations that might be overwritten by a more efficient
    -- implementation in an instance definition.
    -- 
    -- Note that labNodes is essentially needed because the default definition
    -- for matchAny is based on it: we need some node from the graph to define
    -- matchAny in terms of match. Alternatively, we could have made matchAny 
    -- essential and have labNodes defined in terms of ufold and matchAny. 
    -- However, in general, labNodes seems to be (at least) as easy to define 
    -- as matchAny. We have chosen labNodes instead of the function nodes since 
    -- nodes can be easily derived from labNodes, but not vice versa.
    Graph(..), 
    DynGraph(..),
    -- * Operations
    -- ** Graph Folds and Maps
    ufold,gmap,nmap,emap,
    -- ** Graph Projection
    nodes,edges,newNodes,gelem,
    -- ** Graph Construction and Destruction
    insNode,insEdge,delNode,delEdge,delLEdge,
    insNodes,insEdges,delNodes,delEdges,
    buildGr,mkUGraph,
    -- ** Graph Inspection
    context,lab,neighbors,
    suc,pre,lsuc,lpre,
    out,inn,outdeg,indeg,deg,
    equal,
    -- ** Context Inspection
    node',lab',labNode',neighbors',
    suc',pre',lpre',lsuc',
    out',inn',outdeg',indeg',deg',
) where


import Data.List (sortBy)


{- Signatures:

-- basic operations
empty      ::    Graph gr => gr a b
isEmpty    ::    Graph gr => gr a b -> Bool
match      ::    Graph gr => Node -> gr a b -> Decomp gr a b
mkGraph    ::    Graph gr => [LNode a] -> [LEdge b] -> gr a b
(&)        :: DynGraph gr => Context a b -> gr a b -> gr a b

-- graph folds and maps
ufold      :: Graph gr => ((Context a b) -> c -> c) -> c -> gr a b -> c
gmap       :: Graph gr => (Context a b -> Context c d) -> gr a b -> gr c d
nmap       :: Graph gr => (a -> c) -> gr a b -> gr c b
emap       :: Graph gr => (b -> c) -> gr a b -> gr a c

-- graph projection
matchAny   :: Graph gr => gr a b -> GDecomp g a b
nodes      :: Graph gr => gr a b -> [Node]
edges      :: Graph gr => gr a b -> [Edge]
labNodes   :: Graph gr => gr a b -> [LNode a]
labEdges   :: Graph gr => gr a b -> [LEdge b]
newNodes   :: Graph gr => Int -> gr a b -> [Node]
noNodes    :: Graph gr => gr a b -> Int
nodeRange  :: Graph gr => gr a b -> (Node,Node)
gelem      :: Graph gr => Node -> gr a b -> Bool

-- graph construction & destruction
insNode    :: DynGraph gr => LNode a   -> gr a b -> gr a b
insEdge    :: DynGraph gr => LEdge b   -> gr a b -> gr a b
delNode    ::    Graph gr => Node      -> gr a b -> gr a b
delEdge    :: DynGraph gr => Edge      -> gr a b -> gr a b
delLEdge   :: (DynGraph gr, Eq b) =>
                             LEdge b   -> gr a b -> gr a b
insNodes   :: DynGraph gr => [LNode a] -> gr a b -> gr a b
insEdges   :: DynGraph gr => [LEdge b] -> gr a b -> gr a b
delNodes   ::    Graph gr => [Node]    -> gr a b -> gr a b
delEdges   :: DynGraph gr => [Edge]    -> gr a b -> gr a b
buildGr    :: DynGraph gr => [Context a b] -> gr a b
mkUGraph   :: DynGraph gr => [Node] -> [Edge] -> gr () ()

-- graph inspection
context    :: Graph gr => gr a b -> Node -> Context a b
lab        :: Graph gr => gr a b -> Node -> Maybe a
neighbors  :: Graph gr => gr a b -> Node -> [Node] 
suc        :: Graph gr => gr a b -> Node -> [Node]
pre        :: Graph gr => gr a b -> Node -> [Node] 
lsuc       :: Graph gr => gr a b -> Node -> [(Node,b)]
lpre       :: Graph gr => gr a b -> Node -> [(Node,b)] 
out        :: Graph gr => gr a b -> Node -> [LEdge b] 
inn        :: Graph gr => gr a b -> Node -> [LEdge b] 
outdeg     :: Graph gr => gr a b -> Node -> Int
indeg      :: Graph gr => gr a b -> Node -> Int
deg        :: Graph gr => gr a b -> Node -> Int

-- context inspection
node'      :: Context a b -> Node
lab'       :: Context a b -> a
labNode'   :: Context a b -> LNode a
neighbors' :: Context a b -> [Node] 
suc'       :: Context a b -> [Node]
pre'       :: Context a b -> [Node] 
lpre'      :: Context a b -> [(Node,b)] 
lsuc'      :: Context a b -> [(Node,b)]
out'       :: Context a b -> [LEdge b] 
inn'       :: Context a b -> [LEdge b] 
outdeg'    :: Context a b -> Int
indeg'     :: Context a b -> Int
deg'       :: Context a b -> Int

-}

-- | Unlabeled node
type  Node   = Int		
-- | Labeled node
type LNode a = (Node,a)		
-- | Quasi-unlabeled node
type UNode   = LNode ()		

-- | Unlabeled edge
type  Edge   = (Node,Node)	
-- | Labeled edge
type LEdge b = (Node,Node,b)	
-- | Quasi-unlabeled edge
type UEdge   = LEdge ()		

-- | Unlabeled path
type Path    = [Node]		
-- | Labeled path
newtype LPath a = LP [LNode a]

instance Show a => Show (LPath a) where
  show (LP xs) = show xs

-- | Quasi-unlabeled path
type UPath   = [UNode]		

-- | Labeled links to or from a 'Node'.
type Adj b        = [(b,Node)]
-- | Links to the 'Node', the 'Node' itself, a label, links from the 'Node'.
type Context a b  = (Adj b,Node,a,Adj b) -- Context a b "=" Context' a b "+" Node
type MContext a b = Maybe (Context a b)
-- | 'Graph' decomposition - the context removed from a 'Graph', and the rest
-- of the 'Graph'.
type Decomp g a b = (MContext a b,g a b)
-- | The same as 'Decomp', only more sure of itself.
type GDecomp g a b  = (Context a b,g a b)

-- | Unlabeled context.
type UContext     = ([Node],Node,[Node])
-- | Unlabeled decomposition.
type UDecomp g    = (Maybe UContext,g)

-- | Minimum implementation: 'empty', 'isEmpty', 'match', 'mkGraph', 'labNodes'
class Graph gr where
  -- essential operations
  -- | An empty 'Graph'.
  empty     :: gr a b
  -- | True if the given 'Graph' is empty.
  isEmpty   :: gr a b -> Bool
  -- | Decompose a 'Graph' into the 'MContext' found for the given node and the
  -- remaining 'Graph'.
  match     :: Node -> gr a b -> Decomp gr a b
  -- | Create a 'Graph' from the list of 'LNode's and 'LEdge's.
  mkGraph   :: [LNode a] -> [LEdge b] -> gr a b
  -- | A list of all 'LNode's in the 'Graph'.
  labNodes  :: gr a b -> [LNode a]
  -- derived operations
  -- | Decompose a graph into the 'Context' for an arbitrarily-chosen 'Node'
  -- and the remaining 'Graph'.
  matchAny  :: gr a b -> GDecomp gr a b
  -- | The number of 'Node's in a 'Graph'.
  noNodes   :: gr a b -> Int
  -- | The minimum and maximum 'Node' in a 'Graph'.
  nodeRange :: gr a b -> (Node,Node)
  -- | A list of all 'LEdge's in the 'Graph'.
  labEdges  :: gr a b -> [LEdge b]
  -- default implementation of derived operations
  matchAny g = case labNodes g of
                 []      -> error "Match Exception, Empty Graph"
                 (v,_):_ -> (c,g') where (Just c,g') = match v g 
  noNodes = length . labNodes 
  nodeRange g = (minimum vs,maximum vs) where vs = map fst (labNodes g)
  labEdges = ufold (\(_,v,_,s)->((map (\(l,w)->(v,w,l)) s)++)) []


class Graph gr => DynGraph gr where
  -- | Merge the 'Context' into the 'DynGraph'.
  (&) :: Context a b -> gr a b -> gr a b


-- | Fold a function over the graph.
ufold :: Graph gr => ((Context a b) -> c -> c) -> c -> gr a b -> c
ufold f u g | isEmpty g = u
            | otherwise = f c (ufold f u g') 
            where (c,g') = matchAny g

-- | Map a function over the graph.
gmap :: DynGraph gr => (Context a b -> Context c d) -> gr a b -> gr c d
gmap f = ufold (\c->(f c&)) empty

-- | Map a function over the 'Node' labels in a graph.
nmap :: DynGraph gr => (a -> c) -> gr a b -> gr c b
nmap f = gmap (\(p,v,l,s)->(p,v,f l,s))

-- | Map a function over the 'Edge' labels in a graph.
emap :: DynGraph gr => (b -> c) -> gr a b -> gr a c
emap f = gmap (\(p,v,l,s)->(map1 f p,v,l,map1 f s))
         where map1 g = map (\(l,v)->(g l,v))

-- | List all 'Node's in the 'Graph'.
nodes :: Graph gr => gr a b -> [Node]
nodes = map fst . labNodes

-- | List all 'Edge's in the 'Graph'.
edges :: Graph gr => gr a b -> [Edge]
edges = map (\(v,w,_)->(v,w)) . labEdges

-- | List N available 'Node's, i.e. 'Node's that are not used in the 'Graph'.
newNodes :: Graph gr => Int -> gr a b -> [Node]
newNodes i g = [n+1..n+i] where (_,n) = nodeRange g

-- | 'True' if the 'Node' is present in the 'Graph'.
gelem :: Graph gr => Node -> gr a b -> Bool
gelem v g = case match v g of {(Just _,_) -> True; _ -> False}

-- | Insert a 'LNode' into the 'Graph'.
insNode :: DynGraph gr => LNode a -> gr a b -> gr a b
insNode (v,l) = (([],v,l,[])&)

-- | Insert a 'LEdge' into the 'Graph'.
insEdge :: DynGraph gr => LEdge b -> gr a b -> gr a b
insEdge (v,w,l) g = (pr,v,la,(l,w):su) & g'
                    where (Just (pr,_,la,su),g') = match v g

-- | Remove a 'Node' from the 'Graph'.
delNode :: Graph gr => Node -> gr a b -> gr a b
delNode v = delNodes [v]

-- | Remove an 'Edge' from the 'Graph'.
delEdge :: DynGraph gr => Edge -> gr a b -> gr a b
delEdge (v,w) g = case match v g of
                  (Nothing,_)        -> g
                  (Just (p,v',l,s),g') -> (p,v',l,filter ((/=w).snd) s) & g'

-- | Remove an 'LEdge' from the 'Graph'.
delLEdge :: (DynGraph gr, Eq b) => LEdge b -> gr a b -> gr a b
delLEdge (v,w,b) g = case match v g of
                  (Nothing,_)        -> g
                  (Just (p,v',l,s),g') -> (p,v',l,filter (\(x,n) -> x /= b || n /= w) s) & g'

-- | Insert multiple 'LNode's into the 'Graph'.
insNodes   :: DynGraph gr => [LNode a] -> gr a b -> gr a b
insNodes vs g = foldr insNode g vs

-- | Insert multiple 'LEdge's into the 'Graph'.
insEdges :: DynGraph gr => [LEdge b] -> gr a b -> gr a b
insEdges es g = foldr insEdge g es

-- | Remove multiple 'Node's from the 'Graph'.
delNodes :: Graph gr => [Node] -> gr a b -> gr a b
delNodes []     g = g
delNodes (v:vs) g = delNodes vs (snd (match v g))  

-- | Remove multiple 'Edge's from the 'Graph'.
delEdges :: DynGraph gr => [Edge]    -> gr a b -> gr a b
delEdges es g = foldr delEdge g es

-- | Build a 'Graph' from a list of 'Context's.
buildGr :: DynGraph gr => [Context a b] -> gr a b
buildGr = foldr (&) empty

-- mkGraph :: DynGraph gr => [LNode a] -> [LEdge b] -> gr a b
-- mkGraph vs es = (insEdges es . insNodes vs) empty

-- | Build a quasi-unlabeled 'Graph'.
mkUGraph :: Graph gr => [Node] -> [Edge] -> gr () ()
mkUGraph vs es = mkGraph (labUNodes vs) (labUEdges es) 

labUEdges = map (\(v,w)->(v,w,()))
labUNodes = map (\v->(v,()))
 
-- | Find the context for the given 'Node'.  Causes an error if the 'Node' is
-- not present in the 'Graph'.
context :: Graph gr => gr a b -> Node -> Context a b
context g v = case match v g of
                (Nothing,_) -> error ("Match Exception, Node: "++show v)
                (Just c,_)  -> c 

-- | Find the label for a 'Node'.
lab :: Graph gr => gr a b -> Node -> Maybe a
lab g v = fst (match v g) >>= return.lab' 

-- | Find the neighbors for a 'Node'.
neighbors :: Graph gr => gr a b -> Node -> [Node] 
neighbors = (\(p,_,_,s) -> map snd (p++s)) .: context

-- | Find all 'Node's that have a link from the given 'Node'.
suc :: Graph gr => gr a b -> Node -> [Node]
suc = map snd .: context4

-- | Find all 'Node's that link to to the given 'Node'.
pre :: Graph gr => gr a b -> Node -> [Node] 
pre = map snd .: context1

-- | Find all 'Node's that are linked from the given 'Node' and the label of
-- each link.
lsuc :: Graph gr => gr a b -> Node -> [(Node,b)]
lsuc = map flip2 .: context4

-- | Find all 'Node's that link to the given 'Node' and the label of each link.
lpre :: Graph gr => gr a b -> Node -> [(Node,b)] 
lpre = map flip2 .: context1

-- | Find all outward-bound 'LEdge's for the given 'Node'.
out :: Graph gr => gr a b -> Node -> [LEdge b] 
out g v = map (\(l,w)->(v,w,l)) (context4 g v)

-- | Find all inward-bound 'LEdge's for the given 'Node'.
inn :: Graph gr => gr a b -> Node -> [LEdge b] 
inn g v = map (\(l,w)->(w,v,l)) (context1 g v)

-- | The outward-bound degree of the 'Node'.
outdeg :: Graph gr => gr a b -> Node -> Int
outdeg = length .: context4

-- | The inward-bound degree of the 'Node'.
indeg :: Graph gr => gr a b -> Node -> Int
indeg  = length .: context1

-- | The degree of the 'Node'.
deg :: Graph gr => gr a b -> Node -> Int
deg = (\(p,_,_,s) -> length p+length s) .: context

-- | The 'Node' in a 'Context'.
node' :: Context a b -> Node
node' (_,v,_,_) = v

-- | The label in a 'Context'.
lab' :: Context a b -> a
lab' (_,_,l,_) = l

-- | The 'LNode' from a 'Context'.
labNode' :: Context a b -> LNode a
labNode' (_,v,l,_) = (v,l)

-- | All 'Node's linked to or from in a 'Context'.
neighbors' :: Context a b -> [Node] 
neighbors' (p,_,_,s) = map snd p++map snd s

-- | All 'Node's linked to in a 'Context'.
suc' :: Context a b -> [Node]
suc' (_,_,_,s) = map snd s

-- | All 'Node's linked from in a 'Context'.
pre' :: Context a b -> [Node] 
pre' (p,_,_,_) = map snd p

-- | All 'Node's linked from in a 'Context', and the label of the links.
lpre' :: Context a b -> [(Node,b)] 
lpre' (p,_,_,_) = map flip2 p

-- | All 'Node's linked from in a 'Context', and the label of the links.
lsuc' :: Context a b -> [(Node,b)]
lsuc' (_,_,_,s) = map flip2 s

-- | All outward-directed 'LEdge's in a 'Context'.
out' :: Context a b -> [LEdge b] 
out' (_,v,_,s) = map (\(l,w)->(v,w,l)) s

-- | All inward-directed 'LEdge's in a 'Context'.
inn' :: Context a b -> [LEdge b] 
inn' (p,v,_,_) = map (\(l,w)->(w,v,l)) p

-- | The outward degree of a 'Context'.
outdeg' :: Context a b -> Int
outdeg' (_,_,_,s) = length s

-- | The inward degree of a 'Context'.
indeg' :: Context a b -> Int
indeg' (p,_,_,_) = length p

-- | The degree of a 'Context'.
deg' :: Context a b -> Int
deg' (p,_,_,s) = length p+length s


-- graph equality
--
nodeComp :: Eq b => LNode b -> LNode b -> Ordering
nodeComp n@(v,_) n'@(w,_) | n == n'   = EQ
                          | v<w       = LT
                          | otherwise = GT

slabNodes :: (Eq a,Graph gr) => gr a b -> [LNode a]
slabNodes = sortBy nodeComp . labNodes

edgeComp :: Eq b => LEdge b -> LEdge b -> Ordering
edgeComp e@(v,w,_) e'@(x,y,_) | e == e'              = EQ
                              | v<x || (v==x && w<y) = LT
                              | otherwise            = GT

slabEdges :: (Eq b,Graph gr) => gr a b -> [LEdge b]
slabEdges = sortBy edgeComp . labEdges

-- instance (Eq a,Eq b,Graph gr) => Eq (gr a b) where
--   g == g' = slabNodes g == slabNodes g' && slabEdges g == slabEdges g'

equal :: (Eq a,Eq b,Graph gr) => gr a b -> gr a b -> Bool
equal g g' = slabNodes g == slabNodes g' && slabEdges g == slabEdges g'


----------------------------------------------------------------------
-- UTILITIES
----------------------------------------------------------------------


-- auxiliary functions used in the implementation of the 
-- derived class members
-- 
(.:) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d)
-- f .: g = \x y->f (g x y)
-- f .: g = (f .) . g
-- (.:) f = ((f .) .)
-- (.:) = (.) (.) (.)
(.:) = (.) . (.)

fst4 (x,_,_,_) = x
{- not used
snd4 (_,x,_,_) = x
thd4 (_,_,x,_) = x
-}
fth4 (_,_,_,x) = x

{- not used
fst3 (x,_,_) = x
snd3 (_,x,_) = x
thd3 (_,_,x) = x
-}

flip2 (x,y) = (y,x)


-- projecting on context elements
--
-- context1 g v = fst4 (contextP g v)
context1 :: Graph gr => gr a b -> Node -> Adj b
{- not used
context2 :: Graph gr => gr a b -> Node -> Node
context3 :: Graph gr => gr a b -> Node -> a
-}
context4 :: Graph gr => gr a b -> Node -> Adj b

context1 = fst4 .: context
{- not used
context2 = snd4 .: context
context3 = thd4 .: context
-}
context4 = fth4 .: context