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

;;; binary-trees.lisplisp --
;;; Binary Search Trees in the CLR style (Cormen,
;;; Leiserson and Rivest, "Introduction to Algorithms", ppgg.
;;; 244-262, MIT Press).
;;; Array implementation.
;;;
;;; 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: 1.0 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]
;;;
;;; TREE-NODE (content left right parent)                           [STRUCTURE]
;;;
;;; +NULL-NODE+ (make-tree-node)                                     [CONSTANT]
;;;
;;; +NULL-NODE+ (make-tree-node)                                     [CONSTANT]
;;;
;;; TREE (name root null-sentinel comp-fun key-fun eq-fun size)     [STRUCTURE]
;;;
;;; +STANDARD-TREE-ALLOCATION-SIZE+ 16                               [CONSTANT]
;;;
;;; +STANDARD-EXTEND-SIZE+ 16                                        [CONSTANT]
;;;
;;; EMPTY-ERROR (a-tree)                                            [CONDITION]
;;;    Error signaled when an operation is tried on an empty tree
;;;
;;; TREE-NODE-PRINT (tn strm k)                                      [FUNCTION]
;;;
;;; TREE-PRINT (tn strm k)                                           [FUNCTION]
;;;
;;; MAKE-BINARY-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)
;;;
;;; ELEMENT-TYPE (a-tree)                                            [FUNCTION]
;;;
;;; NULL-NODE-P (tn a-tree)                                          [FUNCTION]
;;;
;;; ROOT-NODE-P (node a-tree)                                        [FUNCTION]
;;;
;;; PPRINT-TREE (a-tree &optional (strm *standard-output*))          [FUNCTION]
;;;
;;; EMPTY-P (a-tree)                                                 [FUNCTION]
;;;    Checks whether a tree is empty.
;;;
;;; SEARCH (key a-tree &aux (result (internal-search key a-tree)))   [FUNCTION]
;;;    Retrieves an element from a tree by key.
;;;    Arguments:
;;;    key : the key to be used in the search
;;;    a-tree : the tree
;;;
;;; INTERNAL-SEARCH (key a-tree)                                     [FUNCTION]
;;;
;;; INSERT (elem a-tree)                                             [FUNCTION]
;;;    Inserts an element in the binary search 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)))
;;;
;;; IN-TRAVERSE (node a-tree)                                        [FUNCTION]
;;;
;;; PRE-TRAVERSE (node a-tree)                                       [FUNCTION]
;;;
;;; POST-TRAVERSE (node a-tree)                                      [FUNCTION]
;;;
;;; TRAVERSE (a-tree &optional (order :inorder))                     [FUNCTION]
;;;    Traverses a tree in one of the three standard ways: inorder,
;;;    preorder or postorder.
;;;    Arguments:
;;;    a-tree : tree
;;;    &optional
;;;    order  : (member :inorder :preorder :postorder) (default :inorder)
;;;
;;; 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
;;;
;;; SPLICE-IN (replacement delendum)                                 [FUNCTION]
;;;
;;; MINIMUM (a-tree)                                                 [FUNCTION]
;;;    Returns the 'minimum' element in the tree w.r.t. the comparison
;;;    function associated.
;;;    Arguments:
;;;    a-tree : tree
;;;
;;; SUBTREE-MINIMUM (node a-tree)                                    [FUNCTION]
;;;
;;; MAXIMUM (a-tree)                                                 [FUNCTION]
;;;    Returns the 'minimum' element in the tree w.r.t. the comparison
;;;    function associated.
;;;    Arguments:
;;;    a-tree : tree
;;;
;;; SUBTREE-MAXIMUM (node a-tree)                                    [FUNCTION]
;;;
;;; SUCCESSOR (elem-key a-tree                                       [FUNCTION]
;;;            &aux
;;;            (result
;;;            (internal-successor (internal-search elem-key a-tree)
;;;            a-tree)))
;;;    Returns the 'successor' in a tree of the element with a certain
;;;    key. The result depends on the comparison function associated with
;;;    the tree. Note that nil is returned if no element with the given tree
;;;    exists in the data structure
;;;    Arguments:
;;;    elem-key : the key to be used
;;;    a-tree   : a tree
;;;
;;; INTERNAL-SUCCESSOR (elem-node a-tree)                            [FUNCTION]
;;;
;;; PREDECESSOR (elem-key a-tree                                     [FUNCTION]
;;;              &aux
;;;              (result
;;;              (internal-predecessor
;;;              (internal-search elem-key a-tree) a-tree)))
;;;    Returns the 'predecessor' in a tree of the element with a certain
;;;    key. The result depends on the comparison function associated with
;;;    the tree. Note that nil is returned if no element with the given tree
;;;    exists in the data structure
;;;    Arguments:
;;;    elem-key : the key to be used
;;;    a-tree   : a tree
;;;
;;; INTERNAL-PREDECESSOR (elem-node a-tree)                          [FUNCTION]


