;;; -*- Mode: Lisp -*-
;;;
;;; $Header: /home/gene/library/website/docsrc/amo/RCS/red-black-set.lisp,v 395.1 2008/04/20 17:25:45 gene Exp $
;;;
;;; Copyright (c) 2006 Gene Michael Stover.  All rights reserved.
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU Lesser General Public License as
;;; published by the Free Software Foundation; either version 2 of the
;;; License, or (at your option) any later version.
;;;
;;; This program 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 Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301
;;; USA
;;;

(defpackage "RED-BLACK-SET"
  (:use "COMMON-LISP")
  (:import-from "CYBERTIGGYR-TEST" "CHECK" "DEFTEST")
  (:export "DEF-RED-BLACK-SET"
	   "RED-BLACK-SET"))

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

;;;
;;; This is an implimentation of red/black trees in Lisp, converted
;;; from the Standard ML implementation in Okasaki's "Purely
;;; Functional Data Structures".
;;;

;;;
;;; I'm going to try something different here compared to how I
;;; implemented heaps from earlier parts of Okasaki's book.
;;; Instead of having one set of functions & relying on some
;;; CLOS functions to do comparators, I'm going to use a macro
;;; to make a red/black set that is customized to a particular
;;; comparison function.
;;; I'm doing it this way because I haven't done it before, &
;;; I'd like to know how well it works.
;;; I predict it will make testing more difficult.
;;;

(defmacro def-red-black-set (name lessp)
  "NAME is the base of the symbols we're about to define, sort of
like the name you supply to defstruct.  LESSP may be a function or
a symbol that is fbound to a function."
  (declare (type symbol name))
  (let ((make-name (intern (format nil "MAKE-~A" name)))
	(name-as-list (intern (format nil "~A-AS-LIST" name)))
	(name-balance (intern (format nil "~A-BALANCE" name)))
	(name-color (intern (format nil "~A-COLOR" name)))
	(name-insert (intern (format nil "~A-INSERT" name)))
	(name-left (intern (format nil "~A-LEFT" name)))
        (name-member (intern (format nil "~A-MEMBER" name)))
	(name-remove-if (intern (format nil "~A-REMOVE-IF" name)))
	(name-right (intern (format nil "~A-RIGHT" name)))
	(name-value (intern (format nil "~A-VALUE" name))))
    `(progn
       (defstruct ,name
	 (color :black)
	 left
	 value
	 right)

       (defun ,name-member (x set)
	 (if set
	     (let ((a (,name-left set))
		   (b (,name-right set))
		   (y (,name-value set)))
	       (cond ((,lessp x y) (,name-member x a))
		     ((,lessp y x) (,name-member x b))
		     (t)))
	   ;; else, set is nil, so X ain't in it.
	   nil))

       (defun ,name-balance (self)
	 (if (eq (,name-color self) :red)
	     ;; When this node is RED, we don't change it at all.
	     self
	   ;; else, Self's color is BLACK, so we balance.
	   (let ((l-is-red (and self
				(,name-left self)
				(eq :red (,name-color (,name-left self)))))
		 (ll-is-red (and self
				 (,name-left self)
				 (,name-left (,name-left self))
				 (eq :red (,name-color (,name-left (,name-left self))))))
		 (lr-is-red (and self
				 (,name-left self)
				 (,name-right (,name-left self))
				 (eq :red (,name-color (,name-right (,name-left self))))))
		 (r-is-red (and self
				(,name-right self)
				(eq :red (,name-color (,name-right self)))))
		 (rl-is-red (and self
				 (,name-right self)
				 (,name-left (,name-right self))
				 (eq :red (,name-color (,name-left (,name-right self))))))
		 (rr-is-red (and self
				 (,name-right self)
				 (,name-right (,name-right self))
				 (eq :red (,name-color (,name-right (,name-right self))))))
		 a b c d x y z)
	     (cond ((and l-is-red ll-is-red)
		    (setq z self)
		    (setq y (,name-left z))
		    (setq x (,name-left y))
		    (setq a (,name-left x))
		    (setq b (,name-right x))
		    (setq c (,name-right c))
		    (setq d (,name-right z))
		    (,make-name
		     :color :red
		     :left (,make-name :color :black :left a
				       :value (,name-value x)
				       :right b)
		     :value (,name-value y)
		     :right (,make-name :color :black :left c
					:value (,name-value z) :right d)))
		   ((and l-is-red lr-is-red)
		    (setq z self)
		    (setq x (,name-left z))
		    (setq y (,name-right x))
		    (setq a (,name-left x))
		    (setq b (,name-left y))
		    (setq c (,name-right y))
		    (setq d (,name-right z))
		    (,make-name
		     :color :red
		     :left (,make-name :color :black :left a
				       :value (,name-value x)
				       :right b)
		     :value (,name-value y)
		     :right (,make-name :color :black :left c
					:value (,name-value z) :right d)))
		   ((and r-is-red rr-is-red)
		    (setq x self)
		    (setq y (,name-right x))
		    (setq z (,name-right y))
		    (setq a (,name-left x))
		    (setq b (,name-left y))
		    (setq c (,name-left z))
		    (setq d (,name-right z))
		    (,make-name
		     :color :red
		     :left (,make-name :color :black :left a
				       :value (,name-value x)
				       :right b)
		     :value (,name-value y)
		     :right (,make-name :color :black :left c
					:value (,name-value z) :right d)))
		   ((and r-is-red rl-is-red)
		    (setq x self)
		    (setq z (,name-right x))
		    (setq y (,name-left z))
		    (setq a (,name-left x))
		    (setq b (,name-left y))
		    (setq c (,name-right y))
		    (setq d (,name-right z))
		    (,make-name
		     :color :red
		     :left (,make-name :color :black :left a
				       :value (,name-value x)
				       :right b)
		     :value (,name-value y)
		     :right (,make-name :color :black :left c
					:value (,name-value z) :right d)))
		   (t self)))))
	      
       (defun ,name-insert (x set)
	 (labels
	     ((ins (set)
		   (cond ((null set) (,make-name :color :red
						 :left nil
						 :value x
						 :right nil))
			 ((,lessp x (,name-value set))
			  (,name-balance
			   (,make-name :color (,name-color set)
				       :left (ins (,name-left set))
				       :value (,name-value set)
				       :right (,name-right set))))
			 ((,lessp (,name-value set) x)
			  (,name-balance
			   (,make-name :color (,name-color set)
				       :left (,name-left set)
				       :value (,name-value set)
				       :right (ins (,name-right set)))))
			 (t set))))
	   (let ((y (ins set)))
	     (,make-name :color :black
			 :left (,name-left y)
			 :value (,name-value y)
			 :right (,name-right y)))))

       (defun ,name-as-list (set)
	 "Do an in-order traversal, collecting the values into a list."
	 (if set
	     (append (,name-as-list (,name-left set))
		     (list (,name-value set))
		     (,name-as-list (,name-right set)))
	   nil))

       (defun ,name-remove-if (p set0)
	 (declare (type (or symbol function) p))
	 ;; fixme: This is about as inefficient as an implementation
	 ;; can be.  We convert SET0 to a list, remove the
	 ;; elements which satisfy the predicate, then create a
	 ;; new Red-Black tree with the remaining elements.
	 (let ((set1 nil))
	   (dolist (x (remove-if p (,name-as-list set0)))
	     (setq set1 (,name-insert x set1)))
	   set1))

       '(,name
	 ,make-name
	 ,name-as-list
	 ,name-balance
	 ,name-insert
	 ,name-left
	 ,name-member
	 ,name-remove-if
	 ,name-right
	 ,name-value))))

;;; --- end of file ---