(in-package :binary-trees)

(defun make-sentinel-node (node-class initargs)
  (let ((x (apply #'make-instance node-class :rank 0 initargs)))
    (setf (left x) x
          (right x) x
          (parent x) x)))

(defmethod make-binary-tree-node ((tree binary-tree) item)
  (let ((null-node (sentinel-node tree)))
    (make-instance 'binary-tree-node
                   :left null-node
                   :right null-node
                   :parent null-node
                   :datum item)))

(defmethod make-binary-tree ((type (eql :normal)) &key compfun eqfun keyfun)
  (let* ((sentinel-node (make-sentinel-node 'binary-tree-node nil)))
    (make-instance 'binary-tree
                   :compfun compfun
                   :eqfun eqfun
                   :keyfun keyfun
                   :sentinel-node sentinel-node
                   :root-node sentinel-node)))

(declaim (inline null-node-p emptyp))
(defun null-node-p (node tree)
  (eq node (sentinel-node tree)))
(defun emptyp (tree)
  (null-node-p (root-node tree) tree))

(defun size (tree)
  "Return the number of items currently stored in TREE."
  (tree-size tree))
(defun (setf size) (new-value tree)
  (setf (tree-size tree) new-value))

(macrolet ((defrotate (fun-name which-child child-child)
               `(defun ,fun-name (tree parent)
                 (with-slots (sentinel-node root-node) tree
                   (let ((current (,which-child parent))
                         (pp (parent parent)))
                     (when (not (null-node-p current tree))
                       (setf (,which-child parent) (,child-child current))
                       (when (not (null-node-p (,child-child current) tree))
                         (setf (parent (,child-child current)) parent))
                       (setf (parent current) pp)
                       (if (null-node-p pp tree)
                           (setf root-node current
                                 (parent current) sentinel-node)
                           (if (eq parent (left pp))
                               (setf (left pp) current)
                               (setf (right pp) current)))
                       (setf (,child-child current) parent)
                       (setf (parent parent) current)
                       ,(if (eq fun-name 'rotate-right)
                            '(decf (rank parent) (rank current))
                            '(incf (rank current) (rank parent))))
                     current)))))
  (defrotate rotate-left right left)
  (defrotate rotate-right left right))

(defun insert-node (tree parent side item)
  (let ((new-node (make-binary-tree-node tree item)))
    (incf (size tree))
    (setf (slot-value parent side) new-node
          (parent new-node) parent)
    new-node))

(defun tree-insert-empty (tree item)
  (incf (size tree))
  (setf (root-node tree) (make-binary-tree-node tree item))
  (values (funcall (keyfun tree) item) t))

(defun insert (tree item)
  "Attempt to insert ITEM into TREE.  ITEM must be of a suitable type
for TREE's comparision, equality, and key functions.  Returns two
values; the first is the key of ITEM and the second indicates whether
ITEM was inserted or not."
  (if (emptyp tree)
      (tree-insert-empty tree item)
      (tree-insert-nonempty tree item)))

(defmethod insert-at-node ((tree binary-tree) item parent direction-stack)
  (insert-node tree parent (first direction-stack) item))

(defun tree-insert-nonempty (tree item)
  (with-slots (compfun eqfun keyfun root-node) tree
    (let ((item-key (funcall keyfun item))
          (direction-stack nil))
      (do ((node root-node (slot-value node (first direction-stack)))
           (sentinel (sentinel-node tree))
           (parent-node (sentinel-node tree) node))
          ((eq node sentinel)
           (insert-at-node tree item parent-node direction-stack)
           (values item-key t))
        (let ((node-key (funcall keyfun (datum node))))
          (cond
            ((funcall eqfun node-key item-key)
             ;; undo the rank updates (ugh, FIXME)
             (do ((stack direction-stack (rest stack))
                  (node (parent node) (parent node)))
                 ((null stack)
                  ;; indicate that we didn't insert
                  (return-from tree-insert-nonempty (values node-key nil)))
               (when (eq 'left (first stack))
                 (decf (rank node)))))
            ((funcall compfun item-key node-key)
             (incf (rank node))
             (push 'left direction-stack))
            (t
             (push 'right direction-stack))))))))

(defun lower-bound-node (key tree)
  "Return the node in TREE possessing a key which is equal to or
less than KEY."
  (with-slots (compfun eqfun keyfun root-node) tree
    (labels ((locate-node (node candidate)
               (cond
                 ((null-node-p node tree) candidate)
                 ((funcall compfun key (funcall keyfun (datum node)))
                  (locate-node (left node) candidate))
                 (t
                  (locate-node (right node) node)))))
      (locate-node root-node (sentinel-node tree)))))

(defun lower-bound (key tree)
  "Return the item in TREE possessing a key which is equal to or
lessthan KEY.  Returns NL if there is no such item."
  (let ((node (lower-bound-node key tree)))
    (if (null-node-p node tree)
        nil
        (datum node))))

(defun upper-bound-node (key tree)
  "Return the node in TREE posessing a key which is equal to or
greater than KEY."
  (with-slots (compfun eqfun keyfun root-node) tree
    (labels ((locate-node (node candidate)
               (cond
                 ((null-node-p node tree) candidate)
                 ((funcall compfun key (funcall keyfun (datum node)))
                  (locate-node (left node) node))
                 (t
                  (locate-node (right node) candidate)))))
      (locate-node root-node (sentinel-node tree)))))

(defun upper-bound (key tree)
  "Return the item in TREE possessing a key which is equal to or
greater than KEY.  Returns NIL if there is no such item."
  (let ((node (upper-bound-node key tree)))
    (if (null-node-p node tree)
        nil
        (datum node))))

(defun find-node-with-key (tree key)
  "Find the node in TREE with key KEY.  Might return the null node if no
such node can be found."
  (with-slots (eqfun keyfun) tree
    (let ((node (lower-bound-node key tree)))
      (cond
        ((null-node-p node tree) node)
        ((funcall eqfun key (funcall keyfun (datum node))) node)
        (t (sentinel-node tree))))))

(defun find (key tree)
  "Find the item in TREE whose key is KEY and returns the associated item
and T as multiple values, or returns NIL and NIL if no such item exists."
  (with-slots (eqfun keyfun) tree
    (let ((node (lower-bound-node key tree)))
      (cond
        ((null-node-p node tree) (values nil nil))
        ((funcall eqfun key (funcall keyfun (datum node)))
         (values (datum node) t))
        (t (values nil nil))))))

(defun minimum-node (tree root-node)
  (do ((node root-node (left node))
       (sentinel (sentinel-node tree))
       (parent root-node node))
      ((eq node sentinel) parent)))

(defun maximum-node (tree root-node)
  (do ((node root-node (right node))
       (sentinel (sentinel-node tree))
       (parent root-node node))
      ((eq node sentinel) parent)))

;;; remove node from the tree using the algorithm from CLRS
(defun splice-out-node (tree node)
  (decf (size tree))
  (let* ((deleted (if (or (null-node-p (left node) tree)
                          (null-node-p (right node) tree))
                      node
                      (minimum-node tree (right node))))
         (lone-child (if (not (null-node-p (left deleted) tree))
                         (left deleted)
                         (right deleted)))
         (low-subtree 'right))
    (setf (parent lone-child) (parent deleted))
    (if (null-node-p (parent deleted) tree)
        (setf (root-node tree) lone-child
              low-subtree (if (eq lone-child (left deleted))
                              'left
                              'right))
        (if (eq deleted (left (parent deleted)))
            (setf (left (parent deleted)) lone-child
                  (rank (parent deleted)) (1- (rank (parent deleted)))
                  low-subtree 'left)
            (setf (right (parent deleted)) lone-child
                  low-subtree 'right)))
    (when (not (eq deleted node))
      (setf (datum node) (datum deleted)))
    ;; fixup the rank values.  a little slower to do it here than
    ;; in the various rebalancing routines that come after this
    ;; function is called, but it's a lot easier on the neurons
    #+nil (format t "~%deleted ~A, lone-child ~A~%" deleted lone-child)
    (do ((node (parent lone-child) (parent node)))
        ((or (null-node-p node tree)
             (eq node (root-node tree))) (values deleted lone-child low-subtree))
      (when (eq node (left (parent node)))
        (decf (rank (parent node)))))))

(defun delete (key tree)
  "Attempt to remove the item with KEY from TREE.  Returns T on success,
NIL on failure."
  ;; FIXME: this seems way too complicated.  are we shooting ourselves
  ;; in the foot by attempting to make this as general as possible?
  (multiple-value-bind (deleted direction) (find-node-with-key tree key)
    (declare (ignore direction))
    (if (null-node-p deleted tree)
        nil
        (multiple-value-bind (actual-deleted child low-subtree)
            (splice-out-node tree deleted)
          (tree-delete-nonempty tree actual-deleted child low-subtree)))))

(defmethod tree-delete-nonempty ((tree binary-tree) deleted child low-subtree)
  t)

(defun minimum (tree)
  "Return the item with the minimum key in TREE.  It is an error to ask
for the minimum item of an empty tree."
  (if (emptyp tree)
      (error "Empty tree")
      (datum (minimum-node tree (root-node tree)))))

(defun maximum (tree)
  "Return the item with the maximum key in TREE. It is an error to ask
for the maximum item of an empty tree."
  (if (emptyp tree)
      (error "Empty tree")
      (datum (maximum-node tree (root-node tree)))))

(defun select-node (tree k)
  (labels ((select-loop (node k)
             (let ((rank (1- (rank node))))
               (cond
                 ((= k rank) node)
                 ((< k rank) (select-loop (left node) k))
                 (t (select-loop (right node) (- k rank 1)))))))
  (cond
    ((or (minusp k)
         (>= k (size tree))) (error "Invalid index value"))
    ((emptyp tree) (error "Empty tree"))
    (t (select-loop (root-node tree) k)))))

(defun select (tree k)
  "Return the Kth item (zero-based) in TREE."
  (datum (select-node tree k)))





; an extension for test purposes by me (JB)

(defun item-list (tree)

  (item-list1 (root-node tree) tree))


(defun item-list1 (rootnode tree)

  (if (null-node-p rootnode tree)

      nil

    (let ((l (item-list1 (left rootnode) tree))

          (r (item-list1 (right rootnode) tree)))

      (append l (list (datum rootnode)) r))))