ugraph_incl.sa
Generated by gen_html_sa_files from ICSI. Contact gomes@icsi.berkeley.edu for details
---------------------------> Sather 1.1 source file <--------------------------
-- Author: Benedict A. Gomes <gomes@tiramisu.ICSI.Berkeley.EDU>
-- COPYRIGHT NOTICE: This code is provided WITHOUT ANY WARRANTY
-- and is subject to the terms of the SATHER LIBRARY GENERAL PUBLIC
-- LICENSE contained in the file: Sather/Doc/License of the
-- Sather distribution. The license is also available from ICSI,
-- 1947 Center St., Suite 600, Berkeley CA 94704, USA.
partial class UGRAPH_INCL{NTP} < $UGRAPH{NTP}
partial class UGRAPH_INCL{NTP} < $UGRAPH{NTP} is
-- Partial class used to define useful routines in undirected
-- graphs that are based on a core set of (undefined) routines
-- The core routines must be defined by a particular implementation
-- upon inclusion
private include COMPARE{NTP};
-- ------------------- Stubs: Must redefine ------------
stub add_node: NTP;
stub add_node(n: NTP);
stub add_node(n: NTP):NTP;
stub connect(n1,n2: NTP);
stub delete_node(n: NTP);
stub disconnect(n1,n2: NTP);
stub node!: NTP;
stub adjacent!(once n: NTP): NTP;
stub copy: SAME;
stub create: SAME;
-- Some of the routines need to create a "fresh" graph.
-- ------------------- Insertion -----------------------
connect(e: UEDGE{NTP}) is connect(e.first,e.second) end;
disconnect(e: UEDGE{NTP}) is disconnect(e.first,e.second) end;
-- ------------------- Access --------------------------
nodes: SET{NTP} is
res: SET{NTP}; loop res.insert(node!) end; return res;
end;
edges: SET{UEDGE{NTP}} is
res: SET{UEDGE{NTP}} := #; loop res.insert(edge!) end; return res;
end;
adjacent(n: NTP): SET{NTP} is
res: SET{NTP} := #; loop res.insert(adjacent!(n)) end; return res;
end;
reachable_from(n: NTP): SET{NTP} is
-- Returns the set of nodes reachable from "n"
res: SET{NTP}; loop res.insert(reachable_from!(n)) end; return res;
end;
roots: SET{NTP} is
-- Returns a list of "representative" nodes from which the
-- whole graph is reachable.
-- With inout args, also return a mapping from nodes to the
-- appropriate representative nodes (i.e. seen)
seen: FSET{NTP};
roots:SET{NTP};
loop n ::= node!;
if ~seen.test(n) then
roots.insert(n);
loop seen := seen.insert(reachable_from!(n)); end;
end;
end;
return roots;
end;
node_depths(n: NTP,map:$MAP{NTP,INT}) is
-- map should be inout, but this will work for now
-- Do a bfs and return depths of each node
d ::= 1; loop map[bfs!(n)] := d; d := d + 1; end;
end;
-- ------------------- Queries -------------------------
has_node(n: NTP): BOOL is
loop if elt_eq(n,node!) then return true end; end;
return false;
end;
has_edge(first,second: NTP): BOOL is
loop e ::= edge!;
if elt_eq(e.first,first) and elt_eq(e.second,second) then
return true;
end;
end;
return false;
end;
has_edge(e: UEDGE{NTP}):BOOL is return has_edge(e.first,e.second) end;
are_connected(n1,n2: NTP): BOOL is
-- Return true if there exists a path from n1 to n2
loop n: NTP := dfs!(n1);
if elt_eq(n,n2) then return true; end;
end;
return false;
end;
is_empty: BOOL is return(n_nodes = 0) end;
has(n: NTP): BOOL is return has_node(n) end;
n_reachable_from(n: NTP): INT is
i: INT := 0; loop discard ::= reachable_from!(n); i := i + 1; end;
return i
end;
n_edges: INT is
i: INT := 0; loop e ::= edge!; i := i + 1; end;
return i
end;
n_nodes: INT is
i: INT := 0; loop e ::= node!; i := i + 1; end;
return i
end;
size: INT is return n_nodes end;
n_adjacent(n: NTP): INT is
i: INT := 0;
loop adj_n ::= adjacent!(n); i := i + 1; end;
return i;
end;
-- ------------------- Cursor --------------------------
elt!: NTP is loop yield node! end; end;
edge!: UEDGE{NTP} is
seen: FSET{NTP} := #;
loop n ::= node!;
seen := seen.insert(n);
loop
neigh ::= adjacent!(n);
if ~seen.test(neigh) then yield #UEDGE{NTP}(n,adjacent!(n)); end;
-- Avoid yielding edges twice, from both directions
end;
end;
end;
filter_edge!(once pred: ROUT{UEDGE{NTP}}:BOOL):UEDGE{NTP} is
-- Return a set of edge tuples that are true for test "et"
loop e ::= edge!; if pred.call(e) then yield(e) end; end;
end;
filter_node!(once pred: ROUT{NTP}:BOOL): NTP is
-- Return the set of all nodes in g that satisfy the node test "nt"
loop n ::= node!; if pred.call(n) then yield n end end;
end;
bfs!(once n: NTP): NTP is
-- Return all nodes reachable from "n" in bf order
seen: FSET{NTP} := #;
q: A_QUEUE{NTP} := #;
q.enq(n);
loop until!(q.is_empty);
current ::= q.remove;
yield current;
loop adjacent ::= adjacent!(current);
if ~seen.test(adjacent) then
q.enq(adjacent);
seen:=seen.insert(adjacent);
end;
end;
end;
end;
dfs!(once n: NTP): NTP is
-- Return all nodes reachable from "n" in df order
stack ::= #FLIST{NTP}; stack := stack.push(n);
seen ::= #FSET{NTP}; seen := seen.insert(n);
loop until!(stack.is_empty);
cur ::= stack.pop;
yield cur; -- Actual visit
loop neigh ::= adjacent!(cur);
if ~seen.test(neigh) then
stack:=stack.push(neigh);
seen:=seen.insert(neigh);
end; -- else ( Adjacent has been seen before => backedge.)
end;
end; -- Until stack is empty
end;
reachable_from!(once n: NTP): NTP is
-- Returns successive nodes reachable from "n"
-- using dfs
loop yield dfs!(n) end;
end;
-- ------------------- Comparison ----------------------
equals(g: $RO_UGRAPH{NTP}): BOOL is
-- Check that nodes and edges are the same
-- Very inefficient n^2 version - sort for nlogn version
if ~has_same_nodes(g) then return false end;
loop e ::= edge!; if ~g.has_edge(e) then return false end; end;
loop e ::= g.edge!; if ~has_edge(e) then return false end; end;
return(true);
end;
has_same_nodes(g: $RO_UGRAPH{NTP}): BOOL is
if n_nodes /= g.n_nodes then return false end;
loop n ::= g.node!; if ~has_node(n) then return false end; end;
return true;
end;
-- ------------------- Transformation ------------------
to_union(g: $UGRAPH{NTP}) is
loop add_node(g.node!) end;
loop connect(g.edge!) end;
end;
to_difference(g: $UGRAPH{NTP}) is
loop e ::= edge!;
if g.has_edge(e) then
disconnect(e);
f ::= e.first; s ::= e.second;
if n_adjacent(f) = 0 then delete_node(f) end;
if n_adjacent(s) = 0 then delete_node(s) end;
end;
end;
end;
dfs_apply(n: NTP,prewk:ROUT{NTP},postwk:ROUT{UEDGE{NTP}}) is
-- Perform pre work before visiting a node and
-- perform postwk on the way back up each edge
-- Recursive version of dfs (much simpler to code)
-- Here postwork is applied to *all* edges, including back edges
if void(postwk) then dfs_apply(n,prewk);
else dfs_rec(#FSET{NTP},n,prewk,postwk);
end;
end;
dfs_apply(n: NTP,wk:ROUT{NTP}) is
-- Apply the pre visit work "wk" to nodes in df order. Non recursive
stack: FLIST{NTP} := #;
seen ::= #FSET{NTP};
seen := seen.insert(n);
stack := stack.push(n);
loop until!(stack.is_empty);
cur ::= stack.pop;
wk.call(cur);
loop adjacent ::= adjacent!(cur);
if ~seen.test(adjacent) then
stack:=stack.push(adjacent);
seen:=seen.insert(adjacent);
end; -- else ( Adjacent has been seen before => backedge.)
end;
end; -- Until stack is empty
end;
to_transitive_closure is
-- Convert the graph to it's transitive closure
-- For a non-destructive version, first make a copy
loop
u ::= node!;
loop v ::= node!; if are_connected(u,v) then connect(u,v) end; end;
end;
end;
delete_reflexive_edges is
-- Delete all reflexive edges from the graph
loop e ::= edge!;
if elt_eq(e.first,e.second) then disconnect(e) end;
end;
end;
-- ------------------- Conversion ----------------------
str: STR is
return(str(bind(node_str(_))));
end;
private node_str(n: NTP): STR is
if void(n) then return("void") end;
typecase n
when $STR then return(n.str); else return("non-printable") end;
end;
str(f: ROUT{NTP}:STR): STR is
-- Print out the graph using the bound routine "f"
-- for the nodes
res ::= #FSTR("");
loop n ::= node!;
if void(n) then res := res + "void : ";
else res := res + f.call(n)+" : "; end;
loop
nm: STR := f.call(adjacent!(n));
res := res + ",".separate!(nm);
end; -- All parents edges
res := res+"\n"; -- End of another row of edges
end; -- All graph nodes
return(res.str);
end;
-- ------------------- Basic Operations ----------------
union(g: $UGRAPH{NTP}): $UGRAPH{NTP} is
res: SAME := copy;
res.to_union(g);
return res;
end;
difference(g:$UGRAPH{NTP}): $UGRAPH{NTP} is
res: SAME := copy;
res.to_difference(g);
return res;
end;
induced_subgraph(v: $SET{NTP}): $UGRAPH{NTP} is
-- Generate a subgraph which is induced by the edges "v".
res: SAME := #SAME;
loop n ::= node!;
res.add_node(n);
loop a ::= adjacent!(n);
if v.has(a) then res.connect(n,a) end;
end;
end;
return res;
end;
-- ------------------- Implementation ------------------
private dfs_rec(seen:FSET{NTP},n:NTP,bef:ROUT{NTP},aft:ROUT{UEDGE{NTP}}) is
-- Recursive depth first search, when both pre and postwork
-- must be done. Seen holds the list of nodes already seen
seen := seen.insert(n);
bef.call(n);
neigh: $ARR{NTP} := adjacent(n);
ni: INT; nsz: INT := neigh.size;
loop until!(ni=nsz);
child::=neigh[ni];
bef.call(child); -- Pre work on node
if ~seen.test(child) then
dfs_app_rec(seen,child,bef,aft);
aft.call(#UEDGE{NTP}(n,child)); -- Post work on edge
end;
ni := ni+1;
end;
end;
end; -- class UGRAPH_ALG_INCL