/* hdict.q: hashed dictionaries
   $Id: hdict.q,v 1.2 2004/01/28 16:54:43 agraef Exp $ */

/* This file is part of the Q programming system.

   The Q programming system is free software; you can redistribute it and/or
   modify it under the terms of the GNU General Public License as published by
   the Free Software Foundation; either version 2, or (at your option)
   any later version.

   The Q programming system 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 the
   GNU General Public License for more details.

   You should have received a copy of the GNU General Public License
   along with this program; if not, write to the Free Software
   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */

/* This is a variation of the dictionary data structure using hashed key
   values (commonly called "hashes" or "associative arrays" in other
   programming languages). Each entry of the dictionary consists of a hash
   value K together with the corresponding "bucket" of all (key,value) pairs
   (X,Y) for which hash X = K. This type of dictionary can be used for
   arbitrary (not necessarily ordered) keys. Note, however, that in difference
   to dict.q values will be stored in an apparently random order, and
   dictionary lookup and update operations are done by comparing key values
   syntactically instead of using equality. Moreover, the first/rmfirst/
   last/rmlast operations are not supported and equality testing is more
   involved, since the member lists of equal dictionaries may be arbitrary
   permutations of each other. */

include stdlib, stddecl;

public type HDict = private const nil, bin H XY D1 D2;

/* Construction and type checking: */

public emptyhdict;		// return the empty dictionary
public hdict XYs;		// create a dictionary from a list of key/value
				// pairs
public mkhdict Y Xs;		// create a dictionary from a list of keys
				// and an initial value
public ishdict X;		// check whether X is a hashed dictionary

/* Overloaded and public operations: */

// #D				// size of a dictionary
// D!X				// return the value Y associated with X in D

// null D			// tests whether D is the empty dictionary
// member D X			// tests whether D contains X as a key
// list D, members D		// list members (key-value pairs) of D
// keys D			// list the keys of D
// vals D			// list the corresponding values

// insert D XY			// associate key X with value Y in D; update
				// an existing entry for X
// delete D X			// remove key X from D
// update D X Y			// same as insert D (X,Y)

/* Implementation: *********************************************************/

/* Private Functions: ******************************************************/

private height D;		// return height of tree
private slope D;		// return slope (height diff between left and
				// right subtree)
private mkbin U D1 D2;		// construct node, recomputing height

private rebal D;		// rebalance tree after insertions and 
				// deletions
private rol D, ror D;		// single rotation left/right
private shl D, shr D;		// shift to left/right (single or double
				// rotation)

private last D, rmlast D;	// get/remove last bucket from dictionary
private join D1 D2;		// join two balanced subtrees

height nil			= 0;
height (bin H _ _ _)		= H;

slope nil			= 0;
slope (bin _ _ D1 D2)		= height D1 - height D2;

mkbin U D1 D2			= bin (max (height D1) (height D2) + 1)
				  U D1 D2;

rebal D				= shl D if slope D = -2;
				= shr D if slope D = 2;
				= D otherwise;

rol (bin H1 U1 D1 (bin H2 U2 D2 D3))
				= mkbin U2 (mkbin U1 D1 D2) D3;
ror (bin H1 U1 (bin H2 U2 D1 D2) D3)
				= mkbin U2 D1 (mkbin U1 D2 D3);

shl (bin H U D1 D2)		= rol (mkbin U D1 (ror D2))
				      if slope D2 = 1;
				= rol (bin H U D1 D2) otherwise;

shr (bin H U D1 D2)		= ror (mkbin U (rol D1) D2)
				      if slope D1 = -1;
				= ror (bin H U D1 D2) otherwise;

last (bin _ U _ nil)		= U;
last (bin _ _ _ D2)		= last D2 otherwise;

rmlast (bin _ _ D1 nil)		= D1;
rmlast (bin _ U D1 D2)		= rebal (mkbin U D1 (rmlast D2))
				      otherwise;

join nil D2			= D2;
join D1 D2			= rebal (mkbin (last D1) (rmlast D1) D2)
				      otherwise;

