Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

71 lines (64 sloc) 2.681 kb
(defpackage :ramarren-utils (:use :common-lisp)
(:export heapify heap-empty nheap-insert heap-peek nheap-extract))
(in-package :ramarren-utils)
;heap anyway, as an array
(defun heap-parent (i) (truncate (/ (1- i) 2)))
(defun heap-rchild (i) (+ (* 2 i) 2))
(defun heap-lchild (i) (+ (* 2 i) 1))
(defun nheap-insert (what where);destructive
(declare (inline heap-parent))
(vector-push-extend what (car where))
(flet ((wheref (i) (aref (car where) i))
((setf wheref) (nval i) (setf (aref (car where) i) nval)))
;percolate
(do ((el (1- (length (car where))) (heap-parent el)))
((or
(= el 0)
(funcall (cadr where) (wheref (heap-parent el)) (wheref el))) where)
(let ((tel (wheref el)))
(setf (wheref el) (wheref (heap-parent el)))
(setf (wheref (heap-parent el)) tel)))))
(defun heap-peek (where)
(unless (heap-empty where)
(aref (car where) 0)))
(defun heap-empty (where)
(if (zerop (length (car where)))
t
nil))
(defun nheap-extract (where)
(declare (inline heap-parent heap-rchild heap-lchild))
(if (heap-empty where)
nil
(flet ((wheref (i) (aref (car where) i))
((setf wheref) (nval i) (setf (aref (car where) i) nval)))
(let ((topel (wheref 0))(lght (length (car where))))
(setf (wheref 0) (wheref (1- lght)))
(vector-pop (car where))
;reheap
(do ((el 0))
((and
(if (< (heap-lchild el) lght)
(funcall (cadr where) (wheref el) (wheref (heap-lchild el)))
t)
(if (< (heap-rchild el) lght)
(funcall (cadr where) (wheref el) (wheref (heap-rchild el)))
t))
topel)
(let ((tel (wheref el)))
(if;either both children exist
(< (heap-rchild el) lght)
(if (funcall (cadr where) (wheref (heap-lchild el))(wheref (heap-rchild el)))
(setf (wheref el) (wheref (heap-lchild el))
(wheref (heap-lchild el)) tel
el (heap-lchild el))
(setf (wheref el) (wheref (heap-rchild el))
(wheref (heap-rchild el)) tel
el (heap-rchild el)))
(setf (wheref el) (wheref (heap-lchild el));or just the left one, tree is balanced
(wheref (heap-lchild el)) tel
el (heap-lchild el)))))))))
(defun heapify (what compar) "Turns list into a heap"
(let ((arry (list (make-array (max (length what) 20) :adjustable t :fill-pointer 0) compar))
(mwhat (if (vectorp what) (map 'list #'identity what) what)))
(dolist (el mwhat) (nheap-insert el arry))
arry))
Jump to Line
Something went wrong with that request. Please try again.