- Timestamp:
- 2016-05-30T20:50:14-07:00 (9 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/f4grobner/priority-queue.lisp
r3984 r3985 28 28 (defpackage "PRIORITY-QUEUE" 29 29 (:use :cl :heap) 30 (:export "*PRIORITY-QUEUE-ALLOCATION-SIZE*" 31 "PRIORITY-QUEUE" 32 "PRIORITY-QUEUE-HEAP" 33 "PRIORITY-QUEUE-TEST" 30 (:export "PRIORITY-QUEUE" 34 31 "MAKE-PRIORITY-QUEUE" 35 32 "PRIORITY-QUEUE-INSERT" … … 40 37 41 38 (in-package :priority-queue) 42 (defparameter *priority-queue-allocation-size* 16)43 44 (defun priority-queue-make-heap (&key (element-type 'fixnum))45 (make-array *priority-queue-allocation-size* :element-type element-type :fill-pointer 146 :adjustable t))47 39 48 40 (defstruct (priority-queue (:constructor priority-queue-construct)) 49 (heap ( priority-queue-make-heap))41 (heap (make-heap)) 50 42 test) 51 43 … … 54 46 (element-key #'identity)) 55 47 (priority-queue-construct 56 :heap ( priority-queue-make-heap :element-type element-type)48 :heap (make-heap :element-type element-type) 57 49 :test #'(lambda (x y) (funcall test (funcall element-key y) (funcall element-key x))))) 58 50 59 51 (defun priority-queue-insert (pq item) 60 ( priority-queue-heap-insert (priority-queue-heap pq) item (priority-queue-test pq)))52 (heap-insert (priority-queue-heap pq) item (priority-queue-test pq))) 61 53 62 54 (defun priority-queue-remove (pq) 63 ( priority-queue-heap-remove (priority-queue-heap pq) (priority-queue-test pq)))55 (heap-remove (priority-queue-heap pq) (priority-queue-test pq))) 64 56 65 57 (defun priority-queue-empty-p (pq) 66 ( priority-queue-heap-empty-p (priority-queue-heap pq)))58 (heap-empty-p (priority-queue-heap pq))) 67 59 68 60 (defun priority-queue-size (pq) 69 61 (fill-pointer (priority-queue-heap pq))) 70 71 (defun priority-queue-upheap (a k72 &optional73 (test #'<=)74 &aux (v (aref a k)))75 (declare (fixnum k))76 (assert (< 0 k (fill-pointer a)))77 (loop78 (let ((parent (ash k -1)))79 (when (zerop parent) (return))80 (unless (funcall test (aref a parent) v)81 (return))82 (setf (aref a k) (aref a parent)83 k parent)))84 (setf (aref a k) v)85 a)86 87 88 (defun priority-queue-heap-insert (a item &optional (test #'<=))89 (vector-push-extend item a)90 (priority-queue-upheap a (1- (fill-pointer a)) test))91 92 (defun priority-queue-downheap (a k93 &optional94 (test #'<=)95 &aux (v (aref a k)) (j 0) (n (fill-pointer a)))96 (declare (fixnum k n j))97 (loop98 (unless (<= k (ash n -1))99 (return))100 (setf j (ash k 1))101 (if (and (< j n) (not (funcall test (aref a (1+ j)) (aref a j))))102 (incf j))103 (when (funcall test (aref a j) v)104 (return))105 (setf (aref a k) (aref a j)106 k j))107 (setf (aref a k) v)108 a)109 110 (defun priority-queue-heap-remove (a &optional (test #'<=) &aux (v (aref a 1)))111 (when (<= (fill-pointer a) 1) (error "Empty queue."))112 (setf (aref a 1) (vector-pop a))113 (priority-queue-downheap a 1 test)114 (values v a))115 116 (defun priority-queue-heap-empty-p (a)117 (<= (fill-pointer a) 1))
Note:
See TracChangeset
for help on using the changeset viewer.