;;;============================================================================
;;; History:
;;; 12.30.1992: modified internal structure in order to use a sentinel
;;;             for the 'null' nodes. This simplifies some of the
;;;             algorithms and allows for code reusability in the RED
;;;             BLACK TREES package.
;;; 12.26.1992: released.


;;;============================================================================;;; 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.


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


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

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

(in-package "TREES")


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

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

(defun version ()
  (values "BINARY SEARCH TREES: version 1.0 beta"
	  1
	  0
	  "beta"
	  ))
;;; version


;;; tree-node structure --

(defstruct (tree-node (:print-function tree-node-print)
		      (:conc-name tn-))
  content
  left
  right
  parent
  )
;;; tree-node --


;;; +null-node+ parameter -- The 'sentinel' used in various
;;; algorithms. It is defined as a parameter in order to redefine it
;;; for richer tree structures (e.g. red balck trees).

#-:sentinel (defconstant +null-node+ (make-tree-node))
(defconstant +null-node+ (make-tree-node))
;;; +null-node+ --


;;; tree structure --

(defstruct (tree (:print-function tree-print))
  (name nil			:type symbol)
  (root +null-node+		:type tree-node)
  (null-sentinel +null-node+	:type tree-node)
  (comp-fun #'<)
  (key-fun #'identity)
  (eq-fun #'=)
  (size 0 :type integer)
  )
;;; tree --


;;; +standard-tree-allocation-size+ +standard-extend-size+ --

(defconstant +standard-tree-allocation-size+ 16)

(defconstant +standard-extend-size+ 16)
;;; +standard-tree-allocation-size+ +standard-extend-size+ --


;;; empty-error condition --

(define-condition empty-error (simple-error)
  (a-tree)
  (:report
   (lambda (cnd strm)
     (format strm
	     ">> TREES: empty tree~:[ ~A.~;.~]"
	     (null (tree-name (empty-error-a-tree cnd)))
	     (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.

;;; tree-node-print tree-node stream integer => nil --

(defun tree-node-print (tn strm k)
  (declare (ignore k))
  (print-unreadable-object (tn strm :type t :identity t)
			   (format strm "~S"
				   (tn-content tn)
				   )))
;;; tree-node-print --


;;; tree-print tree stream integer => nil --

(defun tree-print (tn strm k)
  (declare (ignore k))
  (print-unreadable-object (tn strm :type t :identity t)
			   (format strm "~@[name ~A ~]size ~D"
				   (tree-name tn)
				   (tree-size tn))))
;;; tree-print --


;;; make-binary-tree

(defun make-binary-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-tree-node))
	 (a-tree (make-tree :comp-fun test
			    :key-fun key
			    :eq-fun equality-test
			    :name name
			    :root sentinel
			    :null-sentinel sentinel
			    )))
    a-tree))
;;; make-binary-tree --


;;; size tree => integer --

(setf (symbol-function 'size) #'tree-size)
;;; size --


;;; element-type tree => Type Specifier --
;;; Just for the time being.

(defun element-type (a-tree) (declare (ignore a-tree)) t)
;;; element-type --


;;;----------------------------------------------------------------------------
;;; 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.
#+old
(defun null-node-p (tn)
  #-:sentinel (null tn)
  #+:sentinel (eq tn +null-node+)
  )

(defun null-node-p (tn a-tree)
  (eq tn (tree-null-sentinel a-tree)))

(declaim (inline null-node-p))

;;; null-node-p


;;; root-node-p tree-node tree => (member t nil)

(defun root-node-p (node a-tree) (eq node (tree-root a-tree)))

(declaim (inline root-node-p))

;;; root-node-p


;;; 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]~%"
		       (zerop level)
		       (* level 3)
		       side
		       (tn-content node))
	       (pprint-subtree (tn-left node) #\l (1+ level))
	       (pprint-subtree (tn-right node) #\r (1+ level))
	       )))
    (if (empty-p a-tree)
	(format strm ">> Empty tree ~A~%" (tree-name a-tree))
	(progn
	  (format strm ">> Tree ~A~%" (tree-name a-tree))
	  (pprint-subtree (tree-root a-tree) #\R 0))
	)))
;;; pprint-tree --


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

;;; empty-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
;;; => t
;;; => (member t nil)

(defun search (key a-tree &aux (result (internal-search key a-tree)))
  "Retrieves an element from a tree by key.
Arguments:
key : the key to be used in the search
a-tree : the tree"
  (if (null-node-p result a-tree)
      (values nil nil)
      (values (tn-content result) t)))

(defun internal-search (key a-tree)
  (let ((compfun (tree-comp-fun a-tree))
	(eqfun (tree-eq-fun a-tree))
	(keyfun (tree-key-fun a-tree))
	)
    (labels ((do-search (node
			 &aux (node-key (and node
					     (funcall keyfun
						      (tn-content node)))))
			(cond ((null-node-p node a-tree)
			       (tree-null-sentinel a-tree))
			      ((funcall eqfun node-key key) node)
			      ((funcall compfun node-key key)
			       (do-search (tn-right node)))
			      (t (do-search (tn-left node)))
			  )))
      (do-search (tree-root a-tree))
      )))
;;; search --


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

;;; The old version assumes non duplicates keys. (It is really out of
;;; date now).
;;; I should go back to this and fix it up. The recursive version is
;;; more elegant and tail-recursive, but you never know.
#+old 
(defun insert (elem-key a-tree
			&aux
			(compfun (tree-comp-fun a-tree))
			(eqfun (tree-eq-fun a-tree))
			(root (tree-root a-tree))
			)
  "Inserts an element in the binary search tree.
Arguments:
elem : the element to be inserted
a-tree : the binary search tree"

  (do* ((new-node (make-tree-node :content elem-key
				  :parent (tree-null-sentinel a-tree)
				  :left   (tree-null-sentinel a-tree)
				  :right  (tree-null-sentinel a-tree)
				  )
		  new-node)
	((x root (if (funcall compfun elem-key (tn-content x))
		     (tn-left x)
		   (tn- x)))
	 (parent-node nil x)))
      ((null-node-p x a-tree)
       (setf (parent new-node) parent-node)
       (if (null-node-p x a-tree)
	   (progn
	     (setf (tree-root a-tree) new-node)
	     (values new-node t))
	 (if (funcall compfun elem-key (tn-content parent-node))
	     (setf (tn-left parent-node) new-node)
	   (setf (tn-right parent-node) new-node)))
       (values new-node t))))

(defun insert (elem a-tree)
  "Inserts an element in the binary search tree.
Arguments:
elem : the element to be inserted (with a 'key')
a-tree : the binary search tree"

  (multiple-value-bind
	(node insertion-p)
      (internal-insert elem a-tree)
    (values (tn-content node) insertion-p)))

(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-tree-node :content elem-key
				  :parent (tree-null-sentinel a-tree)
				  :left   (tree-null-sentinel a-tree)
				  :right  (tree-null-sentinel a-tree)
				  ))
	)
    (if (null-node-p root a-tree)
	(progn (incf (tree-size a-tree))
	       (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)
		      (values parent-node nil))
		     ((funcall compfun elem-key parent-key)
		      (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
		      (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 root)))
    ))