/* look up the value for a (K,X) pair in a dictionary, where K = hash X */

private lookup _ _;

/* If we can't find X, pretend we got a `nil!X', so the user can supply a
   default rule for D!X and have it return a default value. This behaviour is
   consistent with dict.q. */

lookup nil (K,X)		= nil!X;
lookup (bin _ (K,XYs) D1 D2) (K1,X1)
				= lookup D1 (K1,X1) if K>K1;
				= lookup D2 (K1,X1) if K<K1;
				= lookup XYs X1 otherwise;

lookup [] X			= nil!X;
lookup [(X,Y)|_] X		= Y;
lookup [_|XYs] X		= lookup XYs X otherwise;

/* check whether value is in given bucket of a dictionary */

private memberk _ _;

memberk nil _			= false;
memberk (bin _ (K,XYs) D1 D2) (K1,X1)
				= memberk D1 (K1,X1) if K>K1;
				= memberk D2 (K1,X1) if K<K1;
				= memberk XYs X1 otherwise;

memberk [] _			= false;
memberk [(X,Y)|_] X		= true;
memberk [_|XYs] X		= memberk XYs X otherwise;

/* insert value for a given hash key */

private insertk _ _;

insertk nil (K1,X1,Y1)		= bin 1 (K1,[(X1,Y1)]) nil nil;
insertk (bin H (K,XYs) D1 D2) (K1,X1,Y1)
				= rebal (mkbin (K,XYs) (insertk D1 (K1,X1,Y1))
					 D2) if K>K1;
				= rebal (mkbin (K,XYs) D1
					 (insertk D2 (K1,X1,Y1))) if K<K1;
				= bin H (K1,insertk XYs (X1,Y1)) D1 D2
				    otherwise;

insertk [] (X,Y)		= [(X,Y)];
insertk [(X,Y)|XYs] (X,Y1)	= [(X,Y1)|XYs];
insertk [(X,Y)|XYs] (X1,Y1)	= [(X,Y)|insertk XYs (X1,Y1)] otherwise;

/* delete value for a given hash key */

deletek nil _			= nil;
deletek (bin H (K,XYs) D1 D2) (K1,X1)
				= rebal (mkbin (K,XYs) (deletek D1 (K1,X1)) D2)
				      if K>K1;
				= rebal (mkbin (K,XYs) D1 (deletek D2 (K1,X1)))
				      if K<K1;
				= bin H (K,XYs1) D1 D2 if not null XYs1
				    where XYs1 = deletek XYs X1;
				= join D1 D2 otherwise;

deletek [] _			= [];
deletek [(X,_)|XYs] X		= XYs;
deletek [(X,Y)|XYs] X1		= [(X,Y)|deletek XYs X1] otherwise;

/* Public Functions: *******************************************************/

emptyhdict			= nil;
hdict XYs:List			= foldl insert nil XYs;
mkhdict Y Xs			= hdict (zip Xs (mklist Y (#Xs)));

ishdict _:HDict			= true;
ishdict _			= false otherwise;

#nil				= 0;
#bin _ (_,XYs) D1 D2		= #D1+#D2+#XYs;

D:HDict!X			= lookup D (hash X,X) if not null D;

null nil			= true;
null _:HDict			= false otherwise;

member D:HDict X		= memberk D (hash X,X);

members nil			= [];
members (bin _ (_,XYs) D1 D2)	= members D1 ++ XYs ++ members D2;

keys nil			= [];
keys (bin _ (_,XYs) D1 D2)	= keys D1 ++ map fst XYs ++ keys D2;

vals nil			= [];
vals (bin _ (_,XYs) D1 D2)	= vals D1 ++ map snd XYs ++ vals D2;

insert D:HDict (X,Y)		= insertk D (hash X,X,Y);

delete D:HDict X		= deletek D (hash X,X);

update D:HDict X Y		= insert D (X,Y);

(D1:HDict = D2:HDict)		= all (member D1) (keys D2) and then
				  all (member D2) (keys D1) and then
				  (vals D1 = map (D2!) (keys D1));
D1:HDict <> D2:HDict		= not (D1=D2);