------------------------->  GNU Sather - sourcefile  <-------------------------
-- Copyright (C) 1995 by International Computer Science Institute            --
-- This file is part of the GNU Sather library. It is free software; you may --
-- redistribute  and/or modify it under the terms of the GNU Library General --
-- Public  License (LGPL)  as published  by the  Free  Software  Foundation; --
-- either version 2 of the license, or (at your option) any later version.   --
-- This  library  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/LGPL 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>  <--------------

-- Author: Benedict A. Gomes <gomes@samosa.ICSI.Berkeley.EDU>

class A_PQ{T < $IS_LT{T}} < $PQ{T} is
   --  E is the element type. 
   --  W is the weight type
   -- Priority queue implemented using an array based heap.  Retrieves
   -- maximal elements first.
   -- 
   -- Usage:
   --    a: PQ{INT} := #(#ARRAY{INT}(|2,3,4,5|));
   --    #OUT+a.pop+","+a.pop+","+a.pop; -- prints 5,4,3
   --    wrap: PQMIN{INT}; -- Used as a class alias for the create below
   --    a: PQ{PQMIN{INT}}:=#(|wrap.create(2),wrap.create(4),wrap.create(3)|);
   --    #OUT+a.pop+","+a.pop+","+a.pop; -- prints 1,3,4
   --    wrap: PQWT{STR,INT};
   --    a: PQ{PQWT{STR,INT}}:=#(wrap.create("a",1),wrap.create("b",2)|);
   --    #OUT+a.pop+","+a.pop+","+a.pop; -- prints "(b,2) (a,1)"
   -- 
   -- Design note: It is better to provide access to weight changing
   -- methods via an auxilliary wrapper, since that permits external
   -- objects to change the weight without searching through all
   -- elements
   private include COMPARE{T};
   
   private attr arr:ARRAY{T};                
   readonly attr size:INT;           -- Bottom of queue, = number of elements.
   
   create:SAME is
      -- A new empty priority queue.
      res ::= new; 
      res.arr:=#ARRAY{T}(2);	-- The first element goes into [1]
      res.size := 0;
      return(res);
   end; -- create

   create_sized(n:INT):SAME pre n >= 1 is
      -- A new empty priority queue, initially sized to hold `n' elements.
      res::=new; 
      res.arr:=#ARRAY{T}(n+1);
      res.size := 0;
      return(res);
   end; -- create_sized
   
   create(a: $ELT{T}): SAME is
      -- Return a new priority queue constructed out of the elements of
      -- "a"
      res ::= #SAME;
      loop res.insert(a.elt!) end;
      return res;
   end;
   
   create_from(a: ARRAY{T}): SAME is
      -- Permits use of the literal syntax using type inference
      return #SAME(a);
   end;
   
   is_empty:BOOL is
      -- True if queue is empty.
      return(size=0);
   end; -- is_empty

   current: T is return top end;
   
   top:T pre ~is_empty is return(arr[1]) end;
      -- Top element or `void' if empty.

   has(e: T): BOOL is 
      -- Whether the queue has "e"
      i::=1;  loop until!(i>size); 
	 if elt_eq(e,arr[i]) then return true; end;
	 i := i+1; 
      end;
      return false;
   end;

   delete(e:T): T is
      -- removes e from the heap if it is present and returns it
      -- otherwise returns void
      elm:T;
      i::=1; 
      loop until!(i>size);
	 if elt_eq(e, arr[i]) then
	    elm:=arr[i];
	    arr[i] := arr[size];
	    arr[size] := void;
	    size := size-1;
	    sift_dn(i,size);
	    return elm;
	 end;
	 i:=i+1;
      end;
      return elm;
   end;
   
   remove: T is return pop end;
   
   pop:T pre ~is_empty is
      -- Pops off the first element or `void' if empty.
      res::=arr[1];
      arr[1]:=arr[size];
      arr[size]:=void;          -- forget so gc can get what was there
      size:=size-1;             -- shrink queue
      sift_dn(1,size);          -- fix up heap
      return(res);
   end; -- pop

   insert(e:T) is
      -- Insert `e' into priority queue.
      if size>=arr.asize-2 then -- resize if area full
	 -- i.e. insert location(size+1) >= size of array(arr.asize-1)
	 -- Since we start off with an array of size 0, need to add 2 below
	 new_arr ::= #ARRAY{T}(2*arr.asize);
	 loop new_arr.set!(arr.elt!) end;
	 arr := new_arr;	-- Should discard the old one
         -- arr:=arr.extend(2*arr.asize) 
      end; 
      size:=size+1;
      arr[size]:=e;             -- put new element at bottom
      sift_up(1,size);           -- fix up the heap
   end; -- insert

   insert(e: T): SAME is insert(e); return self end;
   
   bounded_insert(e: T, bnd: INT) is
      -- Insert "e", then keep popping until there are fewer than "bnd"
      -- elements left 
      insert(e);
      loop until!(size <= bnd); discard ::= pop; end;
   end;

   pop!: T is
      -- Yield the elemnts of the queue in priority order, emptying the queue
      loop until!(is_empty); yield(pop); end;
   end;

   elt!: T is
      -- NOTE: In any order, NOT in priority order! 
      -- That would be much more expensive, and is probably best done
      -- by popping elemetns off and then putting them in another queue.
      i::=1;  loop until!(i>size); yield(arr[i]); i := i+1; end;
   end;
   
   clear is
      -- Clear the queue.
      arr.clear; size:=0;
   end; -- clear
   
   check_heap:BOOL is
      -- True if `self' is a legal heap.
      res::=true;
      i:INT:=1; loop until!(i>size); 
         if 2*i<=size then
	    if arr[i] < arr[2*i] then res:=false; break!; end;
         end; -- if
         if 2*i+1<=size then
	    if arr[i] < arr[2*i+1] then res:=false; break!; end;
         end; -- if
         i:=i+1
      end; -- loop
      return(res);
   end; -- check_heap

   private sift_up(l,u:INT) pre l>=1 and u>=1 and l<=u is
      -- Makes an `l,u' heap from a `l,u-1' heap in area.
      i:INT:=u; loop until!(i<=l);
         j:INT := i.rshift(1);
	 if arr[i] < arr[j] then break!;
         else 
            te:T:=arr[j]; arr[j]:=arr[i]; arr[i]:=te; -- swap i and j
            i := j
         end -- if
      end -- loop
   end; -- sift_up
   
   private sift_dn(l,u:INT) pre  l>=0 and u>=0 is
      -- Make an `l,u' heap from an `l+1,u' heap in area.
      i:INT:=l;
      loop
         c:INT:= 2 * i;
         if c>u then break! end;
	 -- bigger sib
         if 1+c<=u and (arr[c] < arr[c+1]) then c:=c+1 end;
	 if ~(arr[i]<arr[c]) then break!;
         else
            te:T:=arr[c]; arr[c]:=arr[i]; arr[i]:=te; -- swap i and c
            i:=c
         end -- if
      end -- loop
   end; -- sift_dn

   str: STR is return ELT_ALG{T}::str(self) end;
   -- Prints out a string version of the flist of the components 
   -- that are under $STR

   as_array:ARRAY{T} is 
      res ::= #ARRAY{T}(size); loop res.set!(elt!) end;  return res;
   end;
   
   copy: SAME is
      res ::= new;
      res.arr := arr.copy;
      res.size := size;
      return res;
   end;
   
