(defstruct (bnt-node (:conc-name) (:print-object (lambda (nd s) (format s "~A" (node-item nd)))))

  (node-item nil)

  (left nil)

  (right nil))






(defstruct (rbt-node (:include bnt-node) (:conc-name))

  (color :black)
   
  (parent nil))




(defparameter *sentinel* (make-rbt-node))



;(setf *old-print-level* *print-level*)
;(setf *print-level* 1)



(setf (parent *sentinel*) nil)

(setf (left *sentinel*) *sentinel*)

(setf (right *sentinel*) *sentinel*)


;(setf *print-level* *old-print-level*)



(defun init (node)

  (setf (left node) *sentinel*)

  (setf (right node) *sentinel*)

  node)







(defun rbt-null (x)

  (eql *sentinel* x))


(declaim (inline rbt-null))



(defun rotate-left (x)

  (cond ((rbt-null x) nil)

        (t

         (let* ((y (right x))

                (b (left y)))

           (setf (right x) b)

           (setf (left y) x)

           (unless (rbt-null b)

             (setf (parent b) x))

           (unless (parent x)

             (setf (parent y) nil)

             (setf (parent x) y)

             (return-from rotate-left y))

           (setf (parent y) (parent x))

           (if (is-left-child x)

               (setf (left (parent x)) y)

             (setf (right (parent x)) y))

           (setf (parent x) y)

           nil))))



; der folgende code ist dual unter left-right x-y


(defun rotate-right (y)

  (cond ((rbt-null y) nil)

        (t

         (let* ((x (left y))

                (b (right x)))

           (setf (left y) b)

           (setf (right x) y)

           (unless (rbt-null b)

             (setf (parent b) y))

           (unless (parent y)

             (when (not (rbt-null x))
               
               (setf (parent x) nil))
               
             (setf (parent y) x)

             (return-from rotate-right x))
 
           (setf (parent x) (parent y))

           (if (is-right-child y)

               (setf (right (parent y)) x)

             (setf (left (parent y)) x))

           (setf (parent y) x)

           nil))))
   






;; back-values from insert item:

;; 1) new-root

;; 2) node-that-was-inserted-or-found

;; 3) item-already-been-in (t or nil)



