;;; -*- Mode: Lisp -*-

;;; rbtrees.lisp --
;;; Red/Black Trees in the CLR style. (Cormen,
;;; Leiserson and Rivest, "Introduction to Algorithms", ppgg.
;;; 262-300, MIT Press).
;;; Package definition file (in CLtL2 style).
;;;
;;; Author: Marco Antoniotti
;;; Address: Robotics Laboratory
;;;          Courant Institute of Mathematical Science
;;;          New York University
;;;          New York, NY, 10012
;;;
;;; Copyright (c) 1992. All rights reserved.
;;;
;;; Version: 0.9 beta
;;;
;;; Tested in CMU CL 16c.

;;;============================================================================
;;; General License Agreement and Lack of Warranty
;;;
;;; This software is distributed in the hope that it will be useful (both
;;; in and of itself and as an example of lisp programming), but WITHOUT
;;; ANY WARRANTY. The author(s) do not accept responsibility to anyone for
;;; the consequences of using it or for whether it serves any particular
;;; purpose or works at all. No warranty is made about the software or its
;;; performance. 
;;; 
;;; Use and copying of this software and the preparation of derivative
;;; works based on this software are permitted, so long as the following
;;; conditions are met:
;;; 	o  The copyright notice and this entire notice are included intact
;;; 	   and prominently carried on all copies and supporting documentation.
;;; 	o  No fees or compensation are charged for use, copies, or
;;; 	   access to this software. You may charge a nominal
;;; 	   distribution fee for the physical act of transferring a
;;; 	   copy, but you may not charge for the program itself. 
;;; 	o  If you modify this software, you must cause the modified
;;; 	   file(s) to carry prominent notices (a Change Log)
;;; 	   describing the changes, who made the changes, and the date
;;; 	   of those changes.
;;; 	o  Any work distributed or published that in whole or in part
;;; 	   contains or is a derivative of this software or any part 
;;; 	   thereof is subject to the terms of this agreement. The 
;;; 	   aggregation of another unrelated program with this software
;;; 	   or its derivative on a volume of storage or distribution
;;; 	   medium does not bring the other program under the scope
;;; 	   of these terms.
;;; 	o  Permission is granted to manufacturers and distributors of
;;; 	   lisp compilers and interpreters to include this software
;;; 	   with their distribution. 
;;; 
;;; This software is made available AS IS, and is distributed without 
;;; warranty of any kind, either expressed or implied.
;;; 
;;; In no event will the author(s) or their institutions be liable to you
;;; for damages, including lost profits, lost monies, or other special,
;;; incidental or consequential damages arising out of or in connection
;;; with the use or inability to use (including but not limited to loss of
;;; data or data being rendered inaccurate or losses sustained by third
;;; parties or a failure of the program to operate as documented) the 
;;; program, even if you have been advised of the possibility of such
;;; damanges, or for any claim by any other party, whether in an action of
;;; contract, negligence, or other tortious action.
;;;
;;;
;;; The current version of this software and a variety of related
;;; utilities may be obtained by anonymous ftp from ftp.cs.cmu.edu
;;; (128.2.206.173) or any other CS machine in the directory 
;;;       /afs/cs.cmu.edu/user/mkant/Public/Lisp/
;;; You must cd to this directory in one fell swoop, as the CMU
;;; security mechanisms prevent access to other directories from an
;;; anonymous ftp. For users accessing the directory via an anonymous
;;; ftp mail server, the file README contains a current listing and
;;; description of the files in the directory. The file UPDATES describes
;;; recent updates to the released versions of the software in the directory.
;;; The file COPYING contains the current copy of this license agreement.
;;; Of course, if your site runs the Andrew File System and you have
;;; afs access, you can just cd to the directory and copy the files directly.
;;; 
;;; If you wish to be added to the CL-Utilities@cs.cmu.edu mailing list, 
;;; send email to CL-Utilities-Request@cs.cmu.edu with your name, email
;;; address, and affiliation. This mailing list is primarily for
;;; notification about major updates, bug fixes, and additions to the lisp
;;; utilities collection. The mailing list is intended to have low traffic.