;;; insert --


;;; traverse tree (member :inorder :postorder :preorder)
;;; => (list t)
;;; ... and auxiliary functions.

(defun in-traverse (node a-tree)
  (if (null-node-p node a-tree)
      nil
      (nconc (in-traverse (tn-left node) a-tree)
	     (list (tn-content node))
	     (in-traverse (tn-right node) a-tree))))

(defun pre-traverse (node a-tree)
  (if (null-node-p node a-tree)
      nil
      (nconc (list (tn-content node))
	     (pre-traverse (tn-left node) a-tree)
	     (pre-traverse (tn-right node) a-tree))))

(defun post-traverse (node a-tree)
  (if (null-node-p node a-tree)
      nil
      (nconc (post-traverse (tn-left node) a-tree)
	     (post-traverse (tn-right node) a-tree)
	     (list (tn-content node)))))

(defun traverse (a-tree &optional (order :inorder))
  "Traverses a tree in one of the three standard ways: inorder,
preorder or postorder.
Arguments:
a-tree : tree
&optional
order  : (member :inorder :preorder :postorder) (default :inorder)"

  (declare (inline in-traverse post-traverse pre-traverse))
  (ccase order
    (:inorder (in-traverse (tree-root a-tree) a-tree))
    (:preorder (pre-traverse (tree-root a-tree) a-tree))
    (:postorder (post-traverse (tree-root a-tree) a-tree))
    ))
;;; traverse --
      

;;; delete-by-key elem a-tree
;;; => a-tree
;;; See CLR for the explanation.