(defun insert-item (it root &key (test-equal #'=) (test #'<) (key #'identity))

(let ((p) (n) (new-root root))

  (setf p (loop  with q = root

                 with p = nil
 
                 finally (return p)

                 while (not (rbt-null q))

                 do

                 (if (funcall test-equal (funcall key it) (funcall key (node-item q)))

                     (return-from insert-item (values root q t)))

                 (setf p q)

                 (if (funcall test (funcall key it) (funcall key (node-item q)))

                     (setf q (left q))

                   (setf q (right q)))))

  (setf n (init (make-rbt-node :node-item it :color :red :parent p)))

  (if p

      (if (funcall test (funcall key it) (funcall key (node-item p)))

          (setf (left p) n)

        (setf (right p) n))

    (setf new-root n))

  (setf new-root (fix-insert n new-root))

  (values new-root n nil)))


(declaim (inline left-to-grandparent)

         (inline right-to-grandparent)

         (inline uncle-over-right)

         (inline uncle-over-left)

         (inline is-right-child)

         (inline is-left-child)

         (inline blacken)

         (inline redden)

         (inline is-black)

         (inline is-red)

         (inline grand-parent))


(defun left-to-grandparent (node)

  (eql (parent node) (left (parent (parent node)))))


(defun right-to-grandparent (node)

  (eql (parent node) (right (parent (parent node)))))


(defun uncle-over-right (node)

  (right (parent (parent node))))


(defun uncle-over-left (node)

  (left (parent (parent node))))



(defun is-right-child (node)

  (eql node (right (parent node))))


(defun is-left-child (node)

  (eql node (left (parent node))))


(defun blacken (node)

  (setf (color node) :black))


(defun redden (node)

  (setf (color node) :red))



(defun is-red (node)

  (eql (color node) :red))


(defun is-black (node)

  (eql (color node) :black))
    

(defun grand-parent (node)

  (parent (parent node)))






(defun fix-insert (pivot root)

  (let ((new-root 

         (loop with y = nil

               with x = pivot

               with res = nil

               with new-root = root

               finally (return new-root)

               while (and (not (eql x new-root)) (is-red (parent x)))

               do

               (cond ((left-to-grandparent x)

                      (setf y (uncle-over-right x))

                      (cond ((is-red y)          

                             (blacken (parent x))

                             (blacken y)

                             (redden (grand-parent x))

                             (setf x (grand-parent x)))

                            (t
          

                             (when (is-right-child x)

                               (setf x (parent x))

                               (setf res (rotate-left x))

                               (when res

                                 (setf new-root res)))

                             (blacken (parent x))

                             (redden (grand-parent x))

                             (setf res (rotate-right (grand-parent x)))

                             (when res

                               (setf new-root res)))))

                     (t

                      (setf y (uncle-over-left x))

                      (cond ((is-red y)           

                             (blacken (parent x))

                             (blacken y)

                             (redden (grand-parent x))

                             (setf x (grand-parent x)))

                            (t
         
                             (when (is-left-child x)

                               (setf x (parent x))

                               (setf res (rotate-right x))

                               (when res

                                 (setf new-root res)))

                             (blacken (parent x))

                             (redden (grand-parent x))

                             (setf res (rotate-left (grand-parent x)))

                             (when res

                               (setf new-root res)))))))))

 

    (blacken new-root)

    new-root))



;
; find-item returns nil
; or
; pointer to the node in the tree root with item it
;

(defun find-item (it root &key (test-equal #'=) (test #'<) (key #'identity))

  (loop with p = root

        named find-loop

        finally (return-from find-loop nil)

        while (not (rbt-null p))

        do

        (cond ((funcall test-equal (funcall key it) (funcall key (node-item p)))
               
               (return-from find-loop p))

              ((funcall test (funcall key it) (funcall key (node-item p))) (setf p (left p)))

              (t (setf p (right p))))))





(defun delete-item (it root)

  (delete-node (find-item it root) root))



;
;  delete-node returns
;  root t, if deletion done
;  root nil, if no deletion done
;


(defun delete-node (delnode root)

  (let ((y delnode)

        (x nil)

        (z nil)

        (newroot nil))

    (assert (not (null y)) () "Error: Delnode is NIL")

    (cond ((rbt-null y) (return-from delete-node (values root nil)))

          ((rbt-null (left y))

           (setf x delnode)

           (setf z (right y)))

          ((rbt-null (right y))

           (setf x delnode)

           (setf z (left y)))

          (t (loop with p = (right y)

                   while (not (rbt-null (left p)))

                   finally (setf x p)

                   do

                   (setf p (left p)))))

    (when (null z)   ;occurs iff case t in above cond selected
           
      (setf (node-item y) (node-item x))

      (setf z (right x)))

    (when (eql x root)

      (setf newroot z)

      (blacken z)

      (return-from delete-node (values newroot t)))

    (if (is-left-child x)

        (setf (left (parent x)) z)

      (setf (right (parent x)) z))

    (unless (rbt-null z)

      (setf (parent z) (parent x)))

    (when (is-black x)
            
      (when (is-red z)

        (blacken z)

        (return-from delete-node (values root t)))

      ; now (rbt-null z) is true

      (setf newroot (fix-delete z (parent x) root))
      
      (return-from delete-node (values newroot t)))

    (values root t)))



    

           

;
; this is my (JB) own version of the red-black correction after deletion
; it comprises 8 subcases and works upward from deletion-point towards root
; it returns the root of the rebalanced tree
;
;



(defun fix-delete (piv parpiv root)

  (let ((newpiv))

    (format nil "piv = ~A * parpiv = ~A~%" piv parpiv)

 
    (loop
     while (not (eql piv root))
     finally (return-from fix-delete root)
     do
     (setf newpiv t)

     (assert (is-black piv) () "piv not black error")
     (assert (or (eql piv (left parpiv)) (eql piv (right parpiv))) () "piv not son of parpiv error")

     (if (eql (left parpiv) piv)
         (let ((alpha parpiv)
               (beta)
               (gamma)
               (delta))

           (assert (eql piv (left parpiv)) () "Error: not left son")


           (cond ((is-red alpha)
                  (setf beta (right alpha))
                  (setf gamma (left beta))
                  (cond ((is-black gamma)       ;1a
                         (setf root (or (rotate-left alpha) root))
                         (debug-case-message "1a"))
                        (t (setf root (or (rotate-right beta) root))  ; 1b
                           (setf root (or (rotate-left alpha) root))
                           (blacken alpha)
                           (debug-case-message "1b")))
                  (return-from fix-delete root))
                 ((is-black alpha)
                  (setf beta (right alpha))
                  (cond ((is-black beta)
                         (setf gamma (left beta))
                         (setf delta (right beta))
                         (cond ((is-red gamma)
                                (cond ((is-red delta)
                                       (redden beta)
                                       (blacken gamma)
                                       (blacken delta)
                                       (debug-case-message "2c->3")) ; 2c -> 3
                                      (t (setf root (or (rotate-right beta) root))
                                         (setf root (or (rotate-left alpha) root))
                                         (blacken gamma)
                                         (debug-case-message "2b1")
                                         (return-from fix-delete root)))) ; 2b1
                               (t ; gamma is black, now decide if delta is black too (2a) or red (2b2)
                                (cond ((is-red delta)
                                       (setf root (or (rotate-left alpha) root))
                                       (blacken delta)
                                       (debug-case-message "2b2")
                                       (return-from fix-delete root)) ; this was 2b2
                                      (t ; now comes 2a
                                       (redden beta)
                                       (debug-case-message "2a")
                                       (setf newpiv alpha))))))
                        (t ; this means beta is red, this gives cases 3a and 3b
                         (setf gamma (left beta))
                         (setf delta (left gamma))
                         (cond ((is-red delta)   ; this is 3b
                                (setf root (or (rotate-left alpha) root))
                                (setf root (or (rotate-right gamma) root))
                                (setf root (or (rotate-left alpha) root))
                                (blacken beta)
                                (debug-case-message "3b")
                                (return-from fix-delete root))
                               (t  ; this is 3a
                                (setf root (or (rotate-left alpha) root))
                                (setf root (or (rotate-left alpha) root))
                                (redden alpha)
                                (blacken beta)
                                (debug-case-message "3a")
                                (return-from fix-delete root))))))))

       ;the following code is dual under left-right
   
       (let ((alpha parpiv)
             (beta)
             (gamma)
             (delta))

         (assert (eql piv (right parpiv)) () "Error: not right son")

         (format nil "Left side~%")
         (cond ((is-red alpha)
                (setf beta (left alpha))
                (setf gamma (right beta))
                (cond ((is-black gamma)       ;1a
                       (setf root (or (rotate-right alpha) root))
                       (debug-case-message "1a"))
                      (t (setf root (or (rotate-left beta) root))  ; 1b
                         (setf root (or (rotate-right alpha) root))
                         (blacken alpha)
                         (debug-case-message "1b")))
                (return-from fix-delete root))
               ((is-black alpha)
                (setf beta (left alpha))
                (cond ((is-black beta)
                       (setf gamma (right beta))
                       (setf delta (left beta))
                       (cond ((is-red gamma)
                              (cond ((is-red delta)
                                     (redden beta)
                                     (blacken gamma)
                                     (blacken delta)
                                     (debug-case-message "2c->3")) ; 2c -> 3
                                    (t (setf root (or (rotate-left beta) root))
                                       (setf root (or (rotate-right alpha) root))
                                       (blacken gamma)
                                       (debug-case-message "2b1")
                                       (return-from fix-delete root)))) ; 2b1
                             (t ; gamma is black, now decide if delta is black too (2a) or red (2b2)
                              (cond ((is-red delta)
                                     (setf root (or (rotate-right alpha) root))
                                     (blacken delta)
                                     (debug-case-message "2b2")
                                     (return-from fix-delete root)) ; this was 2b2
                                    (t ; now comes 2a
                                     (redden beta)
                                     (debug-case-message "2a")
                                     (setf newpiv alpha))))))
                      (t ; this means beta is red, this gives cases 3a and 3b
                       (setf gamma (right beta))
                       (setf delta (right gamma))
                       (cond ((is-red delta)   ; this is 3b
                              (setf root (or (rotate-right alpha) root))
                              (setf root (or (rotate-left gamma) root))
                              (setf root (or (rotate-right alpha) root))
                              (blacken beta)
                              (debug-case-message "3b")
                              (return-from fix-delete root))
                             (t  ; this is 3a
                              (setf root (or (rotate-right alpha) root))
                              (setf root (or (rotate-right alpha) root))
                              (redden alpha)
                              (blacken beta)
                              (debug-case-message "3a")
                              (return-from fix-delete root)))))))))

                           

     (unless (eql newpiv t)

       (setf piv newpiv)

       (format nil "(parent piv) = ~A  * (eql piv root) = ~A~%" (parent piv) (eql piv root))

       (setf parpiv (parent piv))))))

                           

(defun debug-case-message (s)

  (format nil "Fall = ~A~%" s))
          




(defun nil-tree ()

  *sentinel*)

       


(defun display-tree (root &key (key #'identity))

  (cond

   ((rbt-null root) nil)

   (t (list 

       (format nil "Color: ~A - Item ~A" (color root) (funcall key (node-item root))) 

       (display-tree (left root)) 

       (display-tree (right root))))))


(defun item-list (root)

  (cond ((rbt-null root) nil)

        (t (let ((l (item-list (left root)))

                 (r (item-list (right root))))

             (append l (list (node-item root)) r)))))


(defun test-tree (l)

  (let ((tree (nil-tree)))

    (loop for n in l

          finally (return tree)

          do

          (setf tree (insert-item n tree)))))



(defun dt (l)

  (graph-app (display-tree (test-tree l))))

(defun dtt (tree)

  (graph-app (display-tree tree)))



(defun check-rbt (root)

  (labels ((check-recursive (node)

                            (cond ((rbt-null node) 1)

                                  (t (let ((a (check-recursive (left node)))

                                           (b (check-recursive (right node))))

                                       (if (or (null a) (null b) (/= a b))

                                           nil

                                         (cond ((is-black node) (1+ a))

                                               (t

                                                (if (and (is-black (left node))

                                                         (is-black (right node)))

                                                    a

                                                  nil)))))))))

    (and (is-black root) (check-recursive root))))
    
  

  


(defun super-test (n k)

  (dotimes (i n)

    (let* ((len k)

           (lis nil)

           (root nil))

      (if (zerop (mod i 50)) (format t "i = ~A~%" i))

      (dotimes (j len)
        
        (push (random 200) lis))

      (setf root (test-tree lis))

      (if (null (check-rbt root))

        (error "RBT-property not fulfilled"))

      (setf lis (item-list root))

;      (setf lis (butlast lis 5))

      (loop with it = nil

            while (not (null lis))

            do

            (setf it (nth (random (length lis)) lis))

            (setf lis (remove it lis))
            
            (setf root (delete-item it root))
            
            (when (null (check-rbt root))

              (setf err-tree root)
              
              (error "Mistake in delete-function")))

      (format nil "Len lis = ~A~%" (length (item-list root))))))