;;;============================================================================
;;; Documentation (initial)
;;;
;;; VERSION "()"                                                     [FUNCTION]
;;;
;;; COLOR NIL '(member red black)                                        [TYPE]
;;;
;;; RBT-NODE (color size rank)                                      [STRUCTURE]
;;;
;;; RB-TREE "()"                                                    [STRUCTURE]
;;;
;;; EMPTY-ERROR (a-tree)                                            [CONDITION]
;;;    Error signaled when an operation is tried on an empty tree
;;;
;;; MAKE-RED-BLACK-TREE (&key (key #'identity) (test #'<)            [FUNCTION]
;;;                      (equality-test #'=) (name nil)
;;;                      (element-type t) (key-type 'number))
;;;    Creates a red/black tree internal structure.
;;;    Arguments:
;;;    &key
;;;    :key : the value used in the comparisons (default #'identity)
;;;    :test : the comparison function (default #'>)
;;;    :name : a name for the priority queue (default "")
;;;    :element-type : the type of the elements in the queue (default t)
;;;
;;; RED-P (node)                                                     [FUNCTION]
;;;
;;; BLACK-P (node)                                                   [FUNCTION]
;;;
;;; BLACKEN (node)                                                   [FUNCTION]
;;;
;;; REDDEN (node)                                                    [FUNCTION]
;;;
;;; ACTUAL-RBTN-SIZE (node)                                          [FUNCTION]
;;;
;;; ON-THE-RIGHT-P (node)                                            [FUNCTION]
;;;
;;; ON-THE-LEFT-P (node)                                             [FUNCTION]
;;;
;;; LEFT-ROTATE (a-tree node &aux (y (rbtn-right node)))             [FUNCTION]
;;;
;;; RIGHT-ROTATE (a-tree node &aux (y (rbtn-left node)))             [FUNCTION]
;;;
;;; UPDATE-SIZES (up-node down-node)                                 [FUNCTION]
;;;
;;; PPRINT-TREE (a-tree &optional (strm *standard-output*))          [FUNCTION]
;;;
;;; EMPTY-P (a-tree)                                                 [FUNCTION]
;;;    Checks whether a tree is empty.
;;;
;;; INSERT (elem a-tree)                                             [FUNCTION]
;;;    Inserts an element in the red/black tree.
;;;    Arguments:
;;;    elem : the element to be inserted (with a 'key')
;;;    a-tree : the binary search tree
;;;
;;; INTERNAL-INSERT (elem a-tree                                     [FUNCTION]
;;;                  &aux (compfun (tree-comp-fun a-tree)) (keyfun
;;;                  (tree-key-fun a-tree)) (eqfun
;;;                  (tree-eq-fun a-tree)) (root (tree-root a-tree))
;;;                  (elem-key (funcall keyfun elem)))
;;;
;;; REBALANCE-TREE (new-node a-tree &aux (x new-node))               [FUNCTION]
;;;
;;; DELETE-BY-KEY (elem-key a-tree)                                  [FUNCTION]
;;;    Deletes the node with a certain key from the tree.
;;;    Arguments:
;;;    elem-key : the key to be used in the deleting process
;;;    a-tree   : the tree
;;;
;;; UPDATE-SIZES-UP (node a-tree)                                    [FUNCTION]
;;;
;;; FIXUP-DELETION (a-tree x)                                        [FUNCTION]
;;;
;;; SELECT (i a-tree)                                                [FUNCTION]
;;;    Returns the i-th element in the inorder traversal of the red black
;;;    tree.
;;;    Arguments:
;;;    i      : an integer
;;;    a-tree : a red-black tree
;;;
;;; INTERNAL-SELECT (node i                                          [FUNCTION]
;;;                  &aux
;;;                  (rank
;;;                  (1+ (actual-rbtn-size (rbtn-left node)))))
;;;
;;; ELEMENT-RANK (elem-key a-tree)                                   [FUNCTION]
;;;    Returns the rank of the element indexed by the key in a red-black
;;;    tree.
;;;    Arguments:
;;;    elem-key : a key
;;;    a-tree   : a red-black tree with compatible keys
;;;


;;;============================================================================
;;; History
;;; 30.12.92: Reintroduced sentinel.
;;;


;;;============================================================================
;;; Notes:
;;; 12.31.1992: things missing and/or desirable:
;;;             a  - better duplicate handling
;;;             b  - CLtL2 defstruct constructors
;;;             c  - use 'resources' package to improve memory allocation
;;;             d  - better 'rank' and 'size' mainainance
;;;             e  - 'join' operation (always see Cormen, Leiserson
;;;                  and Rivest)

;;;============================================================================
;;; Bugs:
;;; None known -- what hubris :>
;;;
;;; Send bug reports, notes and suggestions to the author
;;;
;;;	marcoxa@cs.nyu.edu


;;;============================================================================
;;; Prologue

(eval-when #+CLtL2 (:compile-toplevel :load-toplevel)
	   #-CLtL2 (compile load)
	   (unless (find-package "TREES")
	     (load "binary-trees-package"))
	   (unless (find-package "RED-BLACK-TREES")
	     (load "rbtrees-package")))

(in-package "RED-BLACK-TREES")


;;; Imports -- I want to import these symbols, but I do not want them
;;; to be seen in the 'package' file.

(import '(;trees::+null-node+
	  trees::null-node-p
	  trees::tree
	  trees::tree-root
	  trees::tree-comp-fun
	  trees::tree-eq-fun
	  trees::tree-key-fun
	  trees::tree-size

	  trees::tree-node
	  trees::tn-content
	  trees::tn-parent
	  trees::tn-left
	  trees::tn-right

	  trees::internal-search
	  trees::internal-successor
	  trees::splice-in
	  ))
;;; Imports


;;;============================================================================
;;; Global definitions

;;; version
;;; => string
;;; => integer
;;; => integer
;;; => string

(defun version ()
  (values "RED BLACK TREES: version 0.9 beta"
	  0
	  9
	  "beta"
	  ))
;;; version


;;; color type specifier

(deftype color () '(member red black))


;;; rbt-node structure -- Augments the 'tree-node' structure with the
;;; fields used by the red/black tree algorithms.

(defstruct (rbt-node (:include tree-node)
		     (:conc-name rbtn-))
  (color 'black :type color)
  (size 0 :type integer)
  (rank 0 :type integer)
  )
;;; rbt-node --


;;; rb-tree -- Just an alias. Used to augment the type system.

(defstruct (rb-tree (:include tree)))
;;; rb-tree --


;;; +null-node+ constant -- The RBT algorithms use a 'sentinel'
;;; technique. Here is the constant used for such task.

#+:sentinel (setq +null-node+ (make-rbt-node :color 'black))
;;; +null-node+ --


;;; empty-error condition --

(define-condition empty-error (simple-error)
  (a-tree)
  (:report
   (lambda (cnd strm)
     (format strm
	     ">> RED/BLACK TREES: empty tree~:[ ~A.~;.~]"
	     (null (rb-tree-name (empty-error-a-tree cnd)))
	     (rb-tree-name (empty-error-a-tree cnd)))))
  (:documentation
   "Error signaled when an operation is tried on an empty tree")
  )
;;; empty-error --


;;;============================================================================
;;; Functions

;;;----------------------------------------------------------------------------
;;; Constructor and type related functions.

;;; make-red-black-tree

(defun make-red-black-tree (&key (key #'identity)
		       (test #'<)
		       (equality-test #'=)
		       (name nil)
		       (element-type t)
		       (key-type 'number)
		       )
  "Creates a red/black tree internal structure.
Arguments:
&key
:key : the value used in the comparisons (default #'identity)
:test : the comparison function (default #'>)
:name : a name for the priority queue (default \"\")
:element-type : the type of the elements in the queue (default t)"

  (declare (ignore element-type key-type))
 
  (let* ((sentinel (make-rbt-node :color 'black
				  :size 0))
	 (a-tree (make-rb-tree :comp-fun test
			       :key-fun key
			       :eq-fun equality-test
			       :name name
			       :root sentinel
			       :null-sentinel sentinel
			       )))
    a-tree))
;;; create-tree --


;;;----------------------------------------------------------------------------
;;; Auxiliary functions

;;; null-node-p tree-node => (member t nil)
;;; In the case I will need the sentinel construct. I will change it
;;; as necessary.
;;; Very good! I needed it, and here it is.

#+:sentinel
(defun null-node-p (tn)
  (eq tn +null-node+))

;(declaim (inline null-node-p))

;;; null-node-p


;;; red-p rb-tree-node => (member t nil)
;;; black-p rb-tree-node => (member t nil)

#+no-sentinel
(defun red-p (node)
  (if (null-node-p node)
      nil
      (eq (rbtn-color node) 'red)))

(defun red-p (node) (eq (rbtn-color node) 'red))

#+no-sentinel
(defun black-p (node)
  (or (null-node-p node) (eq (rbtn-color node) 'black)))

(defun black-p (node) (eq (rbtn-color node) 'black))

(declaim (inline black-p red-p))

;;; red-p black-p --


;;; blacken rb-tree-node => (member 'black)
;;; blacken rb-tree-node => (member 'red)

(defun blacken (node) (setf (rbtn-color node) 'black))

(defun redden (node) (setf (rbtn-color node) 'red))

(declaim (inline blacken redden))

;;; blacken redden


;;; actual-rbtn-size node
;;; I need to check if the node is null
 #+nosentinel
(defun actual-rbtn-size (node)
  (if (null-node-p node)
      0
      (rbtn-size node)))

(defun actual-rbtn-size (node) (rbtn-size node))

(declaim (inline actual-rbtn-size))

;;; actual-rbtn-size


;;; on-the-right-p tn-node => (member t nil)
;;; on-the-left-p  tn-node => (member t nil)

(defun on-the-right-p (node)
  (eq node (rbtn-right (rbtn-parent node))))

(defun on-the-left-p (node)
  (eq node (rbtn-left (rbtn-parent node))))

(declaim (inline on-the-right-p on-the-left-p))

;;; on-the-right-p on-the-left-p --


;;; left-rotate tree node => nil
;;; Left and Right rotation should be simplified. The use of the
;;; sentinel +null-node+ allows for it.

(defun left-rotate (a-tree node &aux (y (rbtn-right node)))
  (setf (rbtn-right node) (rbtn-left y))
  (when (not (null-node-p (rbtn-left y) a-tree))
    (setf (rbtn-parent (rbtn-left y)) node))
  (setf (rbtn-parent y) (rbtn-parent node))
  (cond ((null-node-p (rbtn-parent node) a-tree) ; node is the root
	 (setf (rb-tree-root a-tree) y))
	((on-the-left-p node)
	 (setf (rbtn-left (rbtn-parent node)) y))
	(t				; (on-the-right-p node)
	 (setf (rbtn-right (rbtn-parent node)) y)))
  ;; Finally put node under 'y'.
  (setf (rbtn-left y) node)
  (setf (rbtn-parent node) y)

  ;; ...and update size information.
  (update-sizes y node)
#|
  (setf (rbtn-size y) (actual-rbtn-size node))
  (setf (rbtn-size node) (+ 1
			    (actual-rbtn-size (rbtn-left node))
			    (actual-rbtn-size (rbtn-right node))))
|#
  )
;;; left-rotate --


;;; right-rotate tree node => nil
;;; Left and Right rotation should be simplified. The use of the
;;; sentinel +null-node+ allows for it.

(defun right-rotate (a-tree node &aux (y (rbtn-left node)))
  (setf (rbtn-left node) (rbtn-right y))
  (when (not (null-node-p (rbtn-right y) a-tree))
    (setf (rbtn-parent (rbtn-right y)) node))
  (setf (rbtn-parent y) (rbtn-parent node))
  (cond ((null-node-p (rbtn-parent node) a-tree) ; node is the root
	 (setf (rb-tree-root a-tree) y))
	((on-the-right-p node)
	 (setf (rbtn-right (rbtn-parent node)) y))
	(t				; (on-the-left-p node)
	 (setf (rbtn-left (rbtn-parent node)) y)))
  ;; Finally put node under 'y'
  (setf (rbtn-right y) node)
  (setf (rbtn-parent node) y)

  ;; ...and update size information.
  (update-sizes y node)
  #|
  (setf (rbtn-size y) (actual-rbtn-size node))
  (setf (rbtn-size node) (+ 1
			    (actual-rbtn-size (rbtn-left node))
			    (actual-rbtn-size (rbtn-right node))))
|#
  )
;;; right-rotate --


;;; update-sizes up-node down-node

(defun update-sizes (up-node down-node)
  (setf (rbtn-size up-node) (actual-rbtn-size down-node))
  (setf (rbtn-size down-node)
	(+ 1
	   (actual-rbtn-size (rbtn-left down-node))
	   (actual-rbtn-size (rbtn-right down-node))
	   ))
  )
;;; update-sizes


;;; pprint-tree tree &optional stream integer --
;;; Inorder depth first search of the tree.

(defun pprint-tree (a-tree &optional (strm *standard-output*))
  (labels ((pprint-subtree (node side level)
	     (unless (null-node-p node a-tree)
	       (format strm
		       "~:[~VT~C--~;~2*~][~S ~A ~D]~%"
		       (zerop level)
		       (* level 3)
		       side
		       (tn-content node)
		       (rbtn-color node)
		       (rbtn-size node)
		       )
	       (pprint-subtree (tn-left node) #\l (1+ level))
	       (pprint-subtree (tn-right node) #\r (1+ level))
	       )))
    (if (trees::empty-p a-tree)
	(format strm ">> Empty tree ~A~%" (trees::tree-name a-tree))
	(progn
	  (format strm ">> Tree ~A~%" (trees::tree-name a-tree))
	  (pprint-subtree (tree-root a-tree) #\R 0))
	)))
;;; pprint-tree --


;;;----------------------------------------------------------------------------
;;; External interface functions.


;;; empty-p -- Needs to be redefined in order to use the new 'null-node-p'.

(defun empty-p (a-tree)
  "Checks whether a tree is empty."
  (null-node-p (tree-root a-tree) a-tree))
;;; empty-p --


;;; search key tree --
;;; search does not change w.r.t. binary trees.


;;; insert key a-tree
;;; => tree-node
;;; => (or t nil)

(defun insert (elem a-tree)
  "Inserts an element in the red/black tree.
Arguments:
elem : the element to be inserted (with a 'key')
a-tree : the binary search tree"
  (multiple-value-bind
	(node insertion-p)
      (rbt::internal-insert elem a-tree) ; Just to make the point!
    (values (tn-content node) insertion-p)))

;;; ... but the guts do!
;;; BTW. internal-insert is NOT exported, so this workd just fine!
;;; Magic of the package system.

(defun internal-insert (elem a-tree
			     &aux
			     (compfun (tree-comp-fun a-tree))
			     (keyfun (tree-key-fun a-tree))
			     (eqfun (tree-eq-fun a-tree))
			     (root (tree-root a-tree))
			     (elem-key (funcall keyfun elem))
			     )
  (let ((new-node (make-rbt-node :content elem #|
				 :parent +null-node+
				 :left +null-node+
				 :right +null-node+
                                 |#
				  :parent (rb-tree-null-sentinel a-tree)
				 :left (rb-tree-null-sentinel a-tree)
				 :right (rb-tree-null-sentinel a-tree)
				 :size 1
				 )))
    (if (null-node-p root a-tree)
	(progn (incf (tree-size a-tree))
	       ;; Note that the default color is black.
	       (values (setf (tree-root a-tree) new-node) t))
	(labels
	    ((do-insert (parent-node
			 &aux (parent-key (funcall keyfun
						   (tn-content parent-node))))
	       (cond ((funcall eqfun elem-key parent-key)
		      ;; I do not handle duplicate keys well yet.
		      ;; As a side effect I have to undo the sizes
		      ;; updates I did. To do so I use the routine
		      ;; used also in 'delete-by-key'. But before I
		      ;; must fake the value increase.
		      ;; I know this is ugly; just gimme a break until
		      ;; I fix the handling of duplicates.
		      (incf (rbtn-size parent-node))
		      (update-sizes-up parent-node a-tree)
		      (values parent-node nil))
		     ((funcall compfun elem-key parent-key)
		      (incf (rbtn-size parent-node))
		      ;; First step in maintaining the subtree 'size'.
		      ;; The second one is done in 'left' and
		      ;; 'right' rotations.

		      (if (null-node-p (tn-left parent-node) a-tree)
			  (progn
			    (incf (tree-size a-tree))
			    (setf (tn-parent new-node) parent-node
				  (tn-left parent-node) new-node)
			    (values new-node t))
			  (do-insert (tn-left parent-node))))
		     (t			; else
		      (incf (rbtn-size parent-node))
		      ;; First step in maintaining the subtree 'size'.
		      ;; The second one is done in 'left' and
		      ;; 'right' rotations.
		      
		      (if (null-node-p (tn-right parent-node) a-tree)
			  (progn
			    (incf (tree-size a-tree))
			    (setf (tn-parent new-node) parent-node
				  (tn-right parent-node) new-node)
			    (values new-node t))
			  (do-insert (tn-right parent-node))))
		     ))			; do-insert
	     )
	  (multiple-value-bind (new-node new-insertion-p)
	      (do-insert root)
	    (when new-insertion-p
	      (rebalance-tree new-node a-tree))
	    (values new-node new-insertion-p)))
	)))
;;; insert --


;;; rebalance-tree rb-tree-node rb-tree => nil
;;; Check CLR for a description of this code.

(defun rebalance-tree (new-node a-tree &aux (x new-node))
  (setf (rbtn-color new-node) 'red)
  (loop
   (when (or (eq x (tree-root a-tree)) (black-p (rbtn-parent x)))
     (setf (rbtn-color (tree-root a-tree)) 'black)
     (return-from rebalance-tree))
   (cond ((on-the-left-p (rbtn-parent x))
	  (let ((y (rbtn-right (rbtn-parent (rbtn-parent x))))
		)
	    (cond ((red-p y)
		   (setf (rbtn-color (rbtn-parent x)) 'black
			 (rbtn-color y) 'black
			 (rbtn-color (rbtn-parent (rbtn-parent x))) 'red)
		   (setq x (rbtn-parent (rbtn-parent x))))
		  (t ; (break ">> left right")
		     (when (on-the-right-p x)
		       (setq x (rbtn-parent x))
		       (left-rotate a-tree x))
		     (setf (rbtn-color (rbtn-parent x)) 'black
			   (rbtn-color (rbtn-parent (rbtn-parent x))) 'red)
		     (right-rotate a-tree (rbtn-parent (rbtn-parent x))))
		  )))			; let y right
	 ((on-the-right-p (rbtn-parent x))
	  (let ((y (rbtn-left (rbtn-parent (rbtn-parent x))))
		)
	    (cond ((red-p y)
		   (setf (rbtn-color (rbtn-parent x)) 'black
			 (rbtn-color y) 'black
			 (rbtn-color (rbtn-parent (rbtn-parent x))) 'red)
		   (setq x (rbtn-parent (rbtn-parent x))))
		  (t ; (break ">> right left")
		     (when (on-the-left-p x)
		       (setq x (rbtn-parent x))
		       (right-rotate a-tree x))
		     (setf (rbtn-color (rbtn-parent x)) 'black
			   (rbtn-color (rbtn-parent (rbtn-parent x))) 'red)
		     (left-rotate a-tree (rbtn-parent (rbtn-parent x))))
		  )))			; let y left
	 )				; outer cond
   )					; loop
  )
;;; rebalance-tree --


;;; traverse tree (member :inorder :postorder :preorder)
;;; => (list t)
      

;;; delete-by-key t rb-tree
;;; => rb-tree
;;; See CLR for the explanation.

(defun delete-by-key (elem-key a-tree)
  "Deletes the node with a certain key from the tree.
Arguments:
elem-key : the key to be used in the deleting process
a-tree   : the tree"

  (if (empty-p a-tree)
      (error 'empty-error :a-tree a-tree)
      (let ((delendum (internal-search elem-key a-tree)))
	(if (null-node-p delendum a-tree)
	    (values a-tree nil)
	    (let* ((replacement (if (or
				     (null-node-p (tn-left delendum) a-tree)
				     (null-node-p (tn-right delendum) a-tree))
				    delendum
				    (internal-successor delendum a-tree)))
		   (repl-repl (if (null-node-p (tn-left replacement) a-tree)
				  (tn-right replacement)
				  (tn-left replacement)))
		   )
	      (decf (tree-size a-tree))
	      (update-sizes-up replacement a-tree)

	      ;;(when (not (null-node-p repl-repl) a-tree)
	      ;;  (setf (tn-parent repl-repl) (tn-parent replacement)))
	      ;; Unconditional setiing (thanks to the sentinel)
	      (setf (tn-parent repl-repl) (rbtn-parent replacement))
	      
	      (if (null-node-p (tn-parent replacement) a-tree) ; root
		  (progn
		    (assert (trees::root-node-p replacement a-tree)) ; paranoic
		    (setf (tree-root a-tree) repl-repl)
		  )
		  (if (on-the-left-p replacement)
		      (setf (tn-left (tn-parent replacement)) repl-repl)
		      (setf (tn-right (tn-parent replacement)) repl-repl)))
	      (when (not (eq delendum replacement))
		(splice-in replacement delendum))
	      (when (black-p replacement)
		;; Check CLR for en explanation of the parameters to
		;; the next call. Remember that I am NOT using a sentinel.
		(break ">> Just before fixup")
		(fixup-deletion a-tree repl-repl))
	      (values a-tree t)))
	)))
;;; delete-by-key


;;; update-sizes rb-tree-node rb-tree => nil

(defun update-sizes-up (node a-tree)
  (do ((x node (rbtn-parent x)))
      ((null-node-p x a-tree) nil)
    (decf (rbtn-size x))))
;;; update-sizes


;;; fixup-deletion rb-tree x --

(defun fixup-deletion (a-tree x)
  (loop
   (when (or (eq (tree-root a-tree) x)
	     (red-p x))
     (setf (rbtn-color x) 'black)
     (return-from fixup-deletion))
   ;; looping
   (break ">> Fixup looping")
   (cond ((on-the-left-p x)
	  (let ((x-sibling (rbtn-right (rbtn-parent x))))
	    ;; Case 1
	    (when (red-p x-sibling)
	      (blacken x-sibling)
	      (redden (rbtn-parent x))
	      (left-rotate a-tree (rbtn-parent x))
	      (setq x-sibling (rbtn-right (rbtn-parent x))))
	    ;; Case 2
	    (cond ((and (black-p (rbtn-left x-sibling))
			(black-p (rbtn-right x-sibling)))
		   (redden x-sibling)
		   (setq x (rbtn-parent x)))
		  (t
		   (when (black-p (rbtn-right x-sibling))
		     (blacken (rbtn-left x-sibling))
		     ;; I know that it must be non null (since it is red)
		     (redden x-sibling)
		     (right-rotate a-tree x-sibling)
		     (setq x-sibling (rbtn-right (rbtn-parent x))))
		   (setf (rbtn-color x-sibling)
			 (rbtn-color (rbtn-parent x)))
		   (blacken (rbtn-parent x))
		   (blacken (rbtn-right x-sibling))
		   (left-rotate a-tree (rbtn-parent x))
		   (setq x (tree-root a-tree)))
		  )))

	 ;; This second branch of the cond is simmetric to the first
	 ;; one. All the 'left' have been replaced by 'right' and
	 ;; viceversa. (At least I hope so!)
	 ((on-the-right-p x)
	  (let ((x-sibling (rbtn-left (rbtn-parent x))))
	    ;; Case 1
	    (when (red-p x-sibling)
	      (blacken x-sibling)
	      (redden (rbtn-parent x))
	      (right-rotate a-tree (rbtn-parent x))
	      (setq x-sibling (rbtn-left (rbtn-parent x))))
	    ;; Case 2
	    (cond ((and (black-p (rbtn-left x-sibling))
			(black-p (rbtn-right x-sibling)))
		   (redden x-sibling)
		   (setq x (rbtn-parent x)))
		  (t
		   (when (black-p (rbtn-left x-sibling))
		     (blacken (rbtn-right x-sibling))
		     ;; I know that it must be non null (since it is red)
		     (redden x-sibling)
		     (left-rotate a-tree x-sibling)
		     (setq x-sibling (rbtn-left (rbtn-parent x))))
		   (setf (rbtn-color x-sibling)
			 (rbtn-color (rbtn-parent x)))
		   (blacken (rbtn-parent x))
		   (blacken (rbtn-left x-sibling))
		   (right-rotate a-tree (rbtn-parent x))
		   (setq x (tree-root a-tree)))
		  )))
	 (t (error ">> RED BLACK TREES : something is wrong in the ~
                    fixup loop"))
	 )))
;;; fixup-deletion


;;; select integer rb-tree => t

(defun select (i a-tree)
  "Returns the i-th element in the inorder traversal of the red black tree.
Arguments:
i      : an integer
a-tree : a red-black tree"
  (cond ((empty-p a-tree)
	 (error 'empty-error :a-tree a-tree))
	((minusp i)
	 (error ">> RED BLACK TREES: negative index ~D" i))
	((>= i (tree-size a-tree))
	 (error ">> RED BLACK TREES: index (~D) is grater than or ~
                 equal to the tree size (~D)."
		i
		(tree-size a-tree)))
	(t
	 (tn-content (internal-select (tree-root a-tree) (1+ i))))
	))

(defun internal-select (node i
			     &aux
			     (rank (1+ (actual-rbtn-size (rbtn-left node))))
			     )
  (cond ((= i rank) node)
	((< i rank)
	 (internal-select (rbtn-left node) i))
	(t
	 (internal-select (rbtn-right node) (- i rank)))
	))
;;; select --


;;; element-rank t rb-tree => t
;;;
;;; Notes:
;;; 12.30.92: I do not maintain ranks yet.

(defun element-rank (elem-key a-tree)
  "Returns the rank of the element indexed by the key in a red-black tree.
Arguments:
elem-key : a key
a-tree   : a red-black tree with compatible keys"
  (let ((node (internal-search elem-key a-tree)))
    (when (not (null-node-p node a-tree))
      (do ((node-rank (1+ (actual-rbtn-size (rbtn-left node)))
		      (if (on-the-right-p node-pointer)
			  (+ 1
			     node-rank
			     (actual-rbtn-size
			      (rbtn-left (rbtn-parent node-pointer))))
			  node-rank))
	   (node-pointer node (rbtn-parent node-pointer))
	   (root (tree-root a-tree))
	   )
	  ((eq root node-pointer) (1- node-rank))
	))))
;;; element-rank


;;; end of file -- rbtrees.lisp --