gistfile1.lisp

(defstruct rb
  (l nil) (r nil) data (red T))
(defparameter *tree* nil)

(defun rb-kid (root dirs)
"Get children of node via (rb-kid node '(nil nil T nil))
 where nil means left and T means the right branch of a node."
  (if (endp dirs) root
    (if (car dirs)
      (rb-kid (rb-r root) (cdr dirs))
      (rb-kid (rb-l root) (cdr dirs)))))
#|
(defun set-rb-kid (root dirs store)
"Set children of node via (set-rb-kid node '(nil nil T nil) value)
 where nil means left and T means the right branch of a node."
  (if (endp dirs) (setf root store)
      (if (car dirs)
	(set-rb-kid (rb-r root) (cdr dirs))
	(set-rb-kid (rb-l root) (cdr dirs))))

(defun set-rb-kid (root dirs store)
"Set children of node via (set-rb-kid node '(nil nil T nil) value)
 where nil means left and T means the right branch of a node."
  (if (endp dirs)
      (if dir (setf (rb-r old-root) store) (setf (rb-l old-root) store))
      (let ((old-root root)
	    (dir (car dirs))
	    (node (if (car dirs) (rb-r root) (rb-l root))))
	(set-rb-kid node (cdr dirs) store))))
|#

(defun set-rb-kid (root dirs store)
  (labels ((set-rb-kid-i (old new dir dirs)
	     (if (endp dirs)
		 (if dir (setf (rb-r old) store) (setf (rb-l old) store))
		 (if dir
		     (set-rb-kid-i new (rb-r new) (car dirs) (cdr dirs))
		     (set-rb-kid-i new (rb-r new) (car dirs) (cdr dirs))))))
    (let ((new (if (car dirs) (rb-r root) (rb-l root)))
	  (dir (car dirs)))
      (set-rb-kid-i root new dir (cdr dirs)))))

	  


(defsetf rb-kid set-rb-kid)

(defun is-red (root)
  (and (not (null root)) (rb-red root)))

(defun rotate-single (root dir)
  (let ((save (rb-kid root `(,(not dir)))))
    (setf (rb-kid root `(,(not dir))) (rb-kid root `(,dir))
	  (rb-kid save `(,dir)) root
	  (rb-red root) T
	  (rb-red save) nil)
    save))

(defun rotate-double (root dir)
  (setf (rb-kid root `(,(not dir))) (rotate-single (rb-kid root `(,(not dir))) (not dir)))
  (rotate-single root dir))

;; (defun rb-insert-old (root data)
;;  (cond ((null root) (make-rb :data data))
;;        ((> (rb-data root) data)
;;            (setf (rb-l root) (rb-insert-old (rb-l root) data)) root)
;;        (T  (setf (rb-r root) (rb-insert-old (rb-r root) data)) root)))

(defun rb-insert-r (root data)
  (if (null root) (make-rb :data data)
      (let ((dir (> data (rb-data root))))
	(setf (rb-kid root `(,dir))
	      (rb-insert-r (rb-kid root `(,dir)) data))
	(if (is-red (rb-kid root `(,dir)))
	    (if (is-red (rb-kid root `(,(not dir))))
		(setf (rb-red root) T
		      (rb-red (rb-kid root '(nil))) nil
		      (rb-red (rb-kid root '(T))) nil)
		(if (is-red (rb-kid root `(,dir ,dir)))
		    (setf root (rotate-single root (not dir)))
		    (if (is-red (rb-kid root `(,dir ,(not dir))))
			(setf root (rotate-double root (not dir)))))))
	root)))

(defun rb-remove (data)
  (let ((d nil))
    (labels ((done () d)
	     (set-done (v) (setf d v)))
      (defsetf done set-done)
      (rb-remove-r *tree* data done)))) 

(defun rb-remove-r (root data done)
  (if (null root) (setf done T)
      (if (equal data (rb-data root))
	  (let ((dir (> data (rb-data root))))
	    (if (or (null (rb-kid root '(nil))) (null (rb-kid root '(T))))
		(let ((save (rb-kid root `(,(null root '(nil))))))
		  (if (is-red root) (setf done T)
		      (if (is-red save)
			  (setf (rb-red save) T
				done T)))
		  (return-from rb-remove-r save))
		(let ((heir (rb-kid root '(nil))))
		  (loop while (rb-kid heir '(T)) do (setf heir (rb-kid heir '(T))))
		  (setf (rb-data root) (rb-data heir)
			data (rb-data heir))))
	    (setf (rb-kid root `(,dir))
		  (rb-remove-r (rb-kid root `(,dir)) data done))
	    (if (note done)
		(setf root (rb-remove-balance root dir done)))
	    root))))

(defun rb-remove-balance (root dir done)
  (let ((p root) (s (rb-kid root `(,(not dir)))))
    (if (and s (not (is-red s)))
	(if (not (or (is-red (rb-kid s '(nil))) (is-red (rb-kid s '(T)))))
	    (if (is-red p)
		(setf done T
		      (rb-red p) nil
		      (rb-red s) T))
	    (let ((root-red (rb-red root)))
	      (if (is-red (rb-kid s `(,(not dir))))
		  (setf p (rotate-single p dir))
		  (setf p (rotate-double p dir)))
	      (setf (rb-red p) root-red
		    (rb-red (rb-kid p '(nil))) nil
		    (rb-red (rb-kid p '(T))) nil)))
	(if (rb-kid s `(,dir))
	    (let ((r (rb-kid s `(,dir))))
	      (if (not (or (is-red (rb-kid r '(nil))) (is-red (rb-kid r '(T)))))
		  (setf p (rotate-single p dir)
			(rb-red (rb-kid p `(,dir ,(not dir)))) T)
		  (progn
		    (if (is-red (rb-kid r `(,dir)))
			(setf (rb-kid s `(,dir)) (rotate-single r (not dir))))
		    (setf p (rotate-double p dir)
			  (rb-red (rb-kid s `(,dir))) nil
			  (rb-red (rb-kid p `(,(not dir)))) T)))
	      (setf (rb-red p) nil
		    (rb-red (rb-kid p `(,dir))) nil
		    done T))))
    p))


(defun rb-insert (data)
  (setf *tree* (rb-insert-r *tree* data)
	(rb-red *tree*) nil)
  *tree*)


(rb-insert 7)
(rb-insert 6)
;(rb-insert 5)