
/* hdict.q: hashed dictionaries
   $Id: hdict.q,v 1.9 2008/02/21 21:14:03 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. */

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   Updated: 18 February 2008 by Jiri Spitz

   Purpose: More efficient algorithm for association lists implemented
   as AVL trees.

   The used algorithm has its origin in the SWI-Prolog implementation of
   association lists. The original file was created by R.A.O'Keefe and
   updated for the SWI-Prolog by Jan Wielemaker. For the original file
   see http://www.swi-prolog.org.

   The deletion stuff (delete) is new, it was missing in the original
   assoc.pl file.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

/* 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. */

public type HDict = virtual hdict XYs | private const nil, bin K V B 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 (virtual constructor, see above)
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: */

from stddecl include null, member, list, members, keys, vals, insert, delete,
  update;

// #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: *********************************************************/

/* Default view: */

@-0x80000000
view X:HDict			= '(hdict Xs) where Xs:List = list X;
@0

/* Private Types: **********************************************************/

// For better readability of the code
private type Balance		= const islt, iseq, isgt;
private type Side		= const left, right;

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

private last Tree;
	// find the last element in the tree

private inserta Tree Hash Key Val;
	// insert a new (or replace an existing) member in the tree

private rmlasta Tree;
	// remove the last member from the tree

private deletea Tree Hash Key;
	// delete member with Key from the tree

private adjusti TreeHasChanged Tree LeftOrRight;
	// decide changes needed in order to make a well
	// shaped tree after an insertion

private rebali ToBeRebalanced Tree NewBalance;
	// if ToBeRabalanced = false then set the balance of the root node
	// to NewBalance else call avl_geq

private adjustd TreeHasChanged Tree LeftOrRight;
	// decide changes needed in order to make a well
	// shaped tree after a deletion

private rebald ToBeRebalanced Tree NewBalance WhatHasChanged;
	// if ToBeRabalanced = false then set the balance of the root node
	// to NewBalance else call avl_geq

private avl_geq Tree;
	// single and double rotations of the tree

private tablei BalanceBefore WhereInserted;
	// insert balance rules

private tabled BalanceBefore WhereDeleted;
	// delete balance rules

private table2 BalanceOfSubSubNode;
	// balance rules for double rotations

/*
Tree is either:

-  nil  (empty tree) or
-  bin Key Value Balance Left Right  (Left, Right: trees)
   Balance: islt, iseq, or isgt denoting |L|-|R| = 1, 0, or -1, respectively
*/

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

/* 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. */

private lookup _ _ _, lookup2 _ _;

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;
				= lookup2 XYs X1 otherwise;

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

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

private memberk _ _ _, memberk2 _ _;

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;
				= memberk2 XYs X1 otherwise;

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

/* insertions */

private inserta2 _ _ _;

inserta nil K X Y		= ((bin K [(X, Y)] iseq nil nil), true);
inserta (bin K V B L R) K X Y	= ((bin K (inserta2 V X Y) B L R), false);

inserta (bin K V B L R) Key X Y	if Key < K:
		= adjusti LeftHasChanged (bin K V B NewL R) left
		    where (NewL, LeftHasChanged) = inserta L Key X Y;

inserta (bin K V B L R) Key X Y if Key > K:
		= adjusti RightHasChanged (bin K V B L NewR) right
		    where (NewR, RightHasChanged) = inserta R Key X Y;

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

/* deletions */

// find the last value in the tree
last (bin Key Val _ _ nil)	= (Key, Val);
last (bin _ _ _ _ R)		= last R;

// remove last value from the tree
rmlasta nil			= (nil false);
rmlasta (bin _ _ _ L nil)	= (L, true);

rmlasta (bin K V B L   R)
		= adjustd RightHasChanged (bin K V B L NewR) right
		    where (NewR, RightHasChanged) = rmlasta R;

private deletea2 _ _;

deletea nil _ _			= (nil, false);

deletea (bin Key XYs B nil R  ) Key X
		= if null NewXYs then (R, true)
		  else (bin Key NewXYs B nil R, false)
		    where NewXYs = deletea2 XYs X;

deletea (bin Key XYs B L   nil) Key X
		= if null NewXYs then (L, true)
		  else (bin Key NewXYs B L nil, false)
		    where NewXYs = deletea2 XYs X;

deletea (bin Key XYs B (bin KL VL BL RL LL) R) Key X if null (deletea2 XYs X):
		= adjustd LeftHasChanged (bin LastK LastV B NewL R) left
		    where
		      (LastK, LastV)		= last (bin KL VL BL RL LL),
		      (NewL, LeftHasChanged)	= rmlasta (bin KL VL BL RL LL);

deletea (bin Key XYs B L R) Key X
		= (bin Key (deletea2 XYs X) B L R, false);

deletea (bin K V B L R) Key X if Key < K:
		= adjustd LeftHasChanged (bin K V B NewL R) left
		    where
		      (NewL, LeftHasChanged) = deletea L Key X;