end; -- class PQ
-------------------------------------------------------------------
immutable class PQMIN{T < $IS_LT{T}} < $IS_LT{PQMIN{T}} is
   -- Wrapper that inverts the < behavior, so that the priority queue
   -- will be sorted based on the > relationship i.e. minimal elements
   -- will be extracted first
   -- 
   include COMPARABLE;
   
   attr element: T;
   
   create(e: T): SAME is
      return element(e);
   end;

   is_eq(e: SAME): BOOL is
      return element = e.element;
   end;
   
   is_lt(e:SAME):BOOL is 
      -- Return true is self is GREATER than "e" i.e. invert the 
      -- relationship
      return element > e.element;
   end;
   
   str(e: T): STR is
      typecase e  when $STR then return e.str else return "Unknown" end;
   end;
   
end;
-------------------------------------------------------------------
class PQWT{E, WTP < $NUMBER{WTP}} < $IS_LT{PQWT{E,WTP}} is
   -- A wrapper class for priority queue elements in which a weight
   -- (which is different from the element itself) is used
   -- 
   -- Design note: This is not a immutable class since it is sometimes to
   -- be able to modify the weight of an inserted node without
   -- removing the element This would not be possible if the inserted
   -- element were a value type                                                
   include COMPARABLE;
   
   attr weight:WTP;
   attr element: E;
   
   create(node:E,weight: WTP): SAME is
      res ::= new;
      res.weight := weight;
      res.element :=node;
      return res;
   end;
   
   is_lt(e: SAME):BOOL is return weight < e.weight end;

   is_eq(e: SAME): BOOL is return weight = e.weight end;
   
   str: STR  is 
      res ::= "("+weight.str;
      n: E := element;
      typecase n  when $STR then res:=res+","+n.str; 
      else return "Unknown" end;
      res := res+")";
      return res;
   end;
   
end;
-------------------------------------------------------------------
class PQMINWT{E, WTP < $NUMBER{WTP}} < $IS_LT{PQMINWT{E,WTP}}, $STR is
   -- A wrapper class for priority queue elements in which a weight
   -- (which is different from the element itself) is used In
   -- addition, the comparison function for the weight is reversed so
   -- that smaller weights are considered larger. Thus, minimum elements
   -- will be removed from the priority queue first
   include COMPARABLE;
   
   attr weight:WTP;
   attr element: E;
   
   create(node:E,weight: WTP): SAME is
      res ::= new;
      res.weight := weight;
      res.element :=node;
      return res;
   end;
   
   is_lt(e: SAME):BOOL is return weight > e.weight end;
   
   is_eq(e: SAME):BOOL is return weight = e.weight end;
   
   str: STR  is 
      res ::= "("+wtstr(weight);
      n: E := element;
      typecase n  when $STR then res:=res+","+n.str; 
      else return "Unknown" end;
      res := res+")";
      return res;
   end;
   
   wtstr(w:WTP): STR is
      typecase w
      when $STR then return w.str
      else return "UnprintableWeight"; end
   end;
end;
-------------------------------------------------------------------
      
