(defpackage :pr-tree
    (:use :clim-lisp :clim))

(in-package :pr-tree)

;;;; API

;; MAKE-ITREE
;; ITREE-PUT itree x1 x2 item
;; ITREE-REMOVE itree x1 x2 item
;; ITREE-GET itree x1 x2 -> items


;;;;

(defmacro dada ((&rest substs) &body body)
  "This is an evil macro."
  (setf substs (sort substs #'> :key (lambda (s) (length (symbol-name (first s))))))
  `(progn
     ,@(loop for k from 1 below (length (first substs)) collect
             (labels ((subst-one (new old sym)
                        (let ((p (search (symbol-name old) (symbol-name sym))))
                          (cond ((not (null p))
                                 (let ((pack (if (eq (symbol-package sym)
                                                     (find-package :keyword))
                                                 (symbol-package sym)
                                               *package*)))
                                   (intern (concatenate 'string
                                             (subseq (symbol-name sym) 0 p)
                                             (symbol-name new)
                                             (subseq (symbol-name sym)
                                                     (+ p (length (symbol-name old)))))
                                           pack)))
                                (t
                                 sym))))
                      (walk (x)
                        (cond ((symbolp x)
                               (dolist (subst substs)
                                 (setf x (subst-one (elt subst k) (first subst) x)))
                               x)
                              ((atom x) x)
                              ((consp x)
                               (cons (walk (car x)) (walk (cdr x)))))))
               `(locally
                  ,@(walk body))))))


;;;; --------------------------------------------------------------------------------
;;;;  Point Range Trees

;; This is a humble implementation of a PR-tree (point range tree).

;; The purpose of this tree is to map intervals to some values. It
;; therefore supports the basic operations:

;; INSERT (Tree, [a,b], id)     inserts the interval [a,b]
;; DELETE (Tree, [a,b], id)     removes an interval
;; SEARCH (Tree, [a,b])         find all id's of all intervals that intersect with [a,b]

;; Insertion and search perform in O(log n + m) where n is the number
;; of intervals stored and m is the number of intervals which overlap
;; with a given inserted or queried interval. Deletion performs in
;; O(n log^2 n + m). The space occupied is in O(n**2) and Omega(n).

;; For keeping the tree balanced we implement it as an AVL-tree.

;; This is somewhat inspired by Moez Chaabouni, Soon Chung: "The
;; Point-Range Tree: A Data Structure for Indexing Intervals".

;;; TODO
;; - explain nodes.
;; - actually have infinity
;; - implement deletion

(defstruct node
  ;; The skew of a node which indicates which branch is higher.
  (skew :none :type (member :none :left :right))
  ;; List of interval identifiers
  =)

(defstruct (point-node (:include node))
  value
  (left  nil :type (or null node))
  (right nil :type (or null node)))

(defstruct (range-node (:include node))
  value1
  value2)

(defun make-pr-tree ()
  (make-range-node
   :value1 most-negative-fixnum
   :value2 most-positive-fixnum
   := nil))

(dada ((<left>  left  right)
       (<right> right left))

      (defun avl-to-<left> (n)
        "Rotate an AVL tree node."
        (rotatef n (point-node-<right> n) (point-node-<left> (point-node-<right> n)))
        n)

      (defun avl-<left>-grown (n)
        "This function is called when ever the {left|right} branch of
         'n' has grown. It then balances the tree if neccessary."
        (case (node-skew n)
          (:<left>
           (case (node-skew (point-node-<left> n))
             (:<left>
              (setf (node-skew n) :none)
              (setf (node-skew (point-node-<left> n)) :none)
              (setf n (avl-to-<right> n))
              (values n :ok))
             ;;
             (otherwise
              (setf (values (node-skew n) (node-skew (point-node-<left> n)))
                    (case (node-skew (point-node-<right> (point-node-<left> n)))
                      (:<left>  (values :<right> :none))
                      (:<right> (values :none :<left>))
                      (:none    (values :none :none))))
              (setf (node-skew (point-node-<right> (point-node-<left> n))) :none)
              (setf (point-node-<left> n) (avl-to-<left> (point-node-<left> n))
                    n (avl-to-<right> n))
              (values n :ok))))
          (:<right>
           ;; Left branch grew, while its height was less than the
           ;; height of the right branch -- this makes the node
           ;; perfectly balanced.
           (setf (node-skew n) :none)
           (values n :ok))

          (:none
           ;; Left branch grew, while node was perfectly balanced --
           ;; this node gets a skew of :left. Also further balancing
           ;; might apply.
           (setf (node-skew n) :<left>)
           (values n :balance)) )) )