deletea (bin K V B L R) Key X if Key > K:
		= adjustd RightHasChanged (bin K V B L NewR) right
		    where
		      (NewR, RightHasChanged) = deletea R Key X;

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

// The insertions and deletions are dealt with separately.
// Insertions
adjusti false OldTree _		= (OldTree, false);

adjusti true (bin Key Val B0 L R) LoR
		= (rebali ToBeRebalanced (bin Key Val B0 L R) B1,
		   WhatHasChanged)
		    where
		      (B1, WhatHasChanged, ToBeRebalanced) = tablei B0 LoR;

rebali false (bin K V _ L R) B	= bin K V B L R;
rebali true  OldTree _		= fst (avl_geq OldTree);

// Balance rules for insertions
//	balance	where		balance	  whole tree	to be
//	before	inserted	after	  increased	rebalanced
tablei	iseq	left		= (islt,  true,		false);
tablei	iseq	right		= (isgt,  true,		false);
tablei	islt	left		= (iseq,  false,	true);
tablei	islt	right		= (iseq,  false,	false);
tablei	isgt	left		= (iseq,  false,	false);
tablei	isgt	right		= (iseq,  false,	true);

// Deletions
adjustd false OldTree _		= (OldTree, false);

adjustd true (bin Key Val B0 L R) LoR
		= rebald ToBeRebalanced (bin Key Val B0 L R) B1 WhatHasChanged
		    where
		      (B1, WhatHasChanged, ToBeRebalanced) = tabled B0 LoR;

// Balance rules for deletions
//	balance	where		balance	  whole tree	to be
//	before	deleted		after	  decreased	rebalanced
tabled	iseq	right		= (islt,  false,	false);
tabled	iseq	left		= (isgt,  false,	false);
tabled	islt	right		= (iseq,  true,		true);
//					  ^^^^
// It depends on the tree pattern in avl_geq whether it really decreases

tabled	islt	left		= (iseq,  true, 	false);
tabled	isgt	right		= (iseq,  true,		false);
tabled	isgt	left		= (iseq,  true,		true);
//					  ^^^^
// It depends on the tree pattern in avl_geq whether it really decreases

/*
   Note that rebali and rebald are not symmetrical. With insertions it is
   sufficient to know the original balance and insertion side in order to
   decide whether the whole tree increases. With deletions it is sometimes not
   sufficient and we need to know which kind of tree rotation took place.
*/
rebald false (bin K V _ L R) B WhatHasChanged
				= (bin K V B L R, WhatHasChanged);
rebald true  OldTree _ _	= avl_geq OldTree;

// Single and double tree rotations - these are common for insert and delete
/*
  The patterns isgt-isgt, isgt-islt, islt-islt and islt-isgt on the LHS always
  change the tree height and these are the only patterns which can happen
  after an insertion. That's the reason why we can use tablei only to decide
  the needed changes.
  The patterns isgt-iseq and islt-iseq do not change the tree height. After a
  deletion any pattern can occur and so we return true or false as a flag of
  a height change.
*/
avl_geq (bin A VA isgt Alpha (bin B VB isgt Beta Gamma))
		= (bin B VB iseq (bin A VA iseq Alpha Beta) Gamma, true);

avl_geq (bin A VA isgt Alpha (bin B VB iseq Beta Gamma))
		= (bin B VB islt (bin A VA isgt Alpha Beta) Gamma, false);
			// the tree doesn't decrease with this pattern

avl_geq (bin A VA isgt Alpha (bin B VB islt (bin X VX B1 Beta Gamma) Delta))
		= (bin X VX iseq (bin A VA B2 Alpha Beta)
		   (bin B VB B3 Gamma Delta), true)
		    where (B2, B3) = table2 B1;

avl_geq (bin B VB islt (bin A VA islt Alpha Beta) Gamma)
		= (bin A VA iseq Alpha (bin B VB iseq Beta  Gamma), true);

avl_geq (bin B VB islt (bin A VA iseq Alpha Beta) Gamma)
		= (bin A VA isgt Alpha (bin B VB islt Beta  Gamma), false);
			// the tree doesn't decrease with this pattern

avl_geq (bin B VB islt (bin A VA isgt Alpha(bin X VX B1 Beta Gamma)) Delta)
		= (bin X VX iseq (bin A VA B2 Alpha Beta)
		   (bin B VB B3 Gamma Delta), true)
		    where (B2, B3) = table2 B1;

table2 islt			= (iseq, isgt);
table2 isgt			= (islt, iseq);
table2 iseq			= (iseq, iseq);

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

emptyhdict			= nil;
hdict XYs:List			= foldl insert nil XYs;
mkhdict Y Xs:List		= 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)		= fst (inserta D (hash X) X Y);

delete D:HDict X		= fst (deletea 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);
