-- Copyright 1993-1998, by the Cecil Project
-- Department of Computer Science and Engineering, University of Washington
-- See the LICENSE file for license information.

(--
Partial order graph type.  Supports downwards and upwards traversals.
--)


-- concrete children of partial_order_nodes provide the ordering and hashing 
-- operators

abstract object partial_order_node[Node <= partial_order_node[Node]]
		isa graph_node[Node,partial_order_edge[Node]],
		    partially_ordered[partial_order_node[Node]],
 		    hashable[partial_order_node[Node]];
  var field marked(@:partial_order_node[`Node]):bool := false;

  method up_nodes_do(t@:partial_order_node[`Node],
		     bl:&(Node):void):void {
      t.out_edges.do(&(e:partial_order_edge[Node]){ eval(bl, e.to_node); });
  }
  method down_nodes_do(t@:partial_order_node[`Node],
		       bl:&(Node):void):void {
      t.in_edges.do(&(e:partial_order_edge[Node]){ eval(bl, e.from_node); });
  }
  method traverse_up(t@partial_order_node[`Node]
		      :`Node <= partial_order_node[Node],
	             cl:&(Node):void):void {
      if_false(t.marked, {
	  -- Only proceed if we're done with all children
	  t.in_edges.do(&(e:partial_order_edge[Node]){
	      if_false(e.from_node.marked, { ^ });
	  });
	  t.marked := true;
	  eval(cl, t);
	  t.out_edges.do(&(e:partial_order_edge[Node]){
	      e.to_node.traverse_up(cl);
	  });
      });
  }
  method traverse_down(t@partial_order_node[`Node]
		        :`Node <= partial_order_node[Node],
		       cl:&(Node):void):void {
      if_false(t.marked, {
	  -- Only proceed if we're done with all parents
	  t.out_edges.do(&(e:partial_order_edge[Node]){
	      if_false(e.to_node.marked, { ^ });
	  });
	  t.marked := true;
	  eval(cl, t);
	  t.in_edges.do(&(e:partial_order_edge[Node]){
	      e.from_node.traverse_down(cl);
	  });
      });
  }

  method order_print_string(t@:partial_order_node[`Node]):string {
      let var s:string := t.print_string;
      if(t.out_edges.non_empty, {
	  s := s || " < ";
	  let var first:bool := true;
	  t.up_nodes_do(&(n:Node){
	      if(first, { first := false; }, { s := s || ", "; });
	      s := s || n.print_string;
	  });
      });
      s }


template object partial_order_edge[Node <= partial_order_node[Node]]
		isa graph_edge[Node,partial_order_edge[Node]];
  method new_partial_order_edge(f@partial_order_node[`Node]
				 :`Node <= partial_order_node[Node],
				t:Node):partial_order_edge[Node] {
    concrete object isa partial_order_edge[Node] {
	from_node := f, to_node := t } }


template object partial_order[Node <= partial_order_node[Node]];
  -- all the nodes of the graph
  field nodes(@:partial_order[`Node]):m_set[Node] := new_hash_set[Node]();
  -- tops have no outgoing edges
  field tops(@:partial_order[`Node]):m_set[Node] := new_hash_set[Node]();
  -- bottoms have no incoming edges
  field bottoms(@:partial_order[`Node]):m_set[Node] := new_hash_set[Node]();

  method add_node(t@:partial_order[`Node], node:Node):void {
      t.nodes.add(node);
  }
  method add_partial_order_edges(t@:partial_order[`Node]):void {
      -- Examine each node to find the smallest node larger than it in the
      -- partial order.  This is a little more complicated because we want
      -- to avoid putting in the transitive links.
      t.nodes.do(&(node:Node){
	  let min_set:m_set[Node] := new_hash_set[Node]();
	  t.nodes.do(&(n:Node){
	      if(node < n, {
		  exit(&(exit:&():none){
		      min_set.do(&(cur_min:Node){
			  if(cur_min < n, exit);
		      });
		      min_set.add(n);
		  });
	      });
	  });
	  min_set.do(&(n:Node){
	      t.add_edge(new_partial_order_edge(node,n));
	  });
      });
      -- Now go over the nodes and determine which ones are bottoms and tops
      -- in the partial order
      t.bottoms.remove_all;
      t.tops.remove_all;
      t.nodes.do(&(node:Node){
	  if(node.in_edges.is_empty, {
	      t.bottoms.add(node);
	  });
	  if(node.out_edges.is_empty, {
	      t.tops.add(node);
	  });
      });
  }

  method add_edge(t@:partial_order[`Node], e:partial_order_edge[Node]):void {
      add_edge(e);
  }

  method remove_edge(t@:partial_order[`Node], e:partial_order_edge[Node]):void {
      -- Remove an edge from the partial order.  If any new nodes become tops
      -- or bottoms as a result of the deletion of the edge, add them to the
      -- tops or bottoms set.
      e.from_node.out_edges.remove(e);
      if(e.from_node.out_edges.is_empty, {
	  t.tops.add(e.from_node);
      });

      e.to_node.in_edges.remove(e);
      if(e.to_node.in_edges.is_empty, {
	  t.bottoms.add(e.to_node);
      });
  }

  method remove_node(t@:partial_order[`Node], node:Node):void {
      -- First add all the implied transitive links that should be put in
      -- after removing this node.
      node.in_edges.do(&(below_edge:partial_order_edge[Node]){
	  node.out_edges.do(&(above_edge:partial_order_edge[Node]){
	      assert(below_edge.to_node = node, "edge mismatch");
	      assert(above_edge.from_node = node, "edge mismatch");
	      t.add_edge(new_partial_order_edge
			   (below_edge.from_node,above_edge.to_node));
	  });
      });
      -- Now remove edges into and out of this node
      node.in_edges.do_allowing_updates(&(below_edge:partial_order_edge[Node]){
	  t.remove_edge(below_edge);
      });
      node.out_edges.do_allowing_updates(&(above_edge:partial_order_edge[Node]){
	  t.remove_edge(above_edge);
      });

      -- Now remove the node
      t.nodes.remove(node);
      t.bottoms.remove(node, { });
      t.tops.remove(node, { });
  }

  method top_down_do(t@:partial_order[`Node], cl:&(Node):void):void {
      t.clear_marks;
      t.tops.do(&(n:Node){ n.traverse_down(cl); });
  }
  method bottom_up_do(t@:partial_order[`Node], cl:&(Node):void):void {
      t.clear_marks;
      t.bottoms.do(&(n:Node){ n.traverse_up(cl); });
  }


  method print_header(g@:partial_order[`Node]):string {
    "partial order of " || g.nodes.length.print_string || " nodes\n" }

  method print_headers(t@:partial_order[`Node]):string {
    let var s:string := "";
    t.bottom_up_do(&(n:Node){
	s := s || n.order_print_string || "\n";
    });
    s }

  method print_string(t@:partial_order[`Node]):string {
    t.print_header || t.print_headers }

  method print(t@:partial_order[`Node]):void {
    t.print_header.print;
    t.bottom_up_do(&(n:Node){
	n.order_print_string.print_line;
    });
  }

  method clear_marks(g@:partial_order[`Node]):void {
    g.nodes.do(&(n:Node){ n.marked := false; }); }

  method new_partial_order[Node <= partial_order_node[Node]]
			  ():partial_order[Node] {
      concrete object isa partial_order[Node] }