(defun add-pivot (node x &aux balancep)
  (typecase node
    (point-node
     (cond ((= (point-node-value node) x)
            node)
           ((< x (point-node-value node))
            (setf (values (point-node-left node) balancep)
                  (add-pivot (point-node-left node) x))
            (if (eq balancep :balance)
                (avl-left-grown node)
                node))
           ((> x (point-node-value node))
            (setf (values (point-node-right node) balancep)
                  (add-pivot (point-node-right node) x))
            (if (eq balancep :balance)
                (avl-right-grown node)
                node))))
    (range-node
     (values (make-point-node
              :value x
              :left (make-range-node
                     :value1 (range-node-value1 node)
                     :value2 x
                     := (node-= node))
              :right (make-range-node
                      :value1 x
                      :value2 (range-node-value2 node)
                      := (node-= node))
              := (node-= node))
             :balance))))

(defun map-over-nodes-containing-interval (function node x1 x2)
  "Applies function to all nodes in the tree which denote a range or a
point which intersects with the interval [x1, x2]."
  (typecase node
    ;; At a point node, descent the tree accordingly.
    (point-node
     (cond
       ;; The window is entirely right to this point node, so traverse
       ;; the right branch.
       ((< (point-node-value node) x1)
        (map-over-nodes-containing-interval function (point-node-right node) x1 x2))
       ;; The window is entirely left, so traverse left branch
       ((< x2 (point-node-value node))
        (map-over-nodes-containing-interval function (point-node-left node) x1 x2))
       ;; The point is within the window, so traverse both branches.
       (t
        (funcall function node)
        (map-over-nodes-containing-interval function (point-node-left node) x1 (point-node-value node))
        (map-over-nodes-containing-interval function (point-node-right node) (point-node-value node) x2))))
    ;; At the range node simply test if the window is contained within
    ;; its range.
    (range-node
     (when (or (<= (range-node-value1 node) x1 (range-node-value2 node))
               (<= (range-node-value1 node) x2 (range-node-value2 node)))
       (funcall function node)))))

(defstruct (itree (:constructor cons-itree (root)))
  root)

(defun make-itree ()
  (cons-itree (make-range-node
               :value1 most-negative-fixnum
               :value2 most-positive-fixnum
               := nil)))

(defun itree-put (itree x1 x2 item)
  (setf (itree-root itree) (add-pivot (itree-root itree) x1))
  (setf (itree-root itree) (add-pivot (itree-root itree) x2))
  (add-id (itree-root itree) x1 x2 item))

(defun itree-get (itree x1 x2)
  (retrieve-interval (itree-root itree) x1 x2))

(defun itree-rem (itree x1 x2 item)
  (rem-id (itree-root itree) x1 x2 item))

(defun retrieve-interval (node x1 x2)
  (typecase node
    (point-node
     (cond ((< (point-node-value node) x1)
            (retrieve-interval (point-node-right node) x1 x2))
           ((< x2 (point-node-value node))
            (retrieve-interval (point-node-left node) x1 x2))
           (t
            (progn;;union (node-= node)
              (union
               (retrieve-interval (point-node-left node) x1 (point-node-value node))
               (retrieve-interval (point-node-right node) (point-node-value node) x2))))))
    (range-node
     (when (or (<= (range-node-value1 node) x1  (range-node-value2 node))
               (<= (range-node-value1 node) x2  (range-node-value2 node)))
       (node-= node)))))

(defun add-id (node x1 x2 id)
  (typecase node
    (point-node
     (cond ((< (point-node-value node) x1)
            (add-id (point-node-right node) x1 x2 id))
           ((< x2 (point-node-value node))
            (add-id (point-node-left node) x1 x2 id))
           (t
            (push id (node-= node))
            (add-id (point-node-left node) x1 (point-node-value node) id)
            (add-id (point-node-right node) (point-node-value node) x2 id))))
    (range-node
     (when (and (<= x1 (range-node-value1 node) x2)
                (<= x1 (range-node-value2 node) x2))
       (push id (node-= node)))
     node)))

(defun rem-id (node x1 x2 id)
  (typecase node
    (point-node
     (cond ((< (point-node-value node) x1)
            (rem-id (point-node-right node) x1 x2 id))
           ((< x2 (point-node-value node))
            (rem-id (point-node-left node) x1 x2 id))
           (t
            (setf (node-= node) (remove id (node-= node)))
            (rem-id (point-node-left node) x1 (point-node-value node) id)
            (rem-id (point-node-right node) (point-node-value node) x2 id)))
     node)
    (range-node
     (when (and (<= x1 (range-node-value1 node) x2)
                (<= x1 (range-node-value2 node) x2))
       (setf (node-= node) (remove id (node-= node))))
     node)))