------------------------->  GNU Sather - sourcefile  <-------------------------
-- Copyright (C) 1994 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>  <--------------

-- fqset.sa: Sets which support partial element state queries.
-------------------------------------------------------------------
class FQSET{Q,T} < $ELT{T} is
   -- Class to be inherited by hash array based sets of elements of
   -- type T, which support queries of type Q that depend only on part
   -- of the state of an element. Uses writebacks. 
   -- 
   -- Descendant will usually redefine: `query_test', `query_hash', and
   -- `elt_hash'. More rarely, it may also redefine: `elt_eq' and  
   -- `elt_nil'.
   -- 
   -- A table will never have two elements that are `elt_eq' to 
   -- each other, though there may be many elements responding to
   -- a particular query.
   --
   -- The tables grow by amortized doubling and so require writeback
   -- when inserting and deleting elements.
   -- The simple collision resolution allows us to support deletions,
   -- but makes the behavior quadratic with poor hash functions.
   -- Puts a sentinel at the end of the table to avoid one check while
   -- searching.
   private include COMPARE{T};
   private include AREF{T};
    
   private attr hsize:INT;	-- Number of stored entries.
    
   private const load_ratio:INT:=4; -- Allow to be at most 1/load_ratio full
    
   -- We can't have an invariant here, because we want to be able to
   -- destroy 'self' sometimes for efficiency.
   --invariant:BOOL is  return void(self) or hsize.is_bet(0,asize) end;
    
    
   create:SAME is return void end;

   create(n:INT):SAME 
   -- Make a table capable of dealing with `n' elements. You can
   -- simply insert into a void table to create one as well.
   -- Self may be void.
      pre n>=1 is 
      r::=allocate(1.lshift((3*load_ratio*n/4).highest_bit+1)+1);
      return r 
   end;
    
   private allocate(n:INT):SAME is
      -- Allocate `n' locations (must be power of 2 plus 1) and
      -- initialize to `elt_nil'.
      r::=new(n); 
      if ~void(elt_nil) then loop r.aset!(elt_nil) end end;
      return r 
   end;
    
   query_test(q:Q,t:T):BOOL is
      -- True if `t' satisfies the query posed by `q'.
      -- Usually redefined in descendants.
      return SYS::ob_eq(q,t) 
   end;
    
   query_hash(q:Q):INT is
      -- The hash value associated with the query `q'.
      -- If an element satisfies `query_test(q,t)', then `query_hash(q)' 
      -- must equal `elt_hash(t)'. Should produce full range of integers.
      -- Usually redefined in descendants.      
      typecase q when $HASH then return q.hash
      else return SYS::id(q).hash end 
   end;
    
   size:INT is
      -- Number of entries in the table. Self may be void.
      if void(self) then return 0 else return hsize end 
   end;
    
   copy:SAME is
      -- A copy of self.
      r:SAME; loop r:=r.insert(elt!) end; return r 
   end;
    
   elt!:T is
      -- Yield the elements in self in an arbitrary order. Do not insert
      -- or delete from self while calling this. Self may be void.
      if ~void(self) then 
	 loop r::=aelt!; 
	    if ~is_elt_nil(r) then yield r end end 
      end 
   end;

   get_query!(once q:Q):T is
      -- Retrieve all elements associated with the query `q'.
      -- Self may be void.
      if void(self) then quit end;
      h::=query_hash(q).band(asize-2);	
      loop e::=[h];
	 if is_elt_nil(e) then break!
	 elsif query_test(q,e) then yield e
	 end;
	 h:=h+1 end;
      if h=asize-1 then h:=0;	-- hit sentinel
	 loop e::=[h];
	    if is_elt_nil(e) then break!
	    elsif query_test(q,e) then yield e
	    end;
	    h:=h+1 
	 end;
	 assert h/=asize-1 
      end -- table mustn't be filled 
   end; 

   get_query(q:Q):T is
      -- Retrieve the first element associated with the query arg.
      -- Returns `elt_nil' if not present. Self may be void.
      if void(self) then return void end;
      h::=query_hash(q).band(asize-2);	
      loop e::=[h];
	 if is_elt_nil(e) then break!
	 elsif query_test(q,e) then return e
	 end;
	 h:=h+1 
      end;
      if h=asize-1 then h:=0;	-- hit sentinel
	 loop e::=[h];
	    if is_elt_nil(e) then break!
	    elsif query_test(q,e) then return e
	    end;
	    h:=h+1 end;
	 assert h/=asize-1 end;
      return elt_nil 
   end; -- table mustn't be filled
    
   test_query(q:Q):BOOL is
      -- Test whether any elements are associated with the query `q'.
      -- Self may be void.
      if is_elt_nil(get_query(q)) then return false
      else return true end 
   end;
    
   test(e:T):BOOL is
      -- True if `e' is `elt_eq' to an element contained in self. 
      -- Self may be void.
      if void(self) then return false end;  
      h::=elt_hash(e).band(asize-2);
      loop te::=[h];  
	 if is_elt_nil(te) then break!
	 elsif elt_eq(te,e) then return true
	 end;  
	 h:=h+1 
      end;
      if h=asize-1 then		-- hit sentinel
	 h:=0;
	 loop te::=[h];
	    if is_elt_nil(te) then break!
	    elsif elt_eq(te,e) then return true
	    end;  
	    h:=h+1 
	 end;
	 assert h/=asize-1 
      end; -- table mustn't be filled
      return false 
   end;
    
   get(e:T):T is
      -- If `e' is `elt_eq' to a table entry, return that entry, 
      -- otherwise return `elt_nil'. Useful when different objects 
      -- are treated as equal (eg. a table of strings used to get a 
      -- unique representative for each class of equal strings).
      -- Self may be void.
      if void(self) then return elt_nil end;
      h::=elt_hash(e).band(asize-2);	
      loop te::=[h];
	 if is_elt_nil(te) then break!
	 elsif elt_eq(te,e) then return te
	 end;
	 h:=h+1 
      end;
      if h=asize-1 then h:=0;	-- hit sentinel
	 loop te::=[h];
	    if is_elt_nil(te) then break!
	    elsif elt_eq(te,e) then return te
	    end;
	    h:=h+1 
	 end;
	 assert h/=asize-1 
      end; -- table mustn't be filled
      return elt_nil 
   end; 
    
   private double_size:SAME 
   -- A new table of twice the size of self with self's entries
   -- copied over. 
      pre ~void(self) is
      r::=allocate((asize-1)*2+1); 
      loop r:=r.insert(elt!) end;
      SYS::destroy(self);	-- The old one should never be used now.
      return r
   end;

   private should_grow:BOOL is
      return (hsize+1)*load_ratio>asize;
   end;
    
   insert(e:T):SAME is
      -- A possibly new table which includes `e'. If an entry 
      -- is `elt_eq' to `e' then overwrite it with `e'.
      -- Usage: `tbl:=tbl.insert(e)'. 
      -- Creates a new table if void(self).
      r::=self;
      if is_elt_nil(e) then return r end;
      if void(r) then r:=allocate(5)
      elsif should_grow then r:=r.double_size end;
      asz::=r.asize;
      orig_h::=r.elt_hash(e).band(asz-2);
      h::=orig_h;
      loop te::=r[h];
	 if is_elt_nil(te) then break!
	 elsif elt_eq(te,e) then r[h]:=e; return r end;
	 h:=h+1
      end;
      if h=asz-1 then h:=0;	-- hit sentinel
	 loop te::=r[h];
	    if is_elt_nil(te) then break!
	    elsif elt_eq(te,e) then r[h]:=e; return r end;
	    h:=h+1 
	 end;
	 assert h/=asz-1 
      end; -- table mustn't be filled	 
      assert not_too_many(orig_h,h); -- Look for excessive collisions
      r[h]:=e; r.hsize:=r.hsize+1; 
      return r 
   end;
    
   private not_too_many(start, finish:INT):BOOL is
      -- A function called in an assert to check that really
      -- bad hashing isn't happening, which would probably
      -- be a performance bug.  Since it is in an assert, this
      -- isn't called unless checking is on.
      if finish>start+50 then
	 #ERR+"Found a problem: excessive collisions in "
	       +SYS::str_for_tp(SYS::tp(self))
	       +", possibly due to a bad hash function in the class "
	       +SYS::str_for_tp(SYS::tp([start]))
	       +".\n";
	 t:T;
	 typecase t
	 when $STR then
	    #OUT + "Snowballing values:\n";
	    loop
	       i::=start.upto!(finish-1);
	       e::=[i];
	       h::=elt_hash(e);
	       typecase e
	       when $STR then
		  #OUT + i 
			+ '\t' + h.hex_str 
			+ '\t' + h.band(asize-2) 
			+ '\t' + e.str.pretty + '\n';
	       end;
	    end;
	 else
	 end;
	 return false;
      end;
      return true;
   end;
    
   private halve_size:SAME 
   -- A new table of half the size of self with self's entries
   -- copied over. 
      pre ~void(self) and hsize<(asize-1)/4 is
      r::=allocate((asize-1)/2+1); 
      loop r:=r.insert(elt!) end;
      SYS::destroy(self);	-- The old one should never be used now.
      return r 
   end;

   private should_shrink:BOOL is
      return asize>=33 and hsize<(asize-1)/(load_ratio*2);
   end;
    
   delete(e:T):SAME is
      -- A possibly new table which deletes the element which an 
      -- element of self that is `elt_eq' to `e' if it exists.
      -- Doesn't modify the table if there is no such element.
      -- Usage: `tbl:=tbl.delete(e)'. Self may be void.
      if void(self) then return void end;
      h::=elt_hash(e).band(asize-2);
      loop te::=[h];
	 if is_elt_nil(te) then return self
	 elsif elt_eq(te,e) then break! end;
	 if h=asize-2 then h:=0 else h:=h+1 end end;
      [h]:=elt_nil; hsize:=hsize-1; i::=h; -- h is the index of arg
      -- Now check the block after h for collisions.
      loop 
	 if i=asize-2 then i:=0 else i:=i+1 end;
	 te::=[i];
	 if is_elt_nil(te) then break! end;
	 hsh::=elt_hash(te).band(asize-2);
	 if hsh<=i then		-- block doesn't wrap around
	    if h<i and h>=hsh then -- hole in way
	       [h]:=[i]; h:=i; [i]:=elt_nil end
	 else			-- block wraps
	    if h>=hsh or h<i then -- hole in way
	       [h]:=[i]; h:=i; [i]:=elt_nil end end end;
      if should_shrink then return halve_size
      else return self 
      end 
   end;

   clear:SAME is
      -- Clear out self, return the space if it has 17 or less entries
      -- otherwise return void. Self may be void.
      if void(self) then return void end;
      if asize<=17 then 
	 hsize:=0; loop aset!(elt_nil) end; return self
      else return void end 
   end;

   is_empty:BOOL is		
      -- True if the set is empty. Self may be void.
      return void(self) or hsize=0 
   end;
    
   is_eq(s:SAME):BOOL is	
      -- True if `s' has the same elements as self. Self may be void.
      loop if ~s.test(elt!) then return false end end;
      loop if ~test(s.elt!) then return false end end;
      return true 
   end;
    
   is_disjoint_from(s:SAME):BOOL is
      -- True if self and `s' have no elements in common.
      -- Self may be void.
      loop if s.test(elt!) then return false end end;
      return true 
   end;
    
   intersects(s:SAME):BOOL is
      -- True if self and `s' have elements in common.
      -- Self may be void.
      return ~is_disjoint_from(s) 
   end;
    
   is_subset(s:SAME):BOOL is
      -- True if all elements of self are contained in `s'.
      -- Self may be void.
      loop if ~s.test(elt!) then return false end end;
      return true 
   end;
    
   to_union(s:SAME):SAME is
      -- The union of self and `s', modifies self.
      -- Self may be void.
      r::=self; loop r:=r.insert(s.elt!) end; return r 
   end;
    
   union(s:SAME):SAME is
      -- A new set which is the union of self and `s'.
      -- Self may be void.
      return copy.to_union(s) 
   end;
    
   to_intersect(s:SAME):SAME is
      -- The intersection of self and `s', modifies self.
      -- Self may be void.
      r::=self; loop r:=r.delete(s.elt!) end; return r 
   end;
    
   intersect(s:SAME):SAME is
      -- A new set which is the intersection of self and `s'.
      -- Self may be void.
      r:SAME;
      loop e::=elt!; if s.test(e) then r:=r.insert(e) end end;
      return r 
   end;
    
   to_difference(s:SAME):SAME is
      -- The difference of self and `s', modifies self.
      -- Self may be void.
      r::=self; loop r:=r.delete(s.elt!) end; return r 
   end;
    
   difference(s:SAME):SAME is
      -- A new set which is the difference between self and arg.
      -- Self may be void.
      r:SAME;
      loop e::=elt!; if ~s.test(e) then r:=r.insert(e) end end; 
      return r 
   end;
    
   to_sym_difference(s:SAME):SAME is
      -- The symmetric difference of self and `s', modifies self.
      -- Self may be void.
      r::=self;
      loop e::=s.elt!;
	 if r.test(e) then r:=r.delete(e) else r:=r.insert(e) end end;
      return r 
   end;
    
   sym_difference(s:SAME):SAME is
      -- A new set which is the symmetric difference between self 
      -- and `s'. Self may be void.
      r:SAME;
      loop e::=elt!; if ~s.test(e) then r:=r.insert(e) end end;
      loop e::=s.elt!; if ~test(e) then r:=r.insert(e) end end;
      return r 
   end;
    
   map(m:ROUT{T}:T):SAME is
      -- A new set whose elements are `m' applied to those of self.
      -- Self may be void.
      r:SAME; loop r:=r.insert(m.call(elt!)) end; return r 
   end;
    
   filter(t:ROUT{T}:BOOL):SAME is
      -- A new set whose elements are those of self which satisfy `t'.
      -- Self may be void.
      r:SAME;
      loop e::=elt!; if t.call(e) then r:=r.insert(e) end end;
      return r 
   end;

   some(t:ROUT{T}:BOOL):BOOL is
      -- True if some element of self satisfies `t'.
      -- Self may be void.
      loop if t.call(elt!) then return true end end 
   end;

   every(t:ROUT{T}:BOOL):BOOL is
      -- True if every element of self satisfies `t'.
      -- Self may be void.
      loop if ~t.call(elt!) then return false end end;
      return true 
   end;

   notany(t:ROUT{T}:BOOL):BOOL is
      -- True if none of the elements of self satisfies `t'.
      -- Self may be void.
      loop if t.call(elt!) then return false end end;
      return true 
   end;
    
   notevery(t:ROUT{T}:BOOL):BOOL is
      -- True if not every element of self satisfies `t'.
      -- Self may be void.
      loop if ~t.call(elt!) then return true end end;
      return false 
   end;
    
end; -- class FQSET{Q,T}

-------------------------------------------------------------------
