------------------------->  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>  <--------------

-- fmap.sa: Hash table based maps from objects to objects.
-------------------------------------------------------------------
class FMAP{K,T} < $STR is
   -- Hash array based maps from key objects of type K to target 
   -- objects of type T requiring writebacks. 
   -- In this form void may not be a key, `key_nil' may be redefined.
   -- If K is a subtype of $IS_EQ, then `is_eq' will be used for
   -- key equality test (eg. string equality for STR), otherwise 
   -- object equality is used. 
   -- If K is a subtype of $HASH, then `hash' will be used for the hash
   -- value, otherwise the element `id' will be used.
   -- 
   -- Implementation: May be inherited with `key_eq', `key_nil', and
   -- `key_hash' redefined to get a different behavior.  The tables
   -- grow by amortized doubling and so require writeback when
   -- inserting and deleting elements.  We keep down the load factor
   -- to cut down on collision snowballing.  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 COMPARE{K} 
	 elt_eq->key_eq,elt_lt->,elt_hash->key_hash,
	 elt_nil->key_nil,is_elt_nil->is_key_nil;
	 
   private include AREF{TUP{K,T}};
    
   private attr hsize:INT;	-- Number of stored entries.

   private const load_ratio:INT:=4; -- Allow to get at most 1/load_ratio full.

   -- We can't have an invariant here, because sometimes we 
   -- destroy 'self' 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 without
   -- expansion. You can simply insert into a void table to create 
   -- one as well. Self may be void (and usually is).
      pre n>=1 is 
      return allocate(1.lshift((3*load_ratio*n/4).highest_bit+1)+1) 
   end;

   private allocate(n:INT):SAME is
      -- Allocate `n' locations (must be power of 2 plus 1) and
      -- initialize to `(elt_nil,void)'.
      r::=new(n); 
      if ~void(key_nil) then loop r.aset!(#(key_nil,void)) end end;
      return r 
   end;
    
   copy: SAME is
      res ::= #SAME(size);
      loop res := res.insert_pair(pair!) end;
      res.hsize := hsize;
      return res;
   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;
    
   has_ind(k: K): BOOL is return test(k) end;
   
   has(e:T):BOOL is
      -- True if self has an element which is `elt_eq' to `e'.
      if void(self) then return false end;
      loop if elt_eq(elt!,e) then return true end  end;
      return false 
   end;
      
   n_inds: INT	is 
      if void(self) then return 0 else return hsize end 
   end;
   
   test(k:K):BOOL is
      -- True if the key `k' is mapped by self.
      -- Self may be void.
      if void(self) then return false end; 
      h::=key_hash(k).band(asize-2);
      loop tk::=[h].t1; 
	 if is_key_nil(tk) then break!
	 elsif key_eq(tk,k) then return true
	 end; 
	 h:=h+1 end;
      if h=asize-1 then h:=0;	-- hit sentinel
	 loop tk::=[h].t1; 
	    if is_key_nil(tk) then break!
	    elsif key_eq(tk,k) then return true
	    end; 
	    h:=h+1 end;
	 assert h/=asize-1 
      end;
      return false 
   end;

   get(k:K):T is
      -- If `k' is a key, return the corresponding target, otherwise
      -- return void. Self may be void.
      if void(self) then return void end; 
      h::=key_hash(k).band(asize-2);
      loop tk::=[h].t1; 
	 if is_key_nil(tk) then break!
	 elsif key_eq(tk,k) then return [h].t2
	 end; 
	 h:=h+1 
      end;
      if h=asize-1 then
	 h:=0;	-- hit sentinel
	 loop tk::=[h].t1; 
	    if is_key_nil(tk) then break!
	    elsif key_eq(tk,k) then return [h].t2
	    end; 
	    h:=h+1 
	 end;
	 assert h/=asize-1 
      end; -- table mustn't be filled
      return void 
   end;
    
   get_pair(k:K):TUP{K,T} is
      -- If `k' is a key, return the corresponding key/target pair.
      -- Otherwise return #(key_nil,void). Useful when different
      -- objects are treated as equal by `key_eq'. 
      -- Self may be void.
      if void(self) then return #(key_nil,void) end; 
      h::=key_hash(k).band(asize-2);
      loop tk::=[h].t1; 
	 if is_key_nil(tk) then break!
	 elsif key_eq(tk,k) then return [h]
	 end; 
	 h:=h+1 
      end;
      if h=asize-1 then h:=0;	-- hit sentinel
	 loop tk::=[h].t1; 
	    if is_key_nil(tk) then break!
	    elsif key_eq(tk,k) then return [h]
	    end; 
	    h:=h+1 
	 end;
	 assert h/=asize-1 
      end; -- table mustn't be filled
      return #(key_nil,void) 
   end;
    
   private double_size:SAME 
   -- A new table of twice the size of self with self's entries
   -- copied over. 
      pre ~void(self) is
      ns::=(asize-1)*2+1; r::=allocate(ns); 
      loop r:=r.insert_pair(pairs!) 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(k:K,t:T):SAME is
      -- A possibly new table which includes the key/target pair `k',
      -- `t'. If `k' is already present, replaces the current key and 
      -- target with `k,t'. Usage: `tbl:=tbl.insert(k,t)'. Creates a 
      -- new table if void(self).
      r::=self;
      if void(r) then r:=allocate(5)
      elsif should_grow then r:=double_size end;
      orig_h::=r.key_hash(k).band(r.asize-2);
      h::=orig_h;
      asm::=r.asize-1;
      loop tk::=r[h].t1; 
	 if is_key_nil(tk) then break! end;
	 if key_eq(tk,k) then r[h]:=#(k,t); return r end;
	 h:=h+1 
      end;
      if h=asm then h:=0;	-- hit sentinel
	 loop tk::=r[h].t1; 
	    if is_key_nil(tk) then break! end;
	    if key_eq(tk,k) then r[h]:=#(k,t); return r end;
	    h:=h+1 
	 end;
	 assert h/=asm 
      end; -- table mustn't be filled	 
      assert not_too_many(orig_h,h); -- Look for excessive collisions
      r[h]:=#(k,t); 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 FMAP, probably\n"
	       +"due to a bad hash function in the class "
	       +SYS::str_for_tp(SYS::tp([start]))
	       +".\n";
	 k:K;
	 typecase k
	 when $STR then
	    #OUT + "Snowballing values:\n";
	    loop
	       i::=start.upto!(finish-1);
	       e::=[i].t1;
	       h::=key_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;
    
   insert_pair(p:TUP{K,T}):SAME is
      -- Insert the key/target pair held by the tuple arg.
      -- If the key is already present, replaces it with the new
      -- key and target. `tbl:=tbl.insert(p)'. Creates a new table 
      -- if void(self).
      return insert(p.t1,p.t2) 
   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
      ns::=(asize-1)/2+1; r::=allocate(ns); 
      loop r:=r.insert_pair(pairs!) 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(k:K):SAME is
      -- A possibly new table which deletes the element with key 
      -- `k' if it is contained in self. Usage: `tbl:=tbl.delete(k)'.
      -- Self may be void.
      if void(self) then return void end; 
      h::=key_hash(k).band(asize-2);
      loop tk::=[h].t1; 
	 if is_key_nil(tk) then return self
	 elsif key_eq(tk,k) then break! end;
	 if h=asize-2 then h:=0 else h:=h+1 end 
      end;
      [h]:=#(key_nil,void);	-- h is the index of arg
      hsize:=hsize-1; i::=h; 
      -- Now check the block after h for collisions.
      loop 
	 if i=asize-2 then i:=0 else i:=i+1 end;
	 tk::=[i].t1; 
	 if is_key_nil(tk) then break! end; 
	 hsh::=key_hash(tk).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]:=#(key_nil,void) end;
	 else			-- block wraps
	    if h>=hsh or h<i then -- hole in way
	       [h]:=[i]; h:=i; [i]:=#(key_nil,void) 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 r::=self; r.hsize:=0; 
	 loop aset!(#(key_nil,void)) 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;
    
   str: STR is 
      res: FSTR := #("{");
      i ::= 0; 
      loop until!(i = asize);
	 p ::= [i];
	 if ~is_key_nil(p.t1) then
	    k::=p.t1; e ::=p.t2;
	    typecase k when $STR then res := res+"["+k.str+"]="; else end;
	    typecase e when $STR then res:= res+" "+e.str+" "; else end;
	    res := res+" ";
	 end;	    
	 i := i + 1;
      end;
      res := res+"}";
      return(res.str);
   end;

   equals(e: $RO_MAP{K,T}): BOOL is
      -- Returns true if all of "e"'s elements are equal to self's elts
      -- Ordering is an issue. Should be redefined to be more
      -- precise for particular descendants
      -- This will not be a useful routine until we can place FMAP under
      -- $RO_MAP 
      if e.size /= size then return false end;
      loop k ::= ind!;
	 a1 ::= get(k); a2 ::= e.aget(k);
	 if ~elt_eq(a1,a2) then return false end 
      end;
      return true
   end;

   target!:T is loop yield targets! end; end;
   pair!:TUP{K,T} is loop yield pairs! end; end;
   elt!: T is loop yield targets! end; end;
   
   pairs!:TUP{K,T} is
      -- Yield the input/output pairs of 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_key_nil(r.t1) then yield r end 
	 end 
      end 
   end;  
    
   keys!:K is
      -- Yield the keys 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!.t1; 
	    if ~is_key_nil(r) then yield r end 
	 end 
      end 
   end;

   targets!:T is
      -- Yield the target objects contained 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 e::=aelt!; 
	    if ~is_key_nil(e.t1) then yield e.t2 end 
	 end 
      end 
   end;

   filter!(once f:ROUT{T}:BOOL): T  pre ~void(self) is
      loop e ::= elt!; if f.call(e) then yield e end  end
   end;

   filter_not!(once f:ROUT{T}:BOOL): T  pre ~void(self) is
      loop e ::= elt!; if ~ f.call(e) then yield e end  end
   end;

   ind!: K is loop yield keys! end; end;

end; -- class FMAP{K,T}

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