------------------------->  GNU Sather - sourcefile  <-------------------------
-- Copyright (C) 1995 by International Computer Science Institute            --
-- This file is part of the GNU Sather package. It is free software; you may --
-- redistribute  and/or modify it under the terms of the  GNU General Public --
-- License (GPL)  as  published  by the  Free  Software  Foundation;  either --
-- version 2 of the license, or (at your option) any later version.          --
-- This  program  is distributed  in the  hope that it will  be  useful, but --
-- WITHOUT ANY WARRANTY without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See Doc/GPL for more details.        --
-- The license text is also available from:  Free Software Foundation, Inc., --
-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA                     --
-------------->  Please email comments to <bug-sather@gnu.org>  <--------------

-- graph_aux.sa: Classes that manipulate graphs
-- Author: Benedict A. Gomes <gomes@icsi.berkeley.edu>

class DIGRAPH_AUX{N,E,I,G < $DIGRAPH{N,E,I}} is
   -- Auxilliary functions for digraphs. These functions will work on
   -- any $DIGRAPH.  An alternative way to implement this functionality
   -- is by the use of a partial include class with stub routines.
   
   dfs(g: G,n: I): FLIST{I} is
      -- Return all the descendants of the node "n" in graph g
      -- in depth first order
      stack: FLIST{I} := g.children(n);
      res ::= #FLIST{I};
      seen: FSET{I};
      loop until!(stack.is_empty);
	 cur ::= stack.pop;
	 if ~(seen.test(cur)) then
	    -- visit cur
	    res := res.push(cur);
	    seen := seen.insert(cur);
	    children ::= g.children(cur);
	    loop 
	       -- Add children to stack.
	       child ::= children.elt!;
	       if (~seen.test(child)) then  stack := stack.push(child);  end;
	    end;
	 end; -- If not seen
      end; -- Until stack is empty
      return(res);      
   end;

   dfs_ancestors(g: G, n: I): FLIST{I} is
      -- Return the ancestors of this node in depth first order
      stack: FLIST{I} := g.parents(n);
      res ::= #FLIST{I};
      seen: FSET{I};
      loop until!(stack.is_empty);
	 cur ::= stack.pop;
	 if ~(seen.test(cur)) then
	    -- visit cur
	    res := res.push(cur);
	    seen := seen.insert(cur);
	    parents ::= g.parents(cur);
	    loop 
	       -- Add children to stack.
	       parent ::= parents.elt!;
	       if (~seen.test(parent)) then  stack := stack.push(parent);  end;
	    end;
	 end; -- If not seen
      end; -- Until stack is empty
      return(res);      
   end;
   
   bfs(g: G, n: I): FLIST{I} is
      -- Return all descendants in breadth first order
      init: FLIST{I} := g.children(n);
      q ::= #A_QUEUE{I};
      loop q.enq(init.elt!); end;
      res ::= #FLIST{I};
      seen: FSET{I};
      loop until!(q.is_empty);
	 cur ::= q.remove;
	 if ~(seen.test(cur)) then
	    -- visit cur
	    res := res.push(cur);
	    seen := seen.insert(cur);
	    children ::= g.children(cur);
	    loop 
	       -- Add children to the queue
	       child ::= children.elt!;
	       if (~seen.test(child)) then  q.enq(child);  end;
	    end;
	 end; -- If not seen
      end; -- Until stack is empty
      return(res);      
   end;
   
   bfs_ancestors(g: G, n: I): FLIST{I} is
      -- Return all ancestors in breadth first order
      init: FLIST{I} := g.parents(n);
      q ::= #A_QUEUE{I};
      loop q.enq(init.elt!); end;
      res ::= #FLIST{I};
      seen: FSET{I};
      loop until!(q.is_empty);
	 cur ::= q.remove;
	 if ~(seen.test(cur)) then
	    -- visit cur
	    res := res.push(cur);
	    seen := seen.insert(cur);
	    parents ::= g.parents(cur);
	    loop 
	       -- Add children to stack.
	       parent ::= parents.elt!;
	       if (~seen.test(parent)) then  q.enq(parent);  end;
	    end;
	 end; -- If not seen
      end; -- Until stack is empty
      return(res);      
   end;
   
   topo_order!(g: G): I is
      -- Yield node indices in topological order
      if g.is_empty then quit end; 
      tup ::= get_n_parents(g);
      current_indeg ::= tup.t1;
      root_nodes ::= tup.t2;
      loop while!(root_nodes.size > 0);
	 ni ::= root_nodes.pop;
	 -- Yield the next node in topological order
	 yield(ni);
	 loop targi ::= g.children(ni).elt!;
	    targind ::= current_indeg.get(targi);
	    current_indeg := current_indeg.insert(targi,targind-1);
	    if (targind = 1) then  root_nodes := root_nodes.push(targi);  end;
	 end;
      end;
   end;

   inds_to_nodes(g: G, f: FLIST{I}): FLIST{N} is
      -- Convert a list of indices to a list of nodes
      res ::= #FLIST{N};
      loop res := res.push(g.node(f.elt!)) end; 
      return(res);
   end;
   
   private get_n_parents(g: G): TUP{FMAP{I,INT},FLIST{I}} is
      -- Return a mapping from nodes to their current n_parents
      -- And a list of the root nodes (0 n_parents)
      indeg ::= #FMAP{I,INT}; -- Parents
      root_nodes ::= #FLIST{I};
      -- Determine roots
      loop n: I := g.node_indices.elt!;
	 deg ::= g.n_parents(n);
	 indeg := indeg.insert(n,deg);
	 if (deg = 0) then root_nodes := root_nodes.push(n); end;
      end;
      return(#TUP{FMAP{I,INT},FLIST{I}}(indeg,root_nodes));
   end;
   
--   equal(g1: $IN_DIGRAPH{N,E,I},g2:$IN_DIGRAPH{N,E,I}): BOOL is
      -- Return true if the two graphs are the same
--      #ERR+"Not yet defined
--   end;

-- Trivial node and edge tests for creating subgraphs ----
   any_edge(n1,n2:N,e:E): BOOL is return(true) end;
   
   any_node(n: N): BOOL is return(true) end;
----------------------------------------------------------   
   union(g1,g2,out_:G) is
      -- Create the union of g1 and g2 in "out"
      -- First add g1 to out then add g2 to out
      add_subgraph(g1,bind(any_node(_)),out_);
      add_subgraph(g2,bind(any_node(_)),out_);
   end;
   
   add_subgraph(in_: G, nt: ROUT{N}:BOOL,out_:G) is
      -- Add all nodes that satisfy "nt" and all the edges between
      -- these nodes to out
      nodes: FLIST{N} := node_subset(in_,nt);
      add_nodes(out_,nodes);
      add_relevant_edges(out_,all_edges(in_));
   end;

   all_edges(g: G): FLIST{TUP{N,N}} is
      et: ROUT{N,N,E}:BOOL; 
      et := bind(any_edge(_,_,_));      
      all: FLIST{TUP{N,N}} := edge_subset(g,et);
      return(all);
   end;
   
   edge_subset(g: G, et: ROUT{N,N,E}:BOOL): FLIST{TUP{N,N}} is
      -- Return a set of edge tuples that are true for test "et"
      -- Note that the edges returned are tuples of nodes, not of node indices
      res ::= #FLIST{TUP{N,N}};
      loop 
	 t ::= g.nodes.elt!;
	 ti ::= g.node_index(t);
	 loop
	    si ::= g.parents(ti).elt!;
	    s ::= g.node(si);
	    e ::= g.edge(si,ti);
	    if (et.call(s,t,e)) then
	       res := res.push(#TUP{N,N}(s,t));
	    end;
	 end;
      end;
      return(res);
   end;
   
   node_subset(g: G, nt: ROUT{N}:BOOL): FLIST{N} is
      -- Return the set of all nodes in g that satisfy the node test "nt"
      res ::= #FLIST{N};
      loop n ::= g.nodes.elt!;
	 if (nt.call(n)) then  res := res.push(n); end;
      end;
      return(res);
   end;
   
   add_nodes(g: G, ns: FLIST{N}) is
      -- Add the nodes from ns that are not already in the graph "g"
      loop n ::= ns.elt!;
	 if ~(g.has_node(n)) then   g.add_node(n); end;
      end;
   end;
   
   add_relevant_edges(g: G, edges: FLIST{TUP{N,N}}) is
      -- Add the set of edges  to the graph "g", provided that the
      -- source and target nodes already exist in "g"
      loop
	 e ::=edges.elt!;
	 s ::= e.t1; t ::= e.t2;
	 if (g.has_node(s) and g.has_node(t)) then
	    si ::= g.node_index(s);
	    ti ::= g.node_index(t);
	    if ~(g.has_edge(si,ti)) then  g.connect(si,ti);  end;
	 end;
      end;
   end;
   
   add_node_subset(in_: $DIGRAPH{N,E,I}, nt: ROUT{N}:BOOL,
	    out_:$DIGRAPH{N,E,I}) is
      -- To "out" will be added all nodes from "in"
      -- that satisfy the node test "nt".
      -- No edges will be added
      loop n ::= in_.nodes.elt!;
	 if (nt.call(n)) then 
	    if (~out_.has_node(n)) then
	       discard ::= out_.add_node(n);  
	    end;
	 end;
      end;
   end;
   
   add_edge_subset(in_: $DIGRAPH{N,E,I},et: ROUT{N,N,E}:BOOL, 
              out_: $DIGRAPH{N,E,I}) is
      -- Add any edges from the source graph "in" that meet the test "et" 
      -- provided that the nodes it is attached to are both in the "out"
      -- graph
      -- Note: Node indices may be different in the in and out graphs!
      -- Must traverse using node indices
      -- note:This index <-> node conversion is a pain and error-prone
      loop 
	 t ::= out_.nodes.elt!;
	 in_ti ::= in_.node_index(t);
	 loop 
	    in_si ::= in_.parents(in_.node_index(t)).elt!;
	    s ::= in_.node(in_si);	-- Find the source node
	    if out_.has_node(s) then
	       e ::= in_.edge(in_si,in_ti);
	       if (et.call(s,t,e)) then 
		  out_si ::= out_.node_index(s);
		  out_ti ::= out_.node_index(t);
		  if ~(out_.has_edge(out_si,out_ti)) then
		     -- Connect the appropriate nodes in the outgraph
		     out_.connect(out_.node_index(s),out_.node_index(t),e); 
		  end; -- If the edge is not in the out graph already
	       end; -- If the edge condition is true
	    end; -- If the out graph has the source node
	 end; -- Loop over parents edges
      end; -- Loop over the (target) nodes in the out graph
   end;

   --------------------------------- LAYOUT ROUTINES ----------------------
   get_plain_layout(g: G): FLIST{FLIST{I}} is
      -- Return layout as a "layered" list of lists of node indices
      layout ::= #FLIST{FLIST{I}};
      ready_set::=#FLIST{I};
      new_set:FLIST{I};
      n_parents::=#FMAP{I,INT};	-- Number of currently active parents

      -- intialize ready_set to hold nodes with no parents,
      -- and n_parents to hold n_parents
      loop ni ::= g.node_indices.elt!;
	 deg ::= g.n_parents(ni);
	 n_parents := n_parents.insert(ni,deg);
	 if (deg = 0) then  ready_set := ready_set.push(ni); end;
      end;
      
      -- At iteration(n), the ready set includes all nodes that
      -- are at depth <= n (minimum depth = n)
      -- If any of these nodes has no parents, it is emitted
      loop until!(ready_set.is_empty);
	 new_set:=#FLIST{I};
	 next_ready_set::=#FLIST{I};
	 -- Generate the next layer of nodes
	 loop r:I := ready_set.elt!;
	    -- Find out which of the nodes in the next layer are roots
	    cnt ::= n_parents.get(r);
	    if cnt=0 then     -- If r has no more parents, it is a new root
	       new_set := new_set.push_if_new(r);
	    end;
	 end;
	 
	 -- Look at the children of the current layer of nodes
	 loop r:I := ready_set.elt!;
	    if new_set.contains(r) then
	       -- Add all the children of the done nodes to the next ready set
	       children:FLIST{I}:= g.children(r);
	       loop child: I := children.elt!;
		  sc: INT := n_parents.get(child);
		  n_parents := n_parents.insert(child,sc-1);
		  next_ready_set:=next_ready_set.push_if_new(child);
	       end;
	    else
	       -- If r is not done, carry it over to next iteration.
	       -- This line accumulates the undone nodes at depth < n at iter n
	       next_ready_set:=next_ready_set.push_if_new(r);
	    end;
	 end;
	 ready_set:=next_ready_set;
	 layout:=layout.push(new_set);
      end;
      return(layout);
   end;

   get_layout(in_g: G): LAYOUT{I} is
      -- Convert the layered form of the graph to locations for each node
      -- in the unit square
      layout ::= get_plain_layout(in_g);
      -- First get the depth
      depth: INT := layout.size;
      -- Then the width
      widest: INT := 0;
      loop layer: FLIST{I} := layout.elt!;
	 if (layer.size > widest) then widest := layer.size; end;
      end;

      res ::= #LAYOUT{I}(depth,widest);      
      widest := widest.max(2);
      depth := depth.max(2);
      per_layer_depth: FLT := 1.0/((depth-1).flt);
      per_column_width: FLT := 1.0/((widest-1).flt);
      -- Then insert all the elements into the fmap acc to position
      loop d: INT := layout.size.times!;
	 layer: FLIST{I} := layout[d];
	 loop w: INT := layer.size.times!;
	    elt: I := layer[w];
	    x ::= (w.flt+1.0)/(layer.size+1).flt;
	    -- ----------- MODIFIED, not tested! -------------------------
	    -- Original line:
	    --	    y ::= d.flt*per_layer_depth;
	    -- Modification suggested by Yon Uriarte
	    y: FLT;
	    if layer.size > 3 then
	       -- Stagger the nodes in a layer, if there are more than 3
	       -- so that the text is more visible
	       y := d.flt*per_layer_depth+w.band(1).flt*per_layer_depth*0.2;
	    else 
	       y := d.flt*per_layer_depth;
	    end;
	    -- ------------------------------------------------------------
	    res.add_node(elt,x,y);
	 end;	    
      end;
      return(res);
   end;

   ----------------------------- PRINTOUT ROUTINES -------------------------
   str(g: G): STR is
      return(str(g,bind(default_node_print(_)),bind(default_edge_print(_))));
   end;
   
   private default_node_print(n: N): STR is
      -- The default node print function used by str: STR 
      -- User .str if the node is < $STR, return the empty string otherwise
      typecase n
      when $STR then return(n.str); 
      else return("") end;
   end;
   
   private default_edge_print(e:E): STR is
      typecase e
      when $STR then return(e.str) 
      else return("") end;
   end;
   
   str(g: G, npf: ROUT{N}:STR, epf:ROUT{E}: STR): STR is
      -- Print out the graph using the node print function 
      -- to print out the value of a node.
      -- npf - node print function - takes a node as argument
      -- epf - edge print function - takes an edge as argument
      -- Then the edges, one to a line, preceeded by Parents:
      res ::= #FSTR("");
      loop n ::= g.node_indices.elt!;
	 res := res + npf.call(g.node(n))+" : ";
	 loop
	    in_ ::= g.parents(n).elt!;
	    res := res + " "+ npf.call(g.node(in_));
	    edge: E;
	    typecase edge 
	    when NULL then     -- Do nothing
	    else
	       e ::= g.edge(in_,n);
	       res := res + ","+epf.call(e);
	    end;
	 end; -- All parents edges
	 res := res+"\n";		-- End of another row of edges
      end; -- All graph nodes
      return(res.str);
   end;      

   in_edges_str(g: G,n: N,np: ROUT{N}:STR): STR is
      -- Return a string representing the parents edges to node n
      -- printed out with the node print function np
      res ::= "\tParents Edges: ";
      ni ::= g.node_index(n);
      loop 
	 inn ::= g.parents(ni).elt!;
	 res := res + " "+np.call(g.node(inn));
      end;
      return(res);
   end;
   

   
end;
---------------------------------------------------------------   
class LAYOUT{I} is
   -- Auxilliary class that holds layout information for the return
   -- value of the layout routines above

   -- Corresponding sets of nodes and locations
   readonly attr nodes: FLIST{I};
   readonly attr xlocs: FLIST{FLT};
   readonly attr ylocs: FLIST{FLT};
   readonly attr depth: INT;
   readonly attr width: INT;
   
   create(d,w: INT): SAME is 
      res ::= new;
      res.depth := d;
      res.width := w;
      return(res);
   end;
   
   add_node(n: I,x,y: FLT) is
      nodes := nodes.push(n);
      xlocs := xlocs.push(x);
      ylocs := ylocs.push(y);
   end;
   
end;
-------------------------------------------------------------------
