; by Alex Klinkhamer  (:handle grencez)
; Update: 2008.07.19
;
;  Legal info:
; You may exploit this code,
;    and it may exploit you.
; I am not responsible for either.


; Preface:
; This heap implementation is a tree
;    with each leaf/node of the form
; (val (node . dat) c1 . c2)
;    where /val/ is the node's associated value,
; /node/ is the node, see the part about /refp/ below,
; /dat/ is any extra data associated with it
;    to avoid usage of the :key... keyword, and
; /c1/ and /c2/ are child nodes which
;    can be viewed as heaps themselves.
;
; So, the overall heap is just the top node.
; 
;
; /refp/ = (node . dat) is a reference to /node/.
;    It is valid until /node/ leaves the heap.
;    It is acquired as the return value of HEAP-ADD.
;    Remove /node/ from the heap with
;       (pull-heap (car refp) pred)
; 
; The same persistance cannot be achieved by storing
;    /node/, After enough push/pop operations,
;    different data will be stored in that location.

;;; Somewhat useless... just ensures
;;; that *print-circle* is true
(defun print-heap (h)  
  (let ((*print-circle* t))
    (prin1 h) (terpri)))

;;; Peek in heap /h/ for thing defined by /spec/.
(defmacro pkinheap (spec h)
  (assert
    (and (consp spec)
         (eq (car spec) 'quote))
    (spec)
    "pkinheap: Argument must be a quoted symbol:~
    ~{ '~S~}~%"
    '(value data cons refp))
  (ecase (cadr spec)
    (value `(car ,h))
    (data `(cdadr ,h))
    (cons `(cons (car ,h) (cdadr ,h)))
    (refp `(cadr ,h))))

;;; Stupid
(defun mapcheap (fn h)
  (when (car h)
    (funcall fn (car h) (cdadr h))
    (mapcheap (caddr h))
    (mapcheap (cdddr h))))

;;; Transform a list of form (nil)
;;; to a heap of form
;;; (val (heap . dat) (nil) nil)
;;; or, if /refp/ is true, /dat/ is
;;; of the form (node . dat)
(defmacro nheap (val h &key ((:data dat)) refp)
  `(rplacd (rplaca ,h ,val)
           (list ,(if refp `(rplaca ,refp ,h)
                    `(cons ,h ,dat))
                 (list nil) nil)))

;;; Make a heap using nheap's coolness.
(defun make-heap (&optional val dat)
  (nheap val (list nil) :data dat))

;;; Push an element onto the heap.
;;; refp = (node . dat)
(defun push-heap (x refp h)
  (if (car h)
    (progn
      (rotatef (caddr h) (cdddr h))
      (push-heap
        (shiftf (car h) x);< value
        (shiftf (cadr h) (rplaca refp h))
        (cdddr h)));< pushed child
    (nheap x h :refp refp)))

;;; Correctly swap two nodes without
;;; fudging any external references.
(defmacro swap-heap-tops (a b)
  `(progn
     (rotatef (car ,a) (car ,b))
     (rplaca (cdr ,b)
             (rplaca (shiftf (cadr ,a)
                             (rplaca (cadr ,b) ,a))
                     ,b))))

;;; Any children of /node/ will be lost.
(defun heap-add-node (node h pred)
  (if (car h)
    (progn
      (rotatef (caddr h) (cdddr h))
      (if (funcall pred (car node) (car h))
        (push-heap
          (shiftf (car h) (car node))
          (shiftf (cadr h) (rplaca (cadr node) h))
          (cdddr h))
        (heap-add-node node (cdddr h) pred)))
    (nheap (car node) h :refp (cadr node))))

;;; Add an element into the heap
;;; along with other optional data.
(defun heap-add (x h pred &optional dat)
  (let ((node (make-heap x dat)))
    (heap-add-node node h pred)
    (cadr node)))

;;; The first heap is modified to contain all
;;; elements between the two heaps. The second
;;; heap is destroyed but all references to nodes
;;; remain valid in the new heap.
(defun merge-heaps (h1 h2 pred &optional tnode)
  (if (car h2)
    (if (car h1)
      (if tnode
        (progn
          (if (funcall pred (car h2) (car h1))
            (if (funcall pred (car tnode) (car h2))
              (swap-heap-tops h1 tnode)
              (swap-heap-tops h1 h2))
            (when (funcall pred (car tnode) (car h1))
              (swap-heap-tops h1 tnode)))
          (merge-heaps (caddr h1) (cdddr h2) pred tnode)
          (merge-heaps (cdddr h1) (caddr h2) pred h2))
        (progn
          (when (funcall pred (car h2) (car h1))
            (swap-heap-tops h1 h2))
          (merge-heaps (cdddr h1) (cdddr h2) pred)
          (merge-heaps (caddr h1) (caddr h2) pred h2)))
      (progn
        (rplacd (rplaca h1 (car h2))
                (cons (rplaca (cadr h2) h1)
                      (cddr h2)))
        (when tnode (heap-add-node tnode h1 pred))))
    (when tnode (heap-add-node tnode h1 pred))))

;;; Pop without specific return value.
(defun pull-heap (h pred)
  (macrolet
    ((pull-child
       (child)
       ;; Pull the child node up to replace
       ;; the top of /h/. Then recurse.
       `(progn (rplaca (cdr (rplaca h (car ,child)))
                       (rplaca (cadr ,child) h))
               (pull-heap ,child pred))))
    (destructuring-bind
      (c1 . c2) (cddr h)
      (if (car c2)
        (if (car c1)
          (if (funcall pred (car c1) (car c2))
            (pull-child c1)
            (progn (rotatef (caddr h) (cdddr h))
                   (pull-child c2)))
          (pull-child c2))
        (if (car c1);< False if only add
          ;^ and pop operations are used.^
          (pull-child c1)
          (rplaca (rplacd h nil) nil))))))

;;; Uses PKINHEAP for /spec/.
(defmacro pop-heap-for (spec h pred)
  `(prog1 (pkinheap ,spec ,h)
     (pull-heap ,h ,pred)))

;;; The standard peek and pop functions
;;; return the value and data at the
;;; heap's top using multiple values.
(defun peek-heap (h)
  (if (car h)
    (values (car h) (cdadr h))
    (values nil nil)))

(defun pop-heap (h pred)
  (if (car h)
    (let ((val (car h))
          (dat (cdadr h)))
      (pull-heap h pred)
      (values val dat))
    (values nil nil)))

;;; Loop through all the nodes in /h/ in order.
(defmacro doheap ((sym h pred . s-first-do) . body)
  (unless s-first-do
    (setq s-first-do body))
  (let* ((theap (gensym))
         (c1 (gensym)) (c2 (gensym))
         (s-theap-add-children
           `(destructuring-bind (,c1 . ,c2) (cddr ,sym)
              (when (car ,c1)
                (heap-add (car ,c1) ,theap ,pred ,c1))
              (when (car ,c2)
                (heap-add (car ,c2) ,theap ,pred ,c2))))
         (begin-tag (gensym)) (end-tag (gensym)))
    `(when (car ,h)
       (block
         nil
         (let ((,theap (make-heap))
               (,sym ,h))
           ,s-theap-add-children
           ,@s-first-do
           (tagbody
             ,begin-tag
             (unless (pkinheap 'value ,theap)
               (go ,end-tag))
             (setq ,sym (pop-heap-for 'data  ,theap ,pred))
             ,s-theap-add-children
             ,@body
             (go ,begin-tag)
             ,end-tag))))))

;;; Search for an element in the heap by value.
;;; This function is subject to change.
(defun search-heap (val h pred &key (test #'=))
  (doheap (node h pred)
          (unless (funcall pred (car node) val)
            (return
              (when (funcall test val (car node))
                node)))))

(defun mapcar-heap
  (fn h pred &aux lis tail)
  (doheap
    (node h pred
          (setq lis (list (funcall fn node))
                tail lis))
    (setf tail
          (setf (cdr tail)
                (list (funcall fn node)))))
  lis)

(defun list-heap (h pred &key datap refp)
  (mapcar-heap
     (if refp #'cadr
       (if datap
         ;; Pair the values with data
         (lambda (node)
           (cons (car node)
                 (cdadr node)))
         ;V Just list values.V
         #'car))
     h pred))