#+old
(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)
	    (values a-tree nil)
	    (let* ((replacement (if (or (null-node-p (tn-left delendum))
					(null-node-p (tn-right delendum)))
				    delendum
				    (internal-successor delendum)))
		   (repl-repl (if (null-node-p (tn-left replacement))
				  (tn-right replacement)
				  (tn-left replacement)))
		   )
	      (decf (tree-size a-tree))
	      (when (not (null-node-p repl-repl))
		(setf (tn-parent repl-repl) (tn-parent replacement)))
	      (if (null-node-p (tn-parent replacement)) ; root
		  (setf (tree-root a-tree) repl-repl)
		  (if (eq replacement (tn-left (tn-parent 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))
	      (values a-tree t)))
	)))

(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))
	      (when (not (null-node-p repl-repl a-tree))
		(setf (tn-parent repl-repl) (tn-parent replacement)))
	      (if (null-node-p (tn-parent replacement) a-tree) ; root
		  (setf (tree-root a-tree) repl-repl)
		  (if (eq replacement (tn-left (tn-parent 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))
	      (values a-tree t)))
	)))

(defun splice-in (replacement delendum)
  (setf (tn-content delendum) (tn-content replacement)))

;;; delete-by-key --


;;; minimum tree => t

(defun minimum (a-tree)
  "Returns the 'minimum' element in the tree w.r.t. the comparison
function associated.
Arguments:
a-tree : tree"
  
  (if (empty-p a-tree)
      (error 'empty-error :a-tree a-tree)
      (tn-content (subtree-minimum (tree-root a-tree) a-tree))))

(defun subtree-minimum (node a-tree)
  (do ((min-node node (tn-left min-node)))
      ((null-node-p (tn-left min-node) a-tree) min-node)))
;;; minimum --


;;; maximum tree => t

(defun maximum (a-tree)
  "Returns the 'minimum' element in the tree w.r.t. the comparison
function associated.
Arguments:
a-tree : tree"

  (if (empty-p a-tree)
      (error 'empty-error :a-tree a-tree)
      (tn-content (subtree-maximum (tree-root a-tree) a-tree))))

(defun subtree-maximum (node a-tree)
  (do ((max-node node (tn-right max-node)))
      ((null-node-p (tn-right max-node) a-tree) max-node)))
;;; maximum --


;;; successor t tree
;;; => t
;;; => (member nil t)

(defun successor (elem-key a-tree
			   &aux
			   (result (internal-successor
				    (internal-search elem-key a-tree)
				    a-tree)))
  "Returns the 'successor' in a tree of the element with a certain
key. The result depends on the comparison function associated with the
tree. Note that nil is returned if no element with the given tree
exists in the data structure
Arguments:
elem-key : the key to be used
a-tree   : a tree"
  (if (null-node-p result a-tree)
      (values nil nil)
      (values (tn-content result) t)))

(defun internal-successor (elem-node a-tree)
  (if (null-node-p elem-node a-tree)
      elem-node
    (if (not (null-node-p (tn-right elem-node) a-tree))
	(subtree-minimum (tn-right elem-node) a-tree)
	(do ((parent-node (tn-parent elem-node) (tn-parent parent-node))
	     (current elem-node parent-node)
	     )
	    ((or (null-node-p parent-node a-tree)
		 (not (eq current (tn-right parent-node))))
	     parent-node))
	)))
;;; successor --


;;; predecessor t tree
;;; => t
;;; => (member t nil)

(defun predecessor (elem-key a-tree
			     &aux
			     (result (internal-predecessor
				      (internal-search elem-key a-tree)
				      a-tree)))
  "Returns the 'predecessor' in a tree of the element with a certain
key. The result depends on the comparison function associated with the
tree. Note that nil is returned if no element with the given tree
exists in the data structure
Arguments:
elem-key : the key to be used
a-tree   : a tree"
    (if (null-node-p result a-tree)
      (values nil nil)
      (values (tn-content result) t)))

(defun internal-predecessor (elem-node a-tree)
  (if (null-node-p elem-node a-tree)
      elem-node
    (if (not (null-node-p (tn-left elem-node) a-tree))
	(subtree-maximum (tn-left elem-node) a-tree)
	(do ((parent-node (tn-parent elem-node) (tn-parent parent-node))
	     (current elem-node parent-node)
	     )
	    ((or (null-node-p parent-node a-tree)
		 (not (eq current (tn-left parent-node))))
	     parent-node))
	)))
;;; predecessor --


;;; end of file -- binary-trees.lisp --