
/* bag.q: ordered multiset data structure implemented by AVL trees
   $Id: bag.q,v 1.8 2008/02/21 19:58:49 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 (rmfirst, rmlast, delete) is new, it was missing
   in the original assoc.pl file.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

public type Bag = virtual bag Xs | private const nil, bin X B M1 M2;

/* Construction and type checking: */

public emptybag;		// return the empty bag
//public bag Xs;		// create a bag from list Xs
				// (virtual constructor, see above)
public isbag X;			// check whether X is a bag

/* Overloaded and public operations: */

from stddecl include null, member, list, members, first, last, rmfirst, rmlast,
  insert, delete;

/* As in set.q, the comparison operators are overloaded to implement sub-/
   superbag predicates, and the operators +, - and * are used to denote bag
   union, difference and intersection, respectively. */

// #M				// size of bag M

// null M			// tests whether M is the empty bag
// member M X			// tests whether M contains X
// list M, members M		// list members of M in ascending order

// first M, last M		// return first and last member of M
// rmfirst M, rmlast M		// remove first and last member from M
// public insert M X;		// insert X into M (behind existing element)
// delete M X			// remove X from M

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

/* Default view: */

@-0x80000000
view X:Bag			= '(bag 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 inserta Tree Key;
	// insert a new (or replace an existing) member in the tree

private rmfirsta Tree;
	// remove the first member from the tree

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

private deletea Tree 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 Balance Left Right  (Left, Right: trees)
   Balance: islt, iseq, or isgt denoting |L|-|R| = 1, 0, or -1, respectively
*/

inserta nil Key			= ((bin Key iseq nil nil), true);

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

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

rmfirsta nil			= (nil, false);
rmfirsta (bin _ _ nil R)	= (R, true);

rmfirsta (bin K B L   R)
		= adjustd LeftHasChanged (bin K B NewL R) left
		    where (NewL, LeftHasChanged) = rmfirsta L;

rmlasta nil			= (nil false);
rmlasta (bin _ _ L nil)		= (L, true);

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

deletea nil _			= (nil, false);
deletea (bin K _ nil R  ) Key	= (R, true) if Key = K;
deletea (bin K _ L   nil) Key	= (L, true) if Key = K;

deletea (bin K B (bin KL BL RL LL) R) Key if Key = K:
		= adjustd LeftHasChanged (bin LastK B NewL R) left
		    where
		      LastK			= last (bin KL BL RL LL),
		      (NewL, LeftHasChanged)	= rmlasta (bin KL BL RL LL);

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

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

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

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

rebali false (bin K _ L R) B	= bin K 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 B0 L R) LoR
		= rebald ToBeRebalanced (bin Key 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 _ L R) B WhatHasChanged
				= (bin K 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 isgt Alpha (bin B isgt Beta Gamma))
		= (bin B iseq (bin A iseq Alpha Beta) Gamma, true);

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

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

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

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

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

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

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

emptybag			= nil;
bag Xs:List			= foldl insert nil Xs;

isbag _:Bag			= true;
isbag _				= false otherwise;

#nil				= 0;
#bin _ _ M1 M2			= #M1+#M2+1;

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

member nil _			= false;
member (bin X _ M1 M2) Y	= member M1 Y if X>Y;
				= member M2 Y if X<Y;
				= true if X=Y;

members nil			= [];
members (bin X _ M1 M2)		= members M1 ++ [X|members M2];

first (bin X _ nil _)		= X;
first (bin _ _ M1 _)		= first M1 otherwise;

last (bin X _ _ nil)		= X;
last (bin _ _ _ M2)		= last M2 otherwise;

rmlast M:Bag			= fst (rmlasta M);

rmfirst M:Bag			= fst (rmfirsta M);

insert M:Bag Y			= fst (inserta M Y);

delete M:Bag Y			= fst (deletea M Y);

/* bag comparison, union, difference and intersection: */

(M1:Bag = M2:Bag)		= (members M1 = members M2);
M1:Bag <> M2:Bag		= members M1 <> members M2;

M1:Bag <= M2:Bag		= null (M1-M2);
M1:Bag >= M2:Bag		= null (M2-M1);

M1:Bag < M2:Bag			= (M1<=M2) and then (M1<>M2);
M1:Bag > M2:Bag			= (M1>=M2) and then (M1<>M2);

M1:Bag + M2:Bag			= foldl insert M1 (members M2);
M1:Bag - M2:Bag			= foldl delete M1 (members M2);
M1:Bag * M2:Bag			= M1-(M1-